From e0d750bedbd33f7a133c8c82c35fd8db537ab649 Mon Sep 17 00:00:00 2001 From: simonpj Date: Wed, 26 Sep 2001 15:12:37 +0000 Subject: [PATCH] [project @ 2001-09-26 15:12:33 by simonpj] ------------------ Simon's big commit ------------------ This commit, which I don't think I can sensibly do piecemeal, consists of the things I've been doing recently, mainly directed at making Manuel, George, and Marcin happier with RULES. Reogranise the simplifier ~~~~~~~~~~~~~~~~~~~~~~~~~ 1. The simplifier's environment is now an explicit parameter. This makes it a bit easier to figure out where it is going. 2. Constructor arguments can now be arbitrary expressions, except when the application is the RHS of a let(rec). This makes it much easier to match rules like RULES "foo" f (h x, g y) = f' x y In the simplifier, it's Simplify.mkAtomicArgs that ANF-ises a constructor application where necessary. In the occurrence analyser, there's a new piece of context info (OccEncl) to say whether a constructor app is in a place where it should be in ANF. (Unless it knows this it'll give occurrence info which will inline the argument back into the constructor app.) 3. I'm experimenting with doing the "float-past big lambda" transformation in the full laziness pass, rather than mixed in with the simplifier (was tryRhsTyLam). 4. Arrange that case (coerce (S,T) (x,y)) of ... will simplify. Previous it didn't. A local change to CoreUtils.exprIsConApp_maybe. 5. Do a better job in CoreUtils.exprEtaExpandArity when there's an error function in one branch. Phase numbers, RULES, and INLINE pragmas ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1. Phase numbers decrease from N towards zero (instead of increasing). This makes it easier to add new earlier phases, which is what users want to do. 2. RULES get their own phase number, N, and are disabled in phases before N. e.g. {-# RULES "foo" [2] forall x y. f (x,y) = f' x y #-} Note the [2], which says "only active in phase 2 and later". 3. INLINE and NOINLINE pragmas have a phase number to. This is now treated in just the same way as the phase number on RULE; that is, the Id is not inlined in phases earlier than N. In phase N and later the Id *may* be inlined, and here is where INLINE and NOINLINE differ: INLNE makes the RHS look small, so as soon as it *may* be inlined it probably *will* be inlined. The syntax of the phase number on an INLINE/NOINLINE pragma has changed to be like the RULES case (i.e. in square brackets). This should also make sure you examine all such phase numbers; many will need to change now the numbering is reversed. Inlining Ids is no longer affected at all by whether the Id appears on the LHS of a rule. Now it's up to the programmer to put a suitable INLINE/NOINLINE pragma to stop it being inlined too early. Implementation notes: * A new data type, BasicTypes.Activation says when a rule or inline pragma is active. Functions isAlwaysActive, isNeverActive, isActive, do the obvious thing (all in BasicTypes). * Slight change in the SimplifierSwitch data type, which led to a lot of simplifier-specific code moving from CmdLineOpts to SimplMonad; a Good Thing. * The InlinePragma in the IdInfo of an Id is now simply an Activation saying when the Id can be inlined. (It used to be a rather bizarre pair of a Bool and a (Maybe Phase), so this is much much easier to understand.) * The simplifier has a "mode" environment switch, replacing the old black list. Unfortunately the data type decl has to be in CmdLineOpts, because it's an argument to the CoreDoSimplify switch data SimplifierMode = SimplGently | SimplPhase Int Here "gently" means "no rules, no inlining". All the crucial inlining decisions are now collected together in SimplMonad (preInlineUnconditionally, postInlineUnconditionally, activeInline, activeRule). Specialisation ~~~~~~~~~~~~~~ 1. Only dictionary *functions* are made INLINE, not dictionaries that have no parameters. (This inline-dictionary-function thing is Marcin's idea and I'm still not sure whether it's a good idea. But it's definitely a Bad Idea when there are no arguments.) 2. Be prepared to specialise an INLINE function: an easy fix in Specialise.lhs But there is still a problem, which is that the INLINE wins at the call site, so we don't use the specialised version anyway. I'm still unsure whether it makes sense to SPECIALISE something you want to INLINE. Random smaller things ~~~~~~~~~~~~~~~~~~~~~~ * builtinRules (there was only one, but may be more) in PrelRules are now incorporated. They were being ignored before... * OrdList.foldOL --> OrdList.foldrOL, OrdList.foldlOL * Some tidying up of the tidyOpenTyVar, tidyTyVar functions. I've forgotten exactly what! --- ghc/compiler/basicTypes/BasicTypes.lhs | 47 +++++- ghc/compiler/basicTypes/Id.lhs | 1 + ghc/compiler/basicTypes/IdInfo.lhs | 45 ++---- ghc/compiler/basicTypes/MkId.lhs | 3 - ghc/compiler/basicTypes/VarSet.lhs | 4 +- ghc/compiler/coreSyn/CoreFVs.lhs | 8 +- ghc/compiler/coreSyn/CorePrep.lhs | 35 +++-- ghc/compiler/coreSyn/CoreSyn.lhs | 21 +-- ghc/compiler/coreSyn/CoreTidy.lhs | 87 +++++++---- ghc/compiler/coreSyn/CoreUnfold.lhs | 156 +++++-------------- ghc/compiler/coreSyn/CoreUtils.lhs | 263 +++++++++++++++++++++----------- ghc/compiler/coreSyn/PprCore.lhs | 8 +- ghc/compiler/coreSyn/Subst.lhs | 4 +- ghc/compiler/deSugar/Desugar.lhs | 4 +- ghc/compiler/deSugar/DsForeign.lhs | 7 +- ghc/compiler/hsSyn/HsBinds.lhs | 52 +++---- ghc/compiler/hsSyn/HsCore.lhs | 4 +- ghc/compiler/hsSyn/HsDecls.lhs | 32 ++-- ghc/compiler/main/CmdLineOpts.lhs | 147 ++---------------- ghc/compiler/main/DriverState.hs | 56 +++---- ghc/compiler/main/HscMain.lhs | 19 ++- ghc/compiler/main/HscStats.lhs | 3 +- ghc/compiler/main/MkIface.lhs | 10 +- ghc/compiler/parser/Lex.lhs | 5 +- ghc/compiler/parser/Parser.y | 28 ++-- ghc/compiler/prelude/PrelRules.lhs | 3 - ghc/compiler/rename/ParseIface.y | 25 ++- ghc/compiler/rename/RnBinds.lhs | 9 +- ghc/compiler/rename/RnEnv.lhs | 1 - ghc/compiler/rename/RnExpr.lhs | 1 - ghc/compiler/rename/RnHiFiles.lhs | 5 +- ghc/compiler/rename/RnHsSyn.lhs | 5 +- ghc/compiler/rename/RnSource.lhs | 12 +- ghc/compiler/specialise/Rules.lhs | 68 +++++---- ghc/compiler/specialise/SpecConstr.lhs | 6 +- ghc/compiler/specialise/Specialise.lhs | 35 ++++- ghc/compiler/stranal/StrictAnal.lhs | 4 +- ghc/compiler/stranal/WorkWrap.lhs | 10 +- ghc/compiler/typecheck/TcBinds.lhs | 22 ++- ghc/compiler/typecheck/TcClassDcl.lhs | 6 +- ghc/compiler/typecheck/TcEnv.lhs | 1 - ghc/compiler/typecheck/TcGenDeriv.lhs | 31 ---- ghc/compiler/typecheck/TcHsSyn.lhs | 4 +- ghc/compiler/typecheck/TcInstDcls.lhs | 11 +- ghc/compiler/typecheck/TcMType.lhs | 12 +- ghc/compiler/typecheck/TcMonoType.lhs | 12 +- ghc/compiler/typecheck/TcRules.lhs | 16 +- ghc/compiler/typecheck/TcType.lhs | 7 +- ghc/compiler/types/Type.lhs | 59 ++++--- ghc/compiler/utils/OrdList.lhs | 18 ++- ghc/compiler/utils/Outputable.lhs | 5 +- ghc/compiler/utils/UniqSet.lhs | 5 +- ghc/lib/std/PrelBase.lhs | 19 ++- ghc/lib/std/PrelEnum.lhs | 17 ++- ghc/lib/std/PrelList.lhs | 13 +- ghc/lib/std/PrelST.lhs | 6 +- 56 files changed, 727 insertions(+), 770 deletions(-) diff --git a/ghc/compiler/basicTypes/BasicTypes.lhs b/ghc/compiler/basicTypes/BasicTypes.lhs index 0f7a462..a4e6260 100644 --- a/ghc/compiler/basicTypes/BasicTypes.lhs +++ b/ghc/compiler/basicTypes/BasicTypes.lhs @@ -38,7 +38,10 @@ module BasicTypes( EP(..), - StrictnessMark(..), isMarkedUnboxed, isMarkedStrict + StrictnessMark(..), isMarkedUnboxed, isMarkedStrict, + + CompilerPhase, pprPhase, + Activation(..), isActive, isNeverActive, isAlwaysActive ) where #include "HsVersions.h" @@ -289,7 +292,7 @@ isDeadOcc other = False isFragileOcc :: OccInfo -> Bool isFragileOcc (OneOcc _ _) = True -isFragileOcc other = False +isFragileOcc other = False \end{code} \begin{code} @@ -335,3 +338,43 @@ instance Outputable StrictnessMark where ppr MarkedUnboxed = ptext SLIT("! !") ppr NotMarkedStrict = empty \end{code} + + +%************************************************************************ +%* * +\subsection{Activation} +%* * +%************************************************************************ + +When a rule or inlining is active + +\begin{code} +type CompilerPhase = Int -- Compilation phase + -- Phases decrease towards zero + -- Zero is the last phase + +pprPhase :: CompilerPhase -> SDoc +pprPhase n = brackets (int n) + +data Activation = NeverActive + | AlwaysActive + | ActiveAfter CompilerPhase -- Active in this phase and later + deriving( Eq ) -- Eq used in comparing rules in HsDecls + +instance Outputable Activation where + ppr AlwaysActive = empty -- The default + ppr (ActiveAfter n) = pprPhase n + ppr NeverActive = ptext SLIT("NEVER") + +isActive :: CompilerPhase -> Activation -> Bool +isActive p NeverActive = False +isActive p AlwaysActive = True +isActive p (ActiveAfter n) = p <= n + +isNeverActive, isAlwaysActive :: Activation -> Bool +isNeverActive NeverActive = True +isNeverActive act = False + +isAlwaysActive AlwaysActive = True +isAlwaysActive other = False +\end{code} \ No newline at end of file diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 01b7ab1..c45304f 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -533,3 +533,4 @@ zapLamIdInfo id = maybeModifyIdInfo zapLamInfo id zapDemandIdInfo id = maybeModifyIdInfo zapDemandInfo id \end{code} + diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 061273a..045d765 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -50,8 +50,7 @@ module IdInfo ( -- Inline prags InlinePragInfo(..), - inlinePragInfo, setInlinePragInfo, pprInlinePragInfo, - isNeverInlinePrag, neverInlinePrag, + inlinePragInfo, setInlinePragInfo, -- Occurrence info OccInfo(..), isFragileOcc, isDeadOcc, isLoopBreaker, @@ -89,7 +88,8 @@ import Var ( Id ) import BasicTypes ( OccInfo(..), isFragileOcc, isDeadOcc, seqOccInfo, isLoopBreaker, InsideLam, insideLam, notInsideLam, OneBranch, oneBranch, notOneBranch, - Arity + Arity, + Activation(..) ) import DataCon ( DataCon ) import ForeignCall ( ForeignCall ) @@ -331,7 +331,7 @@ vanillaIdInfo unfoldingInfo = noUnfolding, cprInfo = NoCPRInfo, lbvarInfo = NoLBVarInfo, - inlinePragInfo = NoInlinePragInfo, + inlinePragInfo = AlwaysActive, occInfo = NoOccInfo, newDemandInfo = topDmd, newStrictnessInfo = Nothing @@ -390,36 +390,13 @@ ppArityInfo (Just arity) = hsep [ptext SLIT("Arity"), int arity] %************************************************************************ \begin{code} -data InlinePragInfo - = NoInlinePragInfo - | IMustNotBeINLINEd Bool -- True <=> came from an INLINE prag, False <=> came from a NOINLINE prag - (Maybe Int) -- Phase number from pragma, if any - deriving( Eq ) - -- The True, Nothing case doesn't need to be recorded - - -- SEE COMMENTS WITH CoreUnfold.blackListed on the - -- exact significance of the IMustNotBeINLINEd pragma - -isNeverInlinePrag :: InlinePragInfo -> Bool -isNeverInlinePrag (IMustNotBeINLINEd _ Nothing) = True -isNeverInlinePrag other = False - -neverInlinePrag :: InlinePragInfo -neverInlinePrag = IMustNotBeINLINEd True{-should be False? --SDM -} Nothing - -instance Outputable InlinePragInfo where - -- This is now parsed in interface files - ppr NoInlinePragInfo = empty - ppr other_prag = ptext SLIT("__U") <> pprInlinePragInfo other_prag - -pprInlinePragInfo NoInlinePragInfo = empty -pprInlinePragInfo (IMustNotBeINLINEd True Nothing) = empty -pprInlinePragInfo (IMustNotBeINLINEd True (Just n)) = brackets (int n) -pprInlinePragInfo (IMustNotBeINLINEd False Nothing) = brackets (char '!') -pprInlinePragInfo (IMustNotBeINLINEd False (Just n)) = brackets (char '!' <> int n) - -instance Show InlinePragInfo where - showsPrec p prag = showsPrecSDoc p (ppr prag) +type InlinePragInfo = Activation + -- Tells when the inlining is active + -- When it is active the thing may be inlined, depending on how + -- big it is. + -- + -- If there was an INLINE pragma, then as a separate matter, the + -- RHS will have been made to look small with a CoreSyn Inline Note \end{code} diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index a44e083..c3d3400 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -435,7 +435,6 @@ mkRecordSelId tycon field_label unpack_id unpackUtf8_id `setArityInfo` arity `setUnfoldingInfo` mkTopUnfolding rhs_w_str `setNewStrictnessInfo` Just strict_sig - -- Unfolding and strictness added by dmdAnalTopId -- Allocate Ids. We do it a funny way round because field_dict_tys is -- almost always empty. Also note that we use length_tycon_theta @@ -902,8 +901,6 @@ pcMiscPrelId key mod str ty info pc_bottoming_Id key mod name ty = pcMiscPrelId key mod name ty bottoming_info where - - arity = 1 strict_sig = mkStrictSig (mkTopDmdType [evalDmd] BotRes) bottoming_info = noCafNoTyGenIdInfo `setNewStrictnessInfo` Just strict_sig -- these "bottom" out, no matter what their arguments diff --git a/ghc/compiler/basicTypes/VarSet.lhs b/ghc/compiler/basicTypes/VarSet.lhs index a3c55f4..8cad15e 100644 --- a/ghc/compiler/basicTypes/VarSet.lhs +++ b/ghc/compiler/basicTypes/VarSet.lhs @@ -11,7 +11,7 @@ module VarSet ( elemVarSet, varSetElems, subVarSet, unionVarSet, unionVarSets, intersectVarSet, intersectsVarSet, - isEmptyVarSet, delVarSet, delVarSetByKey, + isEmptyVarSet, delVarSet, delVarSetList, delVarSetByKey, minusVarSet, foldVarSet, filterVarSet, lookupVarSet, mapVarSet, sizeVarSet, seqVarSet ) where @@ -44,6 +44,7 @@ unitVarSet :: Var -> VarSet extendVarSet :: VarSet -> Var -> VarSet elemVarSet :: Var -> VarSet -> Bool delVarSet :: VarSet -> Var -> VarSet +delVarSetList :: VarSet -> [Var] -> VarSet minusVarSet :: VarSet -> VarSet -> VarSet isEmptyVarSet :: VarSet -> Bool mkVarSet :: [Var] -> VarSet @@ -74,6 +75,7 @@ varSetElems = uniqSetToList elemVarSet = elementOfUniqSet minusVarSet = minusUniqSet delVarSet = delOneFromUniqSet +delVarSetList = delListFromUniqSet isEmptyVarSet = isEmptyUniqSet mkVarSet = mkUniqSet foldVarSet = foldUniqSet diff --git a/ghc/compiler/coreSyn/CoreFVs.lhs b/ghc/compiler/coreSyn/CoreFVs.lhs index 2a1a122..0bce99b 100644 --- a/ghc/compiler/coreSyn/CoreFVs.lhs +++ b/ghc/compiler/coreSyn/CoreFVs.lhs @@ -161,7 +161,7 @@ make the whole module an orphan module, which is bad. \begin{code} ruleLhsFreeNames :: IdCoreRule -> NameSet ruleLhsFreeNames (fn, BuiltinRule _ _) = unitNameSet (varName fn) -ruleLhsFreeNames (fn, Rule _ tpl_vars tpl_args rhs) +ruleLhsFreeNames (fn, Rule _ _ tpl_vars tpl_args rhs) = addOneToNameSet (exprsFreeNames tpl_args `del_binders` tpl_vars) (varName fn) exprFreeNames :: CoreExpr -> NameSet @@ -202,14 +202,14 @@ del_binders names bndrs = foldl (\s b -> delFromNameSet s (varName b)) names bnd \begin{code} ruleRhsFreeVars :: CoreRule -> VarSet ruleRhsFreeVars (BuiltinRule _ _) = noFVs -ruleRhsFreeVars (Rule str tpl_vars tpl_args rhs) +ruleRhsFreeVars (Rule str _ tpl_vars tpl_args rhs) = rule_fvs isLocalVar emptyVarSet where rule_fvs = addBndrs tpl_vars (expr_fvs rhs) ruleSomeFreeVars :: InterestingVarFun -> CoreRule -> VarSet ruleSomeFreeVars interesting (BuiltinRule _ _) = noFVs -ruleSomeFreeVars interesting (Rule _ tpl_vars tpl_args rhs) +ruleSomeFreeVars interesting (Rule _ _ tpl_vars tpl_args rhs) = rule_fvs interesting emptyVarSet where rule_fvs = addBndrs tpl_vars $ @@ -219,7 +219,7 @@ ruleLhsFreeIds :: CoreRule -> VarSet -- This finds all the free Ids on the LHS of the rule -- *including* imported ids ruleLhsFreeIds (BuiltinRule _ _) = noFVs -ruleLhsFreeIds (Rule _ tpl_vars tpl_args rhs) +ruleLhsFreeIds (Rule _ _ tpl_vars tpl_args rhs) = foldl delVarSet (exprsSomeFreeVars isId tpl_args) tpl_vars \end{code} diff --git a/ghc/compiler/coreSyn/CorePrep.lhs b/ghc/compiler/coreSyn/CorePrep.lhs index 7d6cc24..e6cac72 100644 --- a/ghc/compiler/coreSyn/CorePrep.lhs +++ b/ghc/compiler/coreSyn/CorePrep.lhs @@ -10,7 +10,7 @@ module CorePrep ( #include "HsVersions.h" -import CoreUtils( exprIsAtom, exprType, exprIsValue, etaExpand ) +import CoreUtils( exprIsAtom, exprType, exprIsValue, etaExpand, exprOkForSpeculation ) import CoreFVs ( exprFreeVars ) import CoreLint ( endPass ) import CoreSyn @@ -103,15 +103,22 @@ corePrepExpr dflags expr -- --------------------------------------------------------------------------- data FloatingBind = FloatLet CoreBind - | FloatCase Id CoreExpr + | FloatCase Id CoreExpr Bool + -- The bool indicates "ok-for-speculation" type CloneEnv = IdEnv Id -- Clone local Ids allLazy :: OrdList FloatingBind -> Bool -allLazy floats = foldOL check True floats +allLazy floats = foldrOL check True floats where - check (FloatLet _) y = y - check (FloatCase _ _) y = False + check (FloatLet _) y = y + check (FloatCase _ _ ok_for_spec) y = ok_for_spec && y + -- The ok-for-speculation flag says that it's safe to + -- float this Case out of a let, and thereby do it more eagerly + +-- --------------------------------------------------------------------------- +-- Bindings +-- --------------------------------------------------------------------------- corePrepTopBinds :: CloneEnv -> [CoreBind] -> UniqSM [CoreBind] corePrepTopBinds env [] = returnUs [] @@ -120,15 +127,11 @@ corePrepTopBinds env (bind : binds) = corePrepBind env bind `thenUs` \ (env', floats) -> ASSERT( allLazy floats ) corePrepTopBinds env' binds `thenUs` \ binds' -> - returnUs (foldOL add binds' floats) + returnUs (foldrOL add binds' floats) where add (FloatLet bind) binds = bind : binds --- --------------------------------------------------------------------------- --- Bindings --- --------------------------------------------------------------------------- - corePrepBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind) -- Used for non-top-level bindings -- We return a *list* of bindings, because we may start with @@ -345,7 +348,7 @@ maybeSaturate fn expr n_args ty fn_arity = idArity fn excess_arity = fn_arity - n_args saturate_it = getUs `thenUs` \ us -> - returnUs (etaExpand excess_arity us expr ty) + returnUs (etaExpand excess_arity (uniqsFromSupply us) expr ty) -- --------------------------------------------------------------------------- -- Precipitating the floating bindings @@ -384,7 +387,7 @@ mkNonRec bndr dem floats rhs -- It's a strict let, or the binder is unlifted, -- so we definitely float all the bindings = ASSERT( not (isUnboxedTupleType bndr_rep_ty) ) - returnUs (floats `snocOL` FloatCase bndr rhs) + returnUs (floats `snocOL` FloatCase bndr rhs (exprOkForSpeculation rhs)) | otherwise -- Don't float @@ -398,10 +401,10 @@ mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr mkBinds binds body | isNilOL binds = returnUs body | otherwise = deLam body `thenUs` \ body' -> - returnUs (foldOL mk_bind body' binds) + returnUs (foldrOL mk_bind body' binds) where - mk_bind (FloatCase bndr rhs) body = mkCase rhs bndr [(DEFAULT, [], body)] - mk_bind (FloatLet bind) body = Let bind body + mk_bind (FloatCase bndr rhs _) body = mkCase rhs bndr [(DEFAULT, [], body)] + mk_bind (FloatLet bind) body = Let bind body -- --------------------------------------------------------------------------- -- Eliminate Lam as a non-rhs (STG doesn't have such a thing) @@ -569,7 +572,7 @@ cloneBndrs env bs = mapAccumLUs cloneBndr env bs cloneBndr :: CloneEnv -> Var -> UniqSM (CloneEnv, Var) cloneBndr env bndr | isId bndr && isLocalId bndr -- Top level things, which we don't want - -- to clone, have become ConstantIds by now + -- to clone, have become GlobalIds by now = getUniqueUs `thenUs` \ uniq -> let bndr' = setVarUnique bndr uniq diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index 83ef923..a352829 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -18,7 +18,7 @@ module CoreSyn ( isTyVar, isId, bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders, - collectArgs, collectBindersIgnoringNotes, + collectArgs, coreExprCc, flattenBinds, @@ -55,6 +55,7 @@ import Var ( Var, Id, TyVar, isTyVar, isId ) import Type ( Type, mkTyVarTy, seqType ) import Literal ( Literal, mkMachInt ) import DataCon ( DataCon, dataConId ) +import BasicTypes ( Activation ) import VarSet import Outputable \end{code} @@ -169,6 +170,7 @@ type IdCoreRule = (Id,CoreRule) -- Rules don't have their leading Id inside the data CoreRule = Rule RuleName + Activation -- When the rule is active [CoreBndr] -- Forall'd variables [CoreExpr] -- LHS args CoreExpr -- RHS @@ -181,7 +183,7 @@ isBuiltinRule (BuiltinRule _ _) = True isBuiltinRule _ = False ruleName :: CoreRule -> RuleName -ruleName (Rule n _ _ _) = n +ruleName (Rule n _ _ _ _) = n ruleName (BuiltinRule n _) = n \end{code} @@ -423,7 +425,6 @@ order. \begin{code} collectBinders :: Expr b -> ([b], Expr b) -collectBindersIgnoringNotes :: Expr b -> ([b], Expr b) collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr) collectValBinders :: CoreExpr -> ([Id], CoreExpr) collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr) @@ -434,16 +435,6 @@ collectBinders expr go bs (Lam b e) = go (b:bs) e go bs e = (reverse bs, e) --- This one ignores notes. It's used in CoreUnfold and StrAnal --- when we aren't going to put the expression back together from --- the pieces, so we don't mind losing the Notes -collectBindersIgnoringNotes expr - = go [] expr - where - go bs (Lam b e) = go (b:bs) e - go bs (Note _ e) = go bs e - go bs e = (reverse bs, e) - collectTyAndValBinders expr = (tvs, ids, body) where @@ -571,8 +562,8 @@ seqRules :: CoreRules -> () seqRules (Rules rules fvs) = seq_rules rules `seq` seqVarSet fvs seq_rules [] = () -seq_rules (Rule fs bs es e : rules) = seqBndrs bs `seq` seqExprs (e:es) `seq` seq_rules rules -seq_rules (BuiltinRule _ _ : rules) = seq_rules rules +seq_rules (Rule fs _ bs es e : rules) = seqBndrs bs `seq` seqExprs (e:es) `seq` seq_rules rules +seq_rules (BuiltinRule _ _ : rules) = seq_rules rules \end{code} diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs index 55b0085..f400051 100644 --- a/ghc/compiler/coreSyn/CoreTidy.lhs +++ b/ghc/compiler/coreSyn/CoreTidy.lhs @@ -15,24 +15,27 @@ import CmdLineOpts ( DynFlags, DynFlag(..), opt_OmitInterfacePragmas ) import CoreSyn import CoreUnfold ( noUnfolding, mkTopUnfolding, okToUnfoldInHiFile ) import CoreFVs ( ruleSomeFreeVars, exprSomeFreeVars ) +import PprCore ( pprIdCoreRule ) import CoreLint ( showPass, endPass ) import VarEnv import VarSet import Var ( Id, Var ) import Id ( idType, idInfo, idName, isExportedId, idSpecialisation, idUnique, isDataConWrapId, - mkVanillaGlobal, isLocalId, isRecordSelector, - setIdUnfolding, hasNoBinding, mkUserLocal, - idNewDemandInfo, setIdNewDemandInfo + mkVanillaGlobal, mkGlobalId, isLocalId, + hasNoBinding, mkUserLocal, isGlobalId, globalIdDetails, + idNewDemandInfo, setIdNewDemandInfo, + idNewStrictness_maybe, setIdNewStrictness ) import IdInfo {- loads of stuff -} import NewDemand ( isBottomingSig, topSig, isStrictDmd ) +import BasicTypes ( isNeverActive ) import Name ( getOccName, nameOccName, globaliseName, setNameOcc, localiseName, isGlobalName, setNameUnique ) import NameEnv ( filterNameEnv ) import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName ) -import Type ( tidyTopType, tidyType, tidyTyVar ) +import Type ( tidyTopType, tidyType, tidyTyVarBndr ) import Module ( Module, moduleName ) import HscTypes ( PersistentCompilerState( pcs_PRS ), PersistentRenamerState( prsOrig ), @@ -42,12 +45,13 @@ import HscTypes ( PersistentCompilerState( pcs_PRS ), ) import FiniteMap ( lookupFM, addToFM ) import Maybes ( maybeToBool, orElse ) -import ErrUtils ( showPass ) +import ErrUtils ( showPass, dumpIfSet_core ) import SrcLoc ( noSrcLoc ) import UniqFM ( mapUFM ) import UniqSupply ( splitUniqSupply, uniqFromSupply ) import List ( partition ) import Util ( mapAccumL ) +import Maybe ( isNothing, fromJust ) import Outputable \end{code} @@ -178,6 +182,9 @@ tidyCorePgm dflags mod pcs cg_info_env md_binds = tidy_binds } ; endPass dflags "Tidy Core" Opt_D_dump_simpl tidy_binds + ; dumpIfSet_core dflags Opt_D_dump_simpl + "Tidy Core Rules" + (vcat (map pprIdCoreRule tidy_rules)) ; return (pcs', tidy_details) } @@ -307,7 +314,7 @@ addExternal (id,rhs) needed spec_ids idinfo = idInfo id - dont_inline = isNeverInlinePrag (inlinePragInfo idinfo) + dont_inline = isNeverActive (inlinePragInfo idinfo) loop_breaker = isLoopBreaker (occInfo idinfo) bottoming_fn = isBottomingSig (newStrictnessInfo idinfo `orElse` topSig) spec_ids = rulesRhsFreeVars (specInfo idinfo) @@ -429,11 +436,6 @@ tidyTopBinder mod ext_ids cg_info_env tidy_env rhs -- all, but in any case it will have the error message inline so it won't matter. - | isRecordSelector id -- We can't use the "otherwise" case, because that - -- forgets the IdDetails, which forgets that this is - -- a record selector, which confuses an importing module - = (env, id `setIdUnfolding` unfold_info) - | otherwise -- This function is the heart of Step 2 -- The second env is the one to use for the IdInfo @@ -452,7 +454,11 @@ tidyTopBinder mod ext_ids cg_info_env tidy_env rhs cg_info = lookupCgInfo cg_info_env name' idinfo' = tidyIdInfo tidy_env is_external unfold_info cg_info id - id' = mkVanillaGlobal name' ty' idinfo' + id' | isGlobalId id = mkGlobalId (globalIdDetails id) name' ty' idinfo' + | otherwise = mkVanillaGlobal name' ty' idinfo' + -- The test ensures that record selectors (which must be tidied; see above) + -- retain their details. If it's forgotten, importing modules get confused. + subst_env' = extendVarEnv subst_env2 id id' maybe_external = lookupVarEnv ext_ids id @@ -542,10 +548,10 @@ tidyIdRules env ((fn,rule) : rules) tidyRule :: TidyEnv -> CoreRule -> CoreRule tidyRule env rule@(BuiltinRule _ _) = rule -tidyRule env (Rule name vars tpl_args rhs) +tidyRule env (Rule name act vars tpl_args rhs) = tidyBndrs env vars =: \ (env', vars) -> map (tidyExpr env') tpl_args =: \ tpl_args -> - (Rule name vars tpl_args (tidyExpr env' rhs)) + (Rule name act vars tpl_args (tidyExpr env' rhs)) \end{code} %************************************************************************ @@ -560,11 +566,11 @@ tidyBind :: TidyEnv -> (TidyEnv, CoreBind) tidyBind env (NonRec bndr rhs) - = tidyBndrWithRhs env (bndr,rhs) =: \ (env', bndr') -> + = tidyLetBndr env (bndr,rhs) =: \ (env', bndr') -> (env', NonRec bndr' (tidyExpr env' rhs)) tidyBind env (Rec prs) - = mapAccumL tidyBndrWithRhs env prs =: \ (env', bndrs') -> + = mapAccumL tidyLetBndr env prs =: \ (env', bndrs') -> map (tidyExpr env') (map snd prs) =: \ rhss' -> (env', Rec (zip bndrs' rhss')) @@ -611,26 +617,43 @@ tidyVarOcc (_, var_env) v = case lookupVarEnv var_env v of -- tidyBndr is used for lambda and case binders tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var) tidyBndr env var - | isTyVar var = tidyTyVar env var - | otherwise = tidyId env var + | isTyVar var = tidyTyVarBndr env var + | otherwise = tidyIdBndr env var tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var]) tidyBndrs env vars = mapAccumL tidyBndr env vars --- tidyBndrWithRhs is used for let binders -tidyBndrWithRhs :: TidyEnv -> (Id, CoreExpr) -> (TidyEnv, Var) -tidyBndrWithRhs env (id,rhs) - = add_dmd_info (tidyId env id) +tidyLetBndr :: TidyEnv -> (Id, CoreExpr) -> (TidyEnv, Var) +-- Used for local (non-top-level) let(rec)s +tidyLetBndr env (id,rhs) + = ((tidy_env,new_var_env), final_id) where - -- We add demand info for let(rec) binders, because - -- that's what tells CorePrep to generate a case instead of a thunk - add_dmd_info (env,new_id) - | isStrictDmd dmd_info = (env, setIdNewDemandInfo new_id dmd_info) - | otherwise = (env, new_id) - dmd_info = idNewDemandInfo id - -tidyId :: TidyEnv -> Id -> (TidyEnv, Id) -tidyId env@(tidy_env, var_env) id + ((tidy_env,var_env), new_id) = tidyIdBndr env id + + -- We need to keep around any interesting strictness and demand info + -- because later on we may need to use it when converting to A-normal form. + -- eg. + -- f (g x), where f is strict in its argument, will be converted + -- into case (g x) of z -> f z by CorePrep, but only if f still + -- has its strictness info. + -- + -- Similarly for the demand info - on a let binder, this tells + -- CorePrep to turn the let into a case. + final_id + | totally_boring_info = new_id + | otherwise = new_id `setIdNewDemandInfo` dmd_info + `setIdNewStrictness` fromJust maybe_new_strictness + + -- override the env we get back from tidyId with the new IdInfo + -- so it gets propagated to the usage sites. + new_var_env = extendVarEnv var_env id final_id + + dmd_info = idNewDemandInfo id + maybe_new_strictness = idNewStrictness_maybe id + totally_boring_info = isNothing maybe_new_strictness && not (isStrictDmd dmd_info) + +tidyIdBndr :: TidyEnv -> Id -> (TidyEnv, Id) +tidyIdBndr env@(tidy_env, var_env) id = -- Non-top-level variables let -- Give the Id a fresh print-name, *and* rename its type @@ -640,7 +663,7 @@ tidyId env@(tidy_env, var_env) id -- All local Ids now have the same IdInfo, which should save some -- space. (tidy_env', occ') = tidyOccName tidy_env (getOccName id) - ty' = tidyType (tidy_env,var_env) (idType id) + ty' = tidyType env (idType id) id' = mkUserLocal occ' (idUnique id) ty' noSrcLoc var_env' = extendVarEnv var_env id id' in diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index e96e741..fe7b8f2 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -26,7 +26,7 @@ module CoreUnfold ( certainlyWillInline, okToUnfoldInHiFile, - callSiteInline, blackListed + callSiteInline ) where #include "HsVersions.h" @@ -43,16 +43,14 @@ import PprCore ( pprCoreExpr ) import OccurAnal ( occurAnalyseGlobalExpr ) import CoreUtils ( exprIsValue, exprIsCheap, exprIsTrivial ) import Id ( Id, idType, isId, - idSpecialisation, idInlinePragma, idUnfolding, + idUnfolding, isFCallId_maybe, globalIdDetails ) -import VarSet +import DataCon ( isUnboxedTupleCon ) import Literal ( isLitLitLit, litSize ) import PrimOp ( primOpIsDupable, primOpOutOfLine ) import ForeignCall ( okToExposeFCall ) -import IdInfo ( InlinePragInfo(..), OccInfo(..), GlobalIdDetails(..), - isNeverInlinePrag - ) +import IdInfo ( OccInfo(..), GlobalIdDetails(..) ) import Type ( isUnLiftedType ) import PrelNames ( hasKey, buildIdKey, augmentIdKey ) import Bag @@ -77,6 +75,7 @@ mkTopUnfolding expr = mkUnfolding True {- Top level -} expr mkUnfolding top_lvl expr = CoreUnfolding (occurAnalyseGlobalExpr expr) top_lvl + (exprIsValue expr) -- Already evaluated @@ -298,7 +297,7 @@ sizeExpr bOMB_OUT_SIZE top_args expr | fun `hasKey` augmentIdKey = augmentSize | otherwise = case globalIdDetails fun of - DataConId dc -> conSizeN (valArgCount args) + DataConId dc -> conSizeN dc (valArgCount args) FCallId fc -> sizeN opt_UF_DearOp PrimOpId op -> primOpSize op (valArgCount args) @@ -370,24 +369,35 @@ maxSize _ TooBig = TooBig maxSize s1@(SizeIs n1 _ _) s2@(SizeIs n2 _ _) | n1 ># n2 = s1 | otherwise = s2 -sizeZero = SizeIs (_ILIT 0) emptyBag (_ILIT 0) -sizeOne = SizeIs (_ILIT 1) emptyBag (_ILIT 0) +sizeZero = SizeIs (_ILIT 0) emptyBag (_ILIT 0) +sizeOne = SizeIs (_ILIT 1) emptyBag (_ILIT 0) sizeN n = SizeIs (iUnbox n) emptyBag (_ILIT 0) -conSizeN n = SizeIs (_ILIT 1) emptyBag (iUnbox n +# _ILIT 1) +conSizeN dc n + | isUnboxedTupleCon dc = SizeIs (_ILIT 0) emptyBag (iUnbox n +# _ILIT 1) + | otherwise = SizeIs (_ILIT 1) emptyBag (iUnbox n +# _ILIT 1) -- Treat constructors as size 1; we are keen to expose them -- (and we charge separately for their args). We can't treat -- them as size zero, else we find that (iBox x) has size 1, -- which is the same as a lone variable; and hence 'v' will -- always be replaced by (iBox x), where v is bound to iBox x. + -- + -- However, unboxed tuples count as size zero + -- I found occasions where we had + -- f x y z = case op# x y z of { s -> (# s, () #) } + -- and f wasn't getting inlined primOpSize op n_args | not (primOpIsDupable op) = sizeN opt_UF_DearOp - | not (primOpOutOfLine op) = sizeN (1 - n_args) + | not (primOpOutOfLine op) = sizeN (2 - n_args) -- Be very keen to inline simple primops. - -- We give a discount of 1 for each arg so that (op# x y z) costs 1. - -- I found occasions where we had - -- f x y z = case op# x y z of { s -> (# s, () #) } - -- and f wasn't getting inlined + -- We give a discount of 1 for each arg so that (op# x y z) costs 2. + -- We can't make it cost 1, else we'll inline let v = (op# x y z) + -- at every use of v, which is excessive. + -- + -- A good example is: + -- let x = +# p q in C {x} + -- Even though x get's an occurrence of 'many', its RHS looks cheap, + -- and there's a good chance it'll get inlined back into C's RHS. Urgh! | otherwise = sizeOne buildSize = SizeIs (-2#) emptyBag 4# @@ -456,8 +466,8 @@ certainlyWillInline :: Id -> Bool certainlyWillInline v = case idUnfolding v of - CoreUnfolding _ _ is_value _ g@(UnfoldIfGoodArgs n_vals _ size _) - -> is_value + CoreUnfolding _ _ _ is_cheap g@(UnfoldIfGoodArgs n_vals _ size _) + -> is_cheap && size - (n_vals +1) <= opt_UF_UseThreshold other -> False @@ -517,7 +527,7 @@ StrictAnal.addStrictnessInfoToTopId \begin{code} callSiteInline :: DynFlags - -> Bool -- True <=> the Id is black listed + -> Bool -- True <=> the Id can be inlined -> Bool -- 'inline' note at call site -> OccInfo -> Id -- The Id @@ -526,7 +536,7 @@ callSiteInline :: DynFlags -> Maybe CoreExpr -- Unfolding, if any -callSiteInline dflags black_listed inline_call occ id arg_infos interesting_cont +callSiteInline dflags active_inline inline_call occ id arg_infos interesting_cont = case idUnfolding id of { NoUnfolding -> Nothing ; OtherCon cs -> Nothing ; @@ -536,7 +546,7 @@ callSiteInline dflags black_listed inline_call occ id arg_infos interesting_cont -- for these things, so we must inline it. -- Only a couple of primop-like things have -- compulsory unfoldings (see MkId.lhs). - -- We don't allow them to be black-listed + -- We don't allow them to be inactive CoreUnfolding unf_template is_top is_value is_cheap guidance -> @@ -547,8 +557,8 @@ callSiteInline dflags black_listed inline_call occ id arg_infos interesting_cont n_val_args = length arg_infos yes_or_no - | black_listed = False - | otherwise = case occ of + | not active_inline = False + | otherwise = case occ of IAmDead -> pprTrace "callSiteInline: dead" (ppr id) False IAmALoopBreaker -> False OneOcc in_lam one_br -> (not in_lam || is_cheap) && consider_safe in_lam True one_br @@ -579,8 +589,10 @@ callSiteInline dflags black_listed inline_call occ id arg_infos interesting_cont -- Note: there used to be a '&& not top_level' in the guard above, -- but that stopped us inlining top-level functions used only once, -- which is stupid - = WARN( not in_lam, ppr id ) -- If (not in_lam) && one_br then PreInlineUnconditionally - -- should have caught it, shouldn't it? + = WARN( not is_top && not in_lam, ppr id ) + -- If (not in_lam) && one_br then PreInlineUnconditionally + -- should have caught it, shouldn't it? Unless it's a top + -- level thing. not (null arg_infos) || interesting_cont | otherwise @@ -589,7 +601,7 @@ callSiteInline dflags black_listed inline_call occ id arg_infos interesting_cont UnfoldIfGoodArgs n_vals_wanted arg_discounts size res_discount | enough_args && size <= (n_vals_wanted + 1) - -- No size increase + -- Inline unconditionally if there no size increase -- Size of call is n_vals_wanted (+1 for the function) -> True @@ -626,7 +638,7 @@ callSiteInline dflags black_listed inline_call occ id arg_infos interesting_cont in if dopt Opt_D_dump_inlinings dflags then pprTrace "Considering inlining" - (ppr id <+> vcat [text "black listed:" <+> ppr black_listed, + (ppr id <+> vcat [text "active:" <+> ppr active_inline, text "occ info:" <+> ppr occ, text "arg infos" <+> ppr arg_infos, text "interesting continuation" <+> ppr interesting_cont, @@ -670,95 +682,3 @@ computeDiscount n_vals_wanted arg_discounts res_discount arg_infos result_used result_discount | result_used = res_discount -- Over-applied, or case scrut | otherwise = 0 \end{code} - - -%************************************************************************ -%* * -\subsection{Black-listing} -%* * -%************************************************************************ - -Inlining is controlled by the "Inline phase" number, which is set -by the per-simplification-pass '-finline-phase' flag. - -For optimisation we use phase 1,2 and nothing (i.e. no -finline-phase flag) -in that order. The meanings of these are determined by the @blackListed@ function -here. - -The final simplification doesn't have a phase number. - -Pragmas -~~~~~~~ - Pragma Black list if - -(least black listing, most inlining) - INLINE n foo phase is Just p *and* p Maybe Int -- Inline phase - -> Id -> Bool -- True <=> blacklisted - --- The blackListed function sees whether a variable should *not* be --- inlined because of the inline phase we are in. This is the sole --- place that the inline phase number is looked at. - -blackListed rule_vars Nothing -- Last phase - = \v -> isNeverInlinePrag (idInlinePragma v) - -blackListed rule_vars (Just phase) - = \v -> normal_case rule_vars phase v - -normal_case rule_vars phase v - = case idInlinePragma v of - NoInlinePragInfo -> has_rules - - IMustNotBeINLINEd from_INLINE Nothing - | from_INLINE -> has_rules -- Black list until final phase - | otherwise -> True -- Always blacklisted - - IMustNotBeINLINEd from_INLINE (Just threshold) - | from_INLINE -> (phase < threshold && has_rules) - | otherwise -> (phase < threshold || has_rules) - where - has_rules = v `elemVarSet` rule_vars - || not (isEmptyCoreRules (idSpecialisation v)) -\end{code} - - -SLPJ 95/04: Why @runST@ must be inlined very late: -\begin{verbatim} -f x = - runST ( \ s -> let - (a, s') = newArray# 100 [] s - (_, s'') = fill_in_array_or_something a x s' - in - freezeArray# a s'' ) -\end{verbatim} -If we inline @runST@, we'll get: -\begin{verbatim} -f x = let - (a, s') = newArray# 100 [] realWorld#{-NB-} - (_, s'') = fill_in_array_or_something a x s' - in - freezeArray# a s'' -\end{verbatim} -And now the @newArray#@ binding can be floated to become a CAF, which -is totally and utterly wrong: -\begin{verbatim} -f = let - (a, s') = newArray# 100 [] realWorld#{-NB-} -- YIKES!!! - in - \ x -> - let (_, s'') = fill_in_array_or_something a x s' in - freezeArray# a s'' -\end{verbatim} -All calls to @f@ will share a {\em single} array! - -Yet we do want to inline runST sometime, so we can avoid -needless code. Solution: black list it until the last moment. - diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 447768c..f873c74 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -7,8 +7,8 @@ module CoreUtils ( -- Construction mkNote, mkInlineMe, mkSCC, mkCoerce, - bindNonRec, mkIfThenElse, mkAltExpr, - mkPiType, + bindNonRec, needsCaseBinding, + mkIfThenElse, mkAltExpr, mkPiType, -- Taking expressions apart findDefault, findAlt, hasDefault, @@ -48,23 +48,26 @@ import VarSet import VarEnv import Name ( hashName ) import Literal ( hashLiteral, literalType, litIsDupable ) -import DataCon ( DataCon, dataConRepArity ) +import DataCon ( DataCon, dataConRepArity, dataConArgTys, isExistentialDataCon, dataConTyCon ) import PrimOp ( primOpOkForSpeculation, primOpIsCheap ) import Id ( Id, idType, globalIdDetails, idNewStrictness, idLBVarInfo, mkWildId, idArity, idName, idUnfolding, idInfo, isOneShotLambda, - isDataConId_maybe, mkSysLocal, hasNoBinding + isDataConId_maybe, mkSysLocal, hasNoBinding, isDataConId, isBottomingId ) import IdInfo ( LBVarInfo(..), GlobalIdDetails(..), megaSeqIdInfo ) import NewDemand ( appIsBottom ) -import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, +import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, splitFunTy, applyTys, isUnLiftedType, seqType, mkUTy, mkTyVarTy, - splitForAllTy_maybe, isForAllTy, splitNewType_maybe, eqType + splitForAllTy_maybe, isForAllTy, splitNewType_maybe, + splitTyConApp_maybe, eqType ) +import TyCon ( tyConArity ) import TysWiredIn ( boolTy, trueDataCon, falseDataCon ) import CostCentre ( CostCentre ) -import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply ) +import BasicTypes ( Arity ) +import Unique ( Unique ) import Outputable import TysPrim ( alphaTy ) -- Debugging only \end{code} @@ -224,8 +227,13 @@ bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr -- that give Core Lint a heart attack. Actually the simplifier -- deals with them perfectly well. bindNonRec bndr rhs body - | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)] - | otherwise = Let (NonRec bndr rhs) body + | needsCaseBinding (idType bndr) rhs = Case rhs bndr [(DEFAULT,[],body)] + | otherwise = Let (NonRec bndr rhs) body + +needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs) + -- Make a case expression instead of a let + -- These can arise either from the desugarer, + -- or from beta reductions: (\x.e) (x +# y) \end{code} \begin{code} @@ -512,7 +520,9 @@ idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args \end{code} @exprIsValue@ returns true for expressions that are certainly *already* -evaluated to WHNF. This is used to decide whether it's ok to change +evaluated to *head* normal form. This is used to decide whether it's ok +to change + case x of _ -> e ===> e and to decide whether it's safe to discard a `seq` @@ -520,12 +530,13 @@ and to decide whether it's safe to discard a `seq` So, it does *not* treat variables as evaluated, unless they say they are. But it *does* treat partial applications and constructor applications -as values, even if their arguments are non-trivial; +as values, even if their arguments are non-trivial, provided the argument +type is lifted; e.g. (:) (f x) (map f xs) is a value map (...redex...) is a value Because `seq` on such things completes immediately -A possible worry: constructors with unboxed args: +For unlifted argument types, we have to be careful: C (f x :: Int#) Suppose (f x) diverges; then C (f x) is not a value. True, but this form is illegal (see the invariants in CoreSyn). Args of unboxed @@ -538,37 +549,77 @@ exprIsValue (Type ty) = True -- Types are honorary Values; we don't mind exprIsValue (Lit l) = True exprIsValue (Lam b e) = isRuntimeVar b || exprIsValue e exprIsValue (Note _ e) = exprIsValue e -exprIsValue other_expr - = go other_expr 0 - where - go (Var f) n_args = idAppIsValue f n_args - - go (App f a) n_args - | not (isRuntimeArg a) = go f n_args - | otherwise = go f (n_args + 1) - - go (Note _ f) n_args = go f n_args - - go other n_args = False - -idAppIsValue :: Id -> Int -> Bool -idAppIsValue id n_val_args - = case globalIdDetails id of - DataConId _ -> True - PrimOpId _ -> n_val_args < idArity id - other | n_val_args == 0 -> isEvaldUnfolding (idUnfolding id) - | otherwise -> n_val_args < idArity id +exprIsValue (Var v) = idArity v > 0 || isEvaldUnfolding (idUnfolding v) + -- The idArity case catches data cons and primops that + -- don't have unfoldings -- A worry: what if an Id's unfolding is just itself: -- then we could get an infinite loop... +exprIsValue other_expr + | (Var fun, args) <- collectArgs other_expr, + isDataConId fun || valArgCount args < idArity fun + = check (idType fun) args + | otherwise + = False + where + -- 'check' checks that unlifted-type args are in + -- fact guaranteed non-divergent + check fun_ty [] = True + check fun_ty (Type _ : args) = case splitForAllTy_maybe fun_ty of + Just (_, ty) -> check ty args + check fun_ty (arg : args) + | isUnLiftedType arg_ty = exprOkForSpeculation arg + | otherwise = check res_ty args + where + (arg_ty, res_ty) = splitFunTy fun_ty \end{code} \begin{code} exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr]) -exprIsConApp_maybe (Note InlineMe expr) = exprIsConApp_maybe expr +exprIsConApp_maybe (Note (Coerce to_ty from_ty) expr) + = -- Maybe this is over the top, but here we try to turn + -- coerce (S,T) ( x, y ) + -- effectively into + -- ( coerce S x, coerce T y ) + -- This happens in anger in PrelArrExts which has a coerce + -- case coerce memcpy a b of + -- (# r, s #) -> ... + -- where the memcpy is in the IO monad, but the call is in + -- the (ST s) monad + case exprIsConApp_maybe expr of { + Nothing -> Nothing ; + Just (dc, args) -> + + case splitTyConApp_maybe to_ty of { + Nothing -> Nothing ; + Just (tc, tc_arg_tys) | tc /= dataConTyCon dc -> Nothing + | isExistentialDataCon dc -> Nothing + | otherwise -> + -- Type constructor must match + -- We knock out existentials to keep matters simple(r) + let + arity = tyConArity tc + val_args = drop arity args + to_arg_tys = dataConArgTys dc tc_arg_tys + mk_coerce ty arg = mkCoerce ty (exprType arg) arg + new_val_args = zipWith mk_coerce to_arg_tys val_args + in + ASSERT( all isTypeArg (take arity args) ) + ASSERT( length val_args == length to_arg_tys ) + Just (dc, map Type tc_arg_tys ++ new_val_args) + }} + +exprIsConApp_maybe (Note _ expr) + = exprIsConApp_maybe expr -- We ignore InlineMe notes in case we have -- x = __inline_me__ (a,b) -- All part of making sure that INLINE pragmas never hurt -- Marcin tripped on this one when making dictionaries more inlinable + -- + -- In fact, we ignore all notes. For example, + -- case _scc_ "foo" (C a b) of + -- C a b -> e + -- should be optimised away, but it will be only if we look + -- through the SCC note. exprIsConApp_maybe expr = analyse (collectArgs expr) where @@ -645,78 +696,118 @@ exprEtaExpandArity :: CoreExpr -> (Int, Bool) -- case x of p -> \s -> ... -- because for I/O ish things we really want to get that \s to the top. -- We are prepared to evaluate x each time round the loop in order to get that --- --- Consider let x = expensive in \y z -> E + +-- It's all a bit more subtle than it looks. Consider one-shot lambdas +-- let x = expensive in \y z -> E -- We want this to have arity 2 if the \y-abstraction is a 1-shot lambda --- --- Hence the list of Bools returned by go1 --- NB: this is particularly important/useful for IO state --- transformers, where we often get --- let x = E in \ s -> ... --- and the \s is a real-world state token abstraction. Such --- abstractions are almost invariably 1-shot, so we want to --- pull the \s out, past the let x=E. --- The hack is in Id.isOneShotLambda +-- Hence the ArityType returned by arityType + +-- NB: this is particularly important/useful for IO state +-- transformers, where we often get +-- let x = E in \ s -> ... +-- and the \s is a real-world state token abstraction. Such +-- abstractions are almost invariably 1-shot, so we want to +-- pull the \s out, past the let x=E. +-- The hack is in Id.isOneShotLambda +-- +-- Consider also +-- f = \x -> error "foo" +-- Here, arity 1 is fine. But if it is +-- f = \x -> case e of +-- True -> error "foo" +-- False -> \y -> x+y +-- then we want to get arity 2. +-- Hence the ABot/ATop in ArityType + exprEtaExpandArity e = go 0 e where go :: Int -> CoreExpr -> (Int,Bool) - go ar (Lam x e) | isId x = go (ar+1) e - | otherwise = go ar e - go ar (Note n e) | ok_note n = go ar e - go ar other = (ar + ar', ar' == 0) - where - ar' = length (go1 other) - - go1 :: CoreExpr -> [Bool] + go ar (Lam x e) | isId x = go (ar+1) e + | otherwise = go ar e + go ar (Note n e) | ok_note n = go ar e + go ar other = (ar + ar', ar' == 0) + where + ar' = arityDepth (arityType other) + +-- A limited sort of function type +data ArityType = AFun Bool ArityType -- True <=> one-shot + | ATop -- Know nothing + | ABot -- Diverges + +arityDepth :: ArityType -> Arity +arityDepth (AFun _ ty) = 1 + arityDepth ty +arityDepth ty = 0 + +andArityType ABot at2 = at2 +andArityType ATop at2 = ATop +andArityType (AFun t1 at1) (AFun t2 at2) = AFun (t1 && t2) (andArityType at1 at2) +andArityType at1 at2 = andArityType at2 at1 + +arityType :: CoreExpr -> ArityType -- (go1 e) = [b1,..,bn] -- means expression can be rewritten \x_b1 -> ... \x_bn -> body -- where bi is True <=> the lambda is one-shot - go1 (Note n e) | ok_note n = go1 e - go1 (Var v) = replicate (idArity v) False -- When the type of the Id - -- encodes one-shot-ness, use - -- the idinfo here +arityType (Note n e) + | ok_note n = arityType e + | otherwise = ATop + +arityType (Var v) + = mk (idArity v) + where + mk :: Arity -> ArityType + mk 0 | isBottomingId v = ABot + | otherwise = ATop + mk n = AFun False (mk (n-1)) + + -- When the type of the Id encodes one-shot-ness, + -- use the idinfo here -- Lambdas; increase arity - go1 (Lam x e) | isId x = isOneShotLambda x : go1 e - | otherwise = go1 e +arityType (Lam x e) | isId x = AFun (isOneShotLambda x) (arityType e) + | otherwise = arityType e -- Applications; decrease arity - go1 (App f (Type _)) = go1 f - go1 (App f a) = case go1 f of - (one_shot : xs) | one_shot || exprIsCheap a -> xs - other -> [] +arityType (App f (Type _)) = arityType f +arityType (App f a) = case arityType f of + AFun one_shot xs | one_shot -> xs + | exprIsCheap a -> xs + other -> ATop -- Case/Let; keep arity if either the expression is cheap -- or it's a 1-shot lambda - go1 (Case scrut _ alts) = case foldr1 (zipWith (&&)) [go1 rhs | (_,_,rhs) <- alts] of - xs@(one_shot : _) | one_shot || exprIsCheap scrut -> xs - other -> [] - go1 (Let b e) = case go1 e of - xs@(one_shot : _) | one_shot || all exprIsCheap (rhssOfBind b) -> xs - other -> [] - - go1 other = [] - - ok_note InlineMe = False - ok_note other = True - -- Notice that we do not look through __inline_me__ - -- This may seem surprising, but consider - -- f = _inline_me (\x -> e) - -- We DO NOT want to eta expand this to - -- f = \x -> (_inline_me (\x -> e)) x - -- because the _inline_me gets dropped now it is applied, - -- giving just - -- f = \x -> e - -- A Bad Idea +arityType (Case scrut _ alts) = case foldr1 andArityType [arityType rhs | (_,_,rhs) <- alts] of + xs@(AFun one_shot _) | one_shot -> xs + xs | exprIsCheap scrut -> xs + | otherwise -> ATop + +arityType (Let b e) = case arityType e of + xs@(AFun one_shot _) | one_shot -> xs + xs | all exprIsCheap (rhssOfBind b) -> xs + | otherwise -> ATop + +arityType other = ATop + +ok_note InlineMe = False +ok_note other = True + -- Notice that we do not look through __inline_me__ + -- This may seem surprising, but consider + -- f = _inline_me (\x -> e) + -- We DO NOT want to eta expand this to + -- f = \x -> (_inline_me (\x -> e)) x + -- because the _inline_me gets dropped now it is applied, + -- giving just + -- f = \x -> e + -- A Bad Idea + \end{code} \begin{code} etaExpand :: Int -- Add this number of value args - -> UniqSupply + -> [Unique] -> CoreExpr -> Type -- Expression and its type -> CoreExpr -- (etaExpand n us e ty) returns an expression with @@ -758,8 +849,7 @@ etaExpand n us expr ty Just (arg_ty, res_ty) -> Lam arg1 (etaExpand (n-1) us2 (App expr (Var arg1)) res_ty) where arg1 = mkSysLocal SLIT("eta") uniq arg_ty - (us1, us2) = splitUniqSupply us - uniq = uniqFromSupply us1 + (uniq:us2) = us ; Nothing -> @@ -769,7 +859,6 @@ etaExpand n us expr ty }}} \end{code} - exprArity is a cheap-and-cheerful version of exprEtaExpandArity. It tells how many things the expression can be applied to before doing any work. It doesn't look inside cases, lets, etc. The idea is that @@ -791,6 +880,8 @@ Similarly, see the ok_note check in exprEtaExpandArity. So won't be eta-expanded. And in any case it seems more robust to have exprArity be a bit more intelligent. +But note that (\x y z -> f x y z) +should have arity 3, regardless of f's arity. \begin{code} exprArity :: CoreExpr -> Int diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index 96c0499..cdde0eb 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -27,7 +27,7 @@ import Var ( isTyVar ) import IdInfo ( IdInfo, megaSeqIdInfo, arityInfo, ppArityInfo, specInfo, cprInfo, ppCprInfo, - strictnessInfo, ppStrictnessInfo, cgInfo, + strictnessInfo, ppStrictnessInfo, cprInfo, ppCprInfo, workerInfo, ppWorkerInfo, tyGenInfo, ppTyGenInfo, @@ -348,7 +348,6 @@ ppIdInfo b info ppWorkerInfo (workerInfo info), ppStrictnessInfo s, ppr (newStrictnessInfo info), --- pprCgInfo c, ppCprInfo m, pprCoreRules b p -- Inline pragma, occ, demand, lbvar info @@ -359,7 +358,6 @@ ppIdInfo b info a = arityInfo info g = tyGenInfo info s = strictnessInfo info --- c = cgInfo info m = cprInfo info p = specInfo info \end{code} @@ -376,8 +374,8 @@ pprCoreRule :: SDoc -> CoreRule -> SDoc pprCoreRule pp_fn (BuiltinRule name _) = ifPprDebug (ptext SLIT("Built in rule") <+> doubleQuotes (ptext name)) -pprCoreRule pp_fn (Rule name tpl_vars tpl_args rhs) - = doubleQuotes (ptext name) <+> +pprCoreRule pp_fn (Rule name act tpl_vars tpl_args rhs) + = doubleQuotes (ptext name) <+> ppr act <+> sep [ ptext SLIT("__forall") <+> braces (sep (map pprTypedBinder tpl_vars)), nest 2 (pp_fn <+> sep (map pprArg tpl_args)), diff --git a/ghc/compiler/coreSyn/Subst.lhs b/ghc/compiler/coreSyn/Subst.lhs index f228274..07e3b0f 100644 --- a/ghc/compiler/coreSyn/Subst.lhs +++ b/ghc/compiler/coreSyn/Subst.lhs @@ -808,8 +808,8 @@ substRules subst (Rules rules rhs_fvs) new_rules = Rules (map do_subst rules) (substVarSet subst rhs_fvs) do_subst rule@(BuiltinRule _ _) = rule - do_subst (Rule name tpl_vars lhs_args rhs) - = Rule name tpl_vars' + do_subst (Rule name act tpl_vars lhs_args rhs) + = Rule name act tpl_vars' (map (substExpr subst') lhs_args) (substExpr subst' rhs) where diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index aa0fde2..78eb151 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -162,11 +162,11 @@ ppr_ds_rules rules \begin{code} dsRule :: IdSet -> TypecheckedRuleDecl -> DsM (Id, CoreRule) -dsRule in_scope (HsRule name sig_tvs vars lhs rhs loc) +dsRule in_scope (HsRule name act sig_tvs vars lhs rhs loc) = putSrcLocDs loc $ ds_lhs all_vars lhs `thenDs` \ (fn, args) -> dsExpr rhs `thenDs` \ core_rhs -> - returnDs (fn, Rule name tpl_vars args core_rhs) + returnDs (fn, Rule name act tpl_vars args core_rhs) where tpl_vars = sig_tvs ++ [var | RuleBndr var <- vars] all_vars = mkInScopeSet (in_scope `unionVarSet` mkVarSet tpl_vars) diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index 133e1d6..3cbc72a 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -20,14 +20,13 @@ import TcHsSyn ( TypecheckedForeignDecl ) import CoreUtils ( exprType, mkInlineMe ) import Id ( Id, idType, idName, mkVanillaGlobal, mkSysLocal, setInlinePragma ) -import IdInfo ( neverInlinePrag, vanillaIdInfo ) +import IdInfo ( vanillaIdInfo ) import Literal ( Literal(..) ) import Module ( Module, moduleUserString ) import Name ( mkGlobalName, nameModule, nameOccName, getOccString, mkForeignExportOcc, isLocalName, NamedThing(..), ) - import Type ( repType, eqType ) import TcType ( Type, mkFunTys, mkForAllTys, mkTyConApp, mkFunTy, applyTy, @@ -47,8 +46,8 @@ import TysPrim ( addrPrimTy ) import PrelNames ( hasKey, ioTyConKey, deRefStablePtrName, newStablePtrName, bindIOName, returnIOName ) +import BasicTypes ( Activation( NeverActive ) ) import Outputable - import Maybe ( fromJust ) \end{code} @@ -393,7 +392,7 @@ dsFExportDynamic mod_name id cconv io_app = mkLams tvs $ mkLams [cback] $ stbl_app ccall_io_adj res_ty - fed = (id `setInlinePragma` neverInlinePrag, io_app) + fed = (id `setInlinePragma` NeverActive, io_app) -- Never inline the f.e.d. function, because the litlit -- might not be in scope in other modules. in diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index ac71099..d30ff27 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -24,7 +24,7 @@ import PprCore ( {- instance Outputable (Expr a) -} ) import Name ( Name ) import PrelNames ( isUnboundName ) import NameSet ( NameSet, elemNameSet, nameSetToList ) -import BasicTypes ( RecFlag(..), Fixity ) +import BasicTypes ( RecFlag(..), Fixity, Activation(..), pprPhase ) import Outputable import SrcLoc ( SrcLoc ) import Var ( TyVar ) @@ -249,12 +249,9 @@ data Sig name (HsType name) -- ... to these types SrcLoc - | InlineSig name -- INLINE f - (Maybe Int) -- phase - SrcLoc - - | NoInlineSig name -- NOINLINE f - (Maybe Int) -- phase + | InlineSig Bool -- True <=> INLINE f, False <=> NOINLINE f + name -- Function name + Activation -- When inlining is *active* SrcLoc | SpecInstSig (HsType name) -- (Class tys); should be a specialisation of the @@ -292,13 +289,12 @@ sigForThisGroup ns sig | otherwise -> n `elemNameSet` ns sigName :: Sig name -> Maybe name -sigName (Sig n _ _) = Just n -sigName (ClassOpSig n _ _ _) = Just n -sigName (SpecSig n _ _) = Just n -sigName (InlineSig n _ _) = Just n -sigName (NoInlineSig n _ _) = Just n -sigName (FixSig (FixitySig n _ _)) = Just n -sigName other = Nothing +sigName (Sig n _ _) = Just n +sigName (ClassOpSig n _ _ _) = Just n +sigName (SpecSig n _ _) = Just n +sigName (InlineSig _ n _ _) = Just n +sigName (FixSig (FixitySig n _ _)) = Just n +sigName other = Nothing isFixitySig :: Sig name -> Bool isFixitySig (FixSig _) = True @@ -311,8 +307,7 @@ isClassOpSig _ = False isPragSig :: Sig name -> Bool -- Identifies pragmas isPragSig (SpecSig _ _ _) = True -isPragSig (InlineSig _ _ _) = True -isPragSig (NoInlineSig _ _ _) = True +isPragSig (InlineSig _ _ _ _) = True isPragSig (SpecInstSig _ _) = True isPragSig other = False \end{code} @@ -321,8 +316,8 @@ isPragSig other = False hsSigDoc (Sig _ _ loc) = (SLIT("type signature"),loc) hsSigDoc (ClassOpSig _ _ _ loc) = (SLIT("class-method type signature"), loc) hsSigDoc (SpecSig _ _ loc) = (SLIT("SPECIALISE pragma"),loc) -hsSigDoc (InlineSig _ _ loc) = (SLIT("INLINE pragma"),loc) -hsSigDoc (NoInlineSig _ _ loc) = (SLIT("NOINLINE pragma"),loc) +hsSigDoc (InlineSig True _ _ loc) = (SLIT("INLINE pragma"),loc) +hsSigDoc (InlineSig False _ _ loc) = (SLIT("NOINLINE pragma"),loc) hsSigDoc (SpecInstSig _ loc) = (SLIT("SPECIALISE instance pragma"),loc) hsSigDoc (FixSig (FixitySig _ _ loc)) = (SLIT("fixity declaration"), loc) \end{code} @@ -357,11 +352,15 @@ ppr_sig (SpecSig var ty _) nest 4 (ppr ty <+> text "#-}") ] -ppr_sig (InlineSig var phase _) - = hsep [text "{-# INLINE", ppr_phase phase, ppr var, text "#-}"] +ppr_sig (InlineSig True var phase _) + = hsep [text "{-# INLINE", ppr phase, ppr var, text "#-}"] -ppr_sig (NoInlineSig var phase _) - = hsep [text "{-# NOINLINE", ppr_phase phase, ppr var, text "#-}"] +ppr_sig (InlineSig False var phase _) + = hsep [text "{-# NOINLINE", pp_phase phase, ppr var, text "#-}"] + where + pp_phase NeverActive = empty -- NOINLINE f + pp_phase (ActiveAfter n) = pprPhase n -- NOINLINE [2] f + pp_phase AlwaysActive = text "ALWAYS?" -- Unexpected ppr_sig (SpecInstSig ty _) = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"] @@ -371,10 +370,6 @@ ppr_sig (FixSig fix_sig) = ppr fix_sig instance Outputable name => Outputable (FixitySig name) where ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name] - -ppr_phase :: Maybe Int -> SDoc -ppr_phase Nothing = empty -ppr_phase (Just n) = int n \end{code} Checking for distinct signatures; oh, so boring @@ -382,9 +377,8 @@ Checking for distinct signatures; oh, so boring \begin{code} eqHsSig :: Sig Name -> Sig Name -> Bool -eqHsSig (Sig n1 _ _) (Sig n2 _ _) = n1 == n2 -eqHsSig (InlineSig n1 _ _) (InlineSig n2 _ _) = n1 == n2 -eqHsSig (NoInlineSig n1 _ _) (NoInlineSig n2 _ _) = n1 == n2 +eqHsSig (Sig n1 _ _) (Sig n2 _ _) = n1 == n2 +eqHsSig (InlineSig b1 n1 _ _)(InlineSig b2 n2 _ _) = b1 == b2 && n1 == n2 eqHsSig (SpecInstSig ty1 _) (SpecInstSig ty2 _) = ty1 == ty2 eqHsSig (SpecSig n1 ty1 _) (SpecSig n2 ty2 _) = diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs index 3212202..e7af9dc 100644 --- a/ghc/compiler/hsSyn/HsCore.lhs +++ b/ghc/compiler/hsSyn/HsCore.lhs @@ -33,7 +33,7 @@ import HsTypes ( HsType, pprParendHsType, pprHsTyVarBndr, toHsType, -- others: import Id ( idArity, idType, isDataConId_maybe, isFCallId_maybe ) import Var ( varType, isId ) -import IdInfo ( InlinePragInfo, pprInlinePragInfo ) +import IdInfo ( InlinePragInfo ) import Name ( Name, NamedThing(..), getName, toRdrName ) import RdrName ( RdrName, rdrNameOcc ) import OccName ( isTvOcc ) @@ -388,7 +388,7 @@ data HsIdInfo name -- NB: Specialisations and rules come in separately and are -- only later attached to the Id. Partial reason: some are orphans. -ppr_hs_info (HsUnfold prag unf) = ptext SLIT("__U") <> pprInlinePragInfo prag <+> parens (pprUfExpr noParens unf) +ppr_hs_info (HsUnfold prag unf) = ptext SLIT("__U") <> ppr prag <+> parens (pprUfExpr noParens unf) ppr_hs_info (HsArity arity) = ptext SLIT("__A") <+> int arity ppr_hs_info (HsStrictness str) = ptext SLIT("__S") <+> pprIfaceStrictSig str ppr_hs_info HsNoCafRefs = ptext SLIT("__C") diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 04b2af1..2635995 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -32,8 +32,8 @@ import PprCore ( pprCoreRule ) import HsCore ( UfExpr, UfBinder, HsIdInfo, pprHsIdInfo, eq_ufBinders, eq_ufExpr, pprUfExpr ) -import CoreSyn ( CoreRule(..) ) -import BasicTypes ( NewOrData(..), StrictnessMark(..) ) +import CoreSyn ( CoreRule(..), RuleName ) +import BasicTypes ( NewOrData(..), StrictnessMark(..), Activation(..) ) import ForeignCall ( CExportSpec, CCallSpec, DNCallSpec, CCallConv ) -- others: @@ -760,7 +760,8 @@ instance Outputable FoType where \begin{code} data RuleDecl name pat = HsRule -- Source rule - FAST_STRING -- Rule name + RuleName -- Rule name + Activation [name] -- Forall'd tyvars, filled in by the renamer with -- tyvars mentioned in sigs; then filled out by typechecker [RuleBndr name] -- Forall'd term vars @@ -769,7 +770,8 @@ data RuleDecl name pat SrcLoc | IfaceRule -- One that's come in from an interface file; pre-typecheck - FAST_STRING + RuleName + Activation [UfBinder name] -- Tyvars and term vars name -- Head of lhs [UfExpr name] -- Args of LHS @@ -780,13 +782,13 @@ data RuleDecl name pat name -- Head of LHS CoreRule -isIfaceRuleDecl (HsRule _ _ _ _ _ _) = False -isIfaceRuleDecl other = True +isIfaceRuleDecl (HsRule _ _ _ _ _ _ _) = False +isIfaceRuleDecl other = True ifaceRuleDeclName :: RuleDecl name pat -> name -ifaceRuleDeclName (IfaceRule _ _ n _ _ _) = n -ifaceRuleDeclName (IfaceRuleOut n r) = n -ifaceRuleDeclName (HsRule fs _ _ _ _ _) = pprPanic "ifaceRuleDeclName" (ppr fs) +ifaceRuleDeclName (IfaceRule _ _ _ n _ _ _) = n +ifaceRuleDeclName (IfaceRuleOut n r) = n +ifaceRuleDeclName (HsRule fs _ _ _ _ _ _) = pprPanic "ifaceRuleDeclName" (ppr fs) data RuleBndr name = RuleBndr name @@ -794,15 +796,15 @@ data RuleBndr name instance (NamedThing name, Ord name) => Eq (RuleDecl name pat) where -- Works for IfaceRules only; used when comparing interface file versions - (IfaceRule n1 bs1 f1 es1 rhs1 _) == (IfaceRule n2 bs2 f2 es2 rhs2 _) - = n1==n2 && f1 == f2 && + (IfaceRule n1 a1 bs1 f1 es1 rhs1 _) == (IfaceRule n2 a2 bs2 f2 es2 rhs2 _) + = n1==n2 && f1 == f2 && a1==a2 && eq_ufBinders emptyEqHsEnv bs1 bs2 (\env -> eqListBy (eq_ufExpr env) (rhs1:es1) (rhs2:es2)) instance (NamedThing name, Outputable name, Outputable pat) => Outputable (RuleDecl name pat) where - ppr (HsRule name tvs ns lhs rhs loc) - = sep [text "{-# RULES" <+> doubleQuotes (ptext name), + ppr (HsRule name act tvs ns lhs rhs loc) + = sep [text "{-# RULES" <+> doubleQuotes (ptext name) <+> ppr act, pp_forall, ppr lhs, equals <+> ppr rhs, text "#-}" ] where @@ -811,8 +813,8 @@ instance (NamedThing name, Outputable name, Outputable pat) fsep (map ppr tvs ++ map ppr ns) <> dot - ppr (IfaceRule name tpl_vars fn tpl_args rhs loc) - = hsep [ doubleQuotes (ptext name), + ppr (IfaceRule name act tpl_vars fn tpl_args rhs loc) + = hsep [ doubleQuotes (ptext name), ppr act, ptext SLIT("__forall") <+> braces (interppSP tpl_vars), ppr fn <+> sep (map (pprUfExpr parens) tpl_args), ptext SLIT("=") <+> ppr rhs diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 2be4ce5..10a9885 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -6,10 +6,9 @@ \begin{code} module CmdLineOpts ( - CoreToDo(..), - SimplifierSwitch(..), isAmongSimpl, - StgToDo(..), - SwitchResult(..), + CoreToDo(..), StgToDo(..), + SimplifierSwitch(..), + SimplifierMode(..), HscLang(..), DynFlag(..), -- needed non-abstractly by DriverFlags @@ -17,8 +16,6 @@ module CmdLineOpts ( v_Static_hsc_opts, - intSwitchSet, - switchIsOn, isStaticHscFlag, -- Manipulating DynFlags @@ -115,22 +112,15 @@ module CmdLineOpts ( #include "HsVersions.h" -import Array ( array, (//) ) import GlaExts import IOExts ( IORef, readIORef, writeIORef ) +import BasicTypes ( CompilerPhase ) import Constants -- Default values for some flags import Util import FastTypes import Config import Maybes ( firstJust ) -import Panic ( panic ) - -#if __GLASGOW_HASKELL__ < 301 -import ArrBase ( Array(..) ) -#else -import PrelArr ( Array(..) ) -#endif \end{code} %************************************************************************ @@ -173,19 +163,13 @@ main loop (\tr{main/Main.lhs}), in the Core-to-Core processing loop %************************************************************************ \begin{code} -data SwitchResult - = SwBool Bool -- on/off - | SwString FAST_STRING -- nothing or a String - | SwInt Int -- nothing or an Int -\end{code} - -\begin{code} data CoreToDo -- These are diff core-to-core passes, -- which may be invoked in any order, -- as many times as you like. = CoreDoSimplify -- The core-to-core simplifier. - (SimplifierSwitch -> SwitchResult) + SimplifierMode + [SimplifierSwitch] -- Each run of the simplifier can take a different -- set of simplifier-specific flags. | CoreDoFloatInwards @@ -201,8 +185,8 @@ data CoreToDo -- These are diff core-to-core passes, | CoreDoCPResult | CoreDoGlomBinds | CoreCSE - | CoreDoRuleCheck String -- Check for non-application of rules - -- matching this string + | CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules + -- matching this string | CoreDoNothing -- useful when building up lists of these things \end{code} @@ -216,12 +200,13 @@ data StgToDo \end{code} \begin{code} +data SimplifierMode -- See comments in SimplMonad + = SimplGently + | SimplPhase Int + data SimplifierSwitch = MaxSimplifierIterations Int - | SimplInlinePhase Int - | DontApplyRules | NoCaseOfCase - | SimplLetToCase \end{code} %************************************************************************ @@ -660,7 +645,8 @@ isStaticHscFlag f = "fno-prune-tydecls", "static", "funregisterised", - "fext-core" + "fext-core", + "frule-check" ] || any (flip prefixMatch f) [ "fcontext-stack", @@ -676,116 +662,11 @@ isStaticHscFlag f = %************************************************************************ %* * -\subsection{Switch ordering} -%* * -%************************************************************************ - -These things behave just like enumeration types. - -\begin{code} -instance Eq SimplifierSwitch where - a == b = tagOf_SimplSwitch a ==# tagOf_SimplSwitch b - -instance Ord SimplifierSwitch where - a < b = tagOf_SimplSwitch a <# tagOf_SimplSwitch b - a <= b = tagOf_SimplSwitch a <=# tagOf_SimplSwitch b - - -tagOf_SimplSwitch (SimplInlinePhase _) = _ILIT(1) -tagOf_SimplSwitch (MaxSimplifierIterations _) = _ILIT(2) -tagOf_SimplSwitch DontApplyRules = _ILIT(3) -tagOf_SimplSwitch SimplLetToCase = _ILIT(4) -tagOf_SimplSwitch NoCaseOfCase = _ILIT(5) - --- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too! - -lAST_SIMPL_SWITCH_TAG = 5 -\end{code} - -%************************************************************************ -%* * -\subsection{Switch lookup} -%* * -%************************************************************************ - -\begin{code} -isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult -isAmongSimpl on_switches -- Switches mentioned later occur *earlier* - -- in the list; defaults right at the end. - = let - tidied_on_switches = foldl rm_dups [] on_switches - -- The fold*l* ensures that we keep the latest switches; - -- ie the ones that occur earliest in the list. - - sw_tbl :: Array Int SwitchResult - sw_tbl = (array (0, lAST_SIMPL_SWITCH_TAG) -- bounds... - all_undefined) - // defined_elems - - all_undefined = [ (i, SwBool False) | i <- [0 .. lAST_SIMPL_SWITCH_TAG ] ] - - defined_elems = map mk_assoc_elem tidied_on_switches - in - -- (avoid some unboxing, bounds checking, and other horrible things:) -#if __GLASGOW_HASKELL__ < 405 - case sw_tbl of { Array bounds_who_needs_'em stuff -> -#else - case sw_tbl of { Array _ _ stuff -> -#endif - \ switch -> - case (indexArray# stuff (tagOf_SimplSwitch switch)) of -#if __GLASGOW_HASKELL__ < 400 - Lift v -> v -#elif __GLASGOW_HASKELL__ < 403 - (# _, v #) -> v -#else - (# v #) -> v -#endif - } - where - mk_assoc_elem k@(MaxSimplifierIterations lvl) - = (iBox (tagOf_SimplSwitch k), SwInt lvl) - mk_assoc_elem k@(SimplInlinePhase n) - = (iBox (tagOf_SimplSwitch k), SwInt n) - mk_assoc_elem k - = (iBox (tagOf_SimplSwitch k), SwBool True) -- I'm here, Mom! - - -- cannot have duplicates if we are going to use the array thing - rm_dups switches_so_far switch - = if switch `is_elem` switches_so_far - then switches_so_far - else switch : switches_so_far - where - sw `is_elem` [] = False - sw `is_elem` (s:ss) = (tagOf_SimplSwitch sw) ==# (tagOf_SimplSwitch s) - || sw `is_elem` ss -\end{code} - - -%************************************************************************ -%* * \subsection{Misc functions for command-line options} %* * %************************************************************************ -\begin{code} -switchIsOn :: (switch -> SwitchResult) -> switch -> Bool - -switchIsOn lookup_fn switch - = case (lookup_fn switch) of - SwBool False -> False - _ -> True - -intSwitchSet :: (switch -> SwitchResult) - -> (Int -> switch) - -> Maybe Int - -intSwitchSet lookup_fn switch - = case (lookup_fn (switch (panic "intSwitchSet"))) of - SwInt int -> Just int - _ -> Nothing -\end{code} \begin{code} startsWith :: String -> String -> Maybe String diff --git a/ghc/compiler/main/DriverState.hs b/ghc/compiler/main/DriverState.hs index c192cad..ca4f05a 100644 --- a/ghc/compiler/main/DriverState.hs +++ b/ghc/compiler/main/DriverState.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverState.hs,v 1.57 2001/09/14 15:51:42 simonpj Exp $ +-- $Id: DriverState.hs,v 1.58 2001/09/26 15:12:34 simonpj Exp $ -- -- Settings for the driver -- @@ -193,30 +193,30 @@ buildCoreToDo = do if opt_level == 0 then return [ - CoreDoSimplify (isAmongSimpl [ + CoreDoSimplify (SimplPhase 0) [ MaxSimplifierIterations max_iter - ]) + ] ] else {- opt_level >= 1 -} return [ -- initial simplify: mk specialiser happy: minimum effort please - CoreDoSimplify (isAmongSimpl [ - SimplInlinePhase 0, + CoreDoSimplify SimplGently [ + -- Simplify "gently" -- Don't inline anything till full laziness has bitten -- In particular, inlining wrappers inhibits floating -- e.g. ...(case f x of ...)... -- ==> ...(case (case x of I# x# -> fw x#) of ...)... -- ==> ...(case x of I# x# -> case fw x# of ...)... -- and now the redex (f x) isn't floatable any more - DontApplyRules, -- Similarly, don't apply any rules until after full -- laziness. Notably, list fusion can prevent floating. + NoCaseOfCase, -- Don't do case-of-case transformations. -- This makes full laziness work better MaxSimplifierIterations max_iter - ]), + ], -- Specialisation is best done before full laziness -- so that overloaded functions have all their dictionary lambdas manifest @@ -225,33 +225,33 @@ buildCoreToDo = do CoreDoFloatOutwards False{-not full-}, CoreDoFloatInwards, - CoreDoSimplify (isAmongSimpl [ - SimplInlinePhase 1, - -- Want to run with inline phase 1 after the specialiser to give + CoreDoSimplify (SimplPhase 2) [ + -- Want to run with inline phase 2 after the specialiser to give -- maximum chance for fusion to work before we inline build/augment - -- in phase 2. This made a difference in 'ansi' where an + -- in phase 1. This made a difference in 'ansi' where an -- overloaded function wasn't inlined till too late. MaxSimplifierIterations max_iter - ]), + ], + case rule_check of { Just pat -> CoreDoRuleCheck 2 pat; Nothing -> CoreDoNothing }, -- infer usage information here in case we need it later. -- (add more of these where you need them --KSW 1999-04) if usageSP then CoreDoUSPInf else CoreDoNothing, - CoreDoSimplify (isAmongSimpl [ + CoreDoSimplify (SimplPhase 1) [ -- Need inline-phase2 here so that build/augment get -- inlined. I found that spectral/hartel/genfft lost some useful -- strictness in the function sumcode' if augment is not inlined -- before strictness analysis runs - SimplInlinePhase 2, MaxSimplifierIterations max_iter - ]), + ], + case rule_check of { Just pat -> CoreDoRuleCheck 1 pat; Nothing -> CoreDoNothing }, - CoreDoSimplify (isAmongSimpl [ - MaxSimplifierIterations 3 - -- No -finline-phase: allow all Ids to be inlined now + CoreDoSimplify (SimplPhase 0) [ + -- Phase 0: allow all Ids to be inlined now -- This gets foldr inlined before strictness analysis - -- + + MaxSimplifierIterations 3 -- At least 3 iterations because otherwise we land up with -- huge dead expressions because of an infelicity in the -- simpifier. @@ -259,17 +259,18 @@ buildCoreToDo = do -- ==> let k = BIG in letrec go = \xs -> ...(k x).... in go xs -- ==> let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs -- Don't stop now! - ]), + + ], + case rule_check of { Just pat -> CoreDoRuleCheck 0 pat; Nothing -> CoreDoNothing }, if cpr then CoreDoCPResult else CoreDoNothing, if strictness then CoreDoStrictness else CoreDoNothing, CoreDoWorkerWrapper, CoreDoGlomBinds, - CoreDoSimplify (isAmongSimpl [ + CoreDoSimplify (SimplPhase 0) [ MaxSimplifierIterations max_iter - -- No -finline-phase: allow all Ids to be inlined now - ]), + ], CoreDoFloatOutwards False{-not full-}, -- nofib/spectral/hartel/wang doubles in speed if you @@ -297,6 +298,8 @@ buildCoreToDo = do -- Case-liberation for -O2. This should be after -- strictness analysis and the simplification which follows it. + case rule_check of { Just pat -> CoreDoRuleCheck 0 pat; Nothing -> CoreDoNothing }, + if opt_level >= 2 then CoreLiberateCase else @@ -307,12 +310,9 @@ buildCoreToDo = do CoreDoNothing, -- Final clean-up simplification: - CoreDoSimplify (isAmongSimpl [ + CoreDoSimplify (SimplPhase 0) [ MaxSimplifierIterations max_iter - -- No -finline-phase: allow all Ids to be inlined now - ]), - - case rule_check of { Just pat -> CoreDoRuleCheck pat; Nothing -> CoreDoNothing } + ] ] buildStgToDo :: IO [ StgToDo ] diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index f1a57b6..e9851e6 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -14,6 +14,7 @@ module HscMain ( HscResult(..), hscMain, #include "HsVersions.h" #ifdef GHCI +import Interpreter import ByteCodeGen ( byteCodeGen ) import CoreTidy ( tidyCoreExpr ) import CorePrep ( corePrepExpr ) @@ -29,10 +30,12 @@ import HscTypes ( InteractiveContext(..) ) import PrelNames ( iNTERACTIVE ) import StringBuffer ( stringToStringBuffer ) import FastString ( mkFastString ) +import Maybes ( catMaybes ) #endif import HsSyn +import RdrName ( mkRdrOrig ) import Id ( idName ) import IdInfo ( CafInfo(..), CgInfoEnv, CgInfo(..) ) import StringBuffer ( hGetStringBuffer, freeStringBuffer ) @@ -43,6 +46,7 @@ import Finder ( findModule ) import Rename ( checkOldIface, renameModule, closeIfaceDecls ) import Rules ( emptyRuleBase ) import PrelInfo ( wiredInThingEnv, wiredInThings ) +import PrelRules ( builtinRules ) import PrelNames ( knownKeyNames ) import MkIface ( mkFinalIface ) import TcModule @@ -65,9 +69,8 @@ import ErrUtils ( dumpIfSet_dyn, showPass, printError ) import Util ( unJust ) import UniqSupply ( mkSplitUniqSupply ) -import Bag ( emptyBag ) +import Bag ( consBag, emptyBag ) import Outputable -import Interpreter import HscStats ( ppSourceStats ) import HscTypes import FiniteMap ( FiniteMap, plusFM, emptyFM, addToFM ) @@ -79,7 +82,7 @@ import Module ( Module ) import IOExts ( newIORef, readIORef, writeIORef, unsafePerformIO ) import Monad ( when ) -import Maybe ( isJust, fromJust, catMaybes ) +import Maybe ( isJust, fromJust ) import IO import MkExternalCore ( emitExternalCore ) @@ -694,10 +697,18 @@ initPersistentRenamerState :: IO PersistentRenamerState nsIPs = emptyFM }, prsDecls = (emptyNameEnv, 0), prsInsts = (emptyBag, 0), - prsRules = (emptyBag, 0), + prsRules = foldr add_rule (emptyBag, 0) builtinRules, prsImpMods = emptyFM } ) + where + add_rule (name,rule) (rules, n_rules) + = (gated_decl `consBag` rules, n_rules+1) + where + gated_decl = (gate_fn, (mod, IfaceRuleOut rdr_name rule)) + mod = nameModule name + rdr_name = mkRdrOrig (moduleName mod) (nameOccName name) + gate_fn vis_fn = vis_fn name -- Load the rule whenever name is visible initOrigNames :: FiniteMap (ModuleName,OccName) Name initOrigNames diff --git a/ghc/compiler/main/HscStats.lhs b/ghc/compiler/main/HscStats.lhs index 8338b01..61eb47e 100644 --- a/ghc/compiler/main/HscStats.lhs +++ b/ghc/compiler/main/HscStats.lhs @@ -112,8 +112,7 @@ ppSourceStats short (HsModule name version exports imports decls _ src_loc) sig_info (Sig _ _ _) = (1,0,0,0) sig_info (ClassOpSig _ _ _ _) = (0,1,0,0) sig_info (SpecSig _ _ _) = (0,0,1,0) - sig_info (InlineSig _ _ _) = (0,0,0,1) - sig_info (NoInlineSig _ _ _) = (0,0,0,1) + sig_info (InlineSig _ _ _ _) = (0,0,0,1) sig_info _ = (0,0,0,0) import_info (ImportDecl _ _ qual as spec _) diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 9ba3a2f..3d171cb 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -17,8 +17,8 @@ import HsSyn import HsCore ( HsIdInfo(..), UfExpr(..), toUfExpr, toUfBndr ) import HsTypes ( toHsTyVars ) import TysPrim ( alphaTyVars ) -import BasicTypes ( Fixity(..), NewOrData(..), - Version, initialVersion, bumpVersion, +import BasicTypes ( Fixity(..), NewOrData(..), Activation(..), + Version, initialVersion, bumpVersion ) import RnMonad import RnHsSyn ( RenamedInstDecl, RenamedTyClDecl ) @@ -313,12 +313,12 @@ ifaceInstance dfun_id ifaceRule (id, BuiltinRule _ _) = pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule id) -ifaceRule (id, Rule name bndrs args rhs) - = IfaceRule name (map toUfBndr bndrs) (getName id) +ifaceRule (id, Rule name act bndrs args rhs) + = IfaceRule name act (map toUfBndr bndrs) (getName id) (map toUfExpr args) (toUfExpr rhs) noSrcLoc bogusIfaceRule id - = IfaceRule SLIT("bogus") [] (getName id) [] (UfVar (getName id)) noSrcLoc + = IfaceRule SLIT("bogus") NeverActive [] (getName id) [] (UfVar (getName id)) noSrcLoc \end{code} diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs index 845f689..deac286 100644 --- a/ghc/compiler/parser/Lex.lhs +++ b/ghc/compiler/parser/Lex.lhs @@ -36,7 +36,6 @@ module Lex ( import Char ( isSpace, toUpper ) import List ( isSuffixOf ) -import IdInfo ( InlinePragInfo(..) ) import PrelNames ( mkTupNameStr ) import CmdLineOpts ( opt_HiVersion, opt_NoHiCheck ) import ForeignCall ( Safety(..) ) @@ -152,7 +151,7 @@ data Token | ITarity | ITspecialise | ITnocaf - | ITunfold InlinePragInfo + | ITunfold | ITstrict StrictSig | ITrules | ITcprinfo @@ -346,7 +345,7 @@ ghcExtensionKeywordsFM = listToUFM $ ("__C", ITnocaf), ("__R", ITrules), ("__D", ITdeprecated), - ("__U", ITunfold NoInlinePragInfo), + ("__U", ITunfold), ("__ccall", ITccall (False, False, PlayRisky)), ("__ccall_GC", ITccall (False, False, PlaySafe)), diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index da612d8..efe3934 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.73 2001/08/20 10:19:47 simonmar Exp $ +$Id: Parser.y,v 1.74 2001/09/26 15:12:35 simonpj Exp $ Haskell grammar. @@ -28,7 +28,8 @@ import OccName ( UserFS, varName, tcName, dataName, tcClsName, tvName ) import SrcLoc ( SrcLoc ) import Module import CmdLineOpts ( opt_SccProfilingOn ) -import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), NewOrData(..), StrictnessMark(..) ) +import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), + NewOrData(..), StrictnessMark(..), Activation(..) ) import Panic import GlaExts @@ -145,7 +146,7 @@ Conflicts: 14 shift/reduce '__A' { ITarity } '__P' { ITspecialise } '__C' { ITnocaf } - '__U' { ITunfold $$ } + '__U' { ITunfold } '__S' { ITstrict $$ } '__M' { ITcprinfo $$ } -} @@ -414,18 +415,14 @@ decls :: { [RdrBinding] } decl :: { RdrBinding } : fixdecl { $1 } | valdef { $1 } - | '{-# INLINE' srcloc opt_phase qvar '#-}' { RdrSig (InlineSig $4 $3 $2) } - | '{-# NOINLINE' srcloc opt_phase qvar '#-}' { RdrSig (NoInlineSig $4 $3 $2) } + | '{-# INLINE' srcloc activation qvar '#-}' { RdrSig (InlineSig True $4 $3 $2) } + | '{-# NOINLINE' srcloc inverse_activation qvar '#-}' { RdrSig (InlineSig False $4 $3 $2) } | '{-# SPECIALISE' srcloc qvar '::' sigtypes '#-}' { foldr1 RdrAndBindings (map (\t -> RdrSig (SpecSig $3 t $2)) $5) } | '{-# SPECIALISE' srcloc 'instance' inst_type '#-}' { RdrSig (SpecInstSig $4 $2) } -opt_phase :: { Maybe Int } - : INTEGER { Just (fromInteger $1) } - | {- empty -} { Nothing } - wherebinds :: { RdrNameHsBinds } : where { cvBinds cvValSig (groupBindings $1) } @@ -456,8 +453,16 @@ rules :: { RdrBinding } | {- empty -} { RdrNullBind } rule :: { RdrBinding } - : STRING rule_forall infixexp '=' srcloc exp - { RdrHsDecl (RuleD (HsRule $1 [] $2 $3 $6 $5)) } + : STRING activation rule_forall infixexp '=' srcloc exp + { RdrHsDecl (RuleD (HsRule $1 $2 [] $3 $4 $7 $6)) } + +activation :: { Activation } -- Omitted means AlwaysActive + : {- empty -} { AlwaysActive } + | '[' INTEGER ']' { ActiveAfter (fromInteger $2) } + +inverse_activation :: { Activation } -- Omitted means NeverActive + : {- empty -} { NeverActive } + | '[' INTEGER ']' { ActiveAfter (fromInteger $2) } rule_forall :: { [RdrNameRuleBndr] } : 'forall' rule_var_list '.' { $2 } @@ -500,6 +505,7 @@ unsafe_flag :: { Safety } ext_name :: { Maybe CLabelString } : STRING { Just $1 } + | STRING STRING { Just $2 } -- Ignore "module name" for now | {- empty -} { Nothing } diff --git a/ghc/compiler/prelude/PrelRules.lhs b/ghc/compiler/prelude/PrelRules.lhs index 94e4ddb..d6a4b6f 100644 --- a/ghc/compiler/prelude/PrelRules.lhs +++ b/ghc/compiler/prelude/PrelRules.lhs @@ -321,9 +321,6 @@ wordResult result \begin{code} type RuleFun = [CoreExpr] -> Maybe CoreExpr -or_rule :: RuleFun -> RuleFun -> RuleFun -or_rule r1 r2 args = maybe (r2 args) Just (r1 args) -- i.e.: r1 args `mplus` r2 args - twoLits :: (Literal -> Literal -> Maybe CoreExpr) -> RuleFun twoLits rule [Lit l1, Lit l2] = rule (convFloating l1) (convFloating l2) twoLits rule _ = Nothing diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index c6f623d..78553df 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -38,7 +38,8 @@ import HsTypes ( mkHsForAllTy, mkHsTupCon ) import HsCore import Literal ( Literal(..), mkMachInt, mkMachInt64, mkMachWord, mkMachWord64 ) import BasicTypes ( Fixity(..), FixityDirection(..), StrictnessMark(..), - NewOrData(..), Version, initialVersion, Boxity(..) + NewOrData(..), Version, initialVersion, Boxity(..), + Activation(..) ) import CostCentre ( CostCentre(..), IsCafCC(..), IsDupdCC(..) ) import Type ( Kind, mkArrowKind, liftedTypeKind, openTypeKind, usageTypeKind ) @@ -141,7 +142,7 @@ import FastString ( tailFS ) '__A' { ITarity } '__P' { ITspecialise } '__C' { ITnocaf } - '__U' { ITunfold $$ } + '__U' { ITunfold } '__S' { ITstrict $$ } '__R' { ITrules } '__M' { ITcprinfo } @@ -421,8 +422,12 @@ rules :: { [RdrNameRuleDecl] } | rule ';' rules { $1:$3 } rule :: { RdrNameRuleDecl } -rule : src_loc STRING rule_forall qvar_name - core_args '=' core_expr { IfaceRule $2 $3 $4 $5 $7 $1 } +rule : src_loc STRING activation rule_forall qvar_name + core_args '=' core_expr { IfaceRule $2 $3 $4 $5 $6 $8 $1 } + +activation :: { Activation } +activation : {- empty -} { AlwaysActive } + | INTEGER { ActiveAfter (fromInteger $1) } rule_forall :: { [UfBinder RdrName] } rule_forall : '__forall' '{' core_bndrs '}' { $3 } @@ -749,16 +754,8 @@ id_info_item :: { HsIdInfo RdrName } | '__P' qvar_name INTEGER { HsWorker $2 (fromInteger $3) } inline_prag :: { InlinePragInfo } - : {- empty -} { NoInlinePragInfo } - | '[' from_prag phase ']' { IMustNotBeINLINEd $2 $3 } - -from_prag :: { Bool } - : {- empty -} { True } - | '!' { False } - -phase :: { Maybe Int } - : {- empty -} { Nothing } - | INTEGER { Just (fromInteger $1) } + : {- empty -} { AlwaysActive } + | '[' INTEGER ']' { ActiveAfter (fromInteger $2) } ------------------------------------------------------- core_expr :: { UfExpr RdrName } diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index 1ec05fa..eb9ea2d 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -537,15 +537,10 @@ renameSig (FixSig (FixitySig v fix src_loc)) lookupSigOccRn v `thenRn` \ new_v -> returnRn (FixSig (FixitySig new_v fix src_loc)) -renameSig (InlineSig v p src_loc) +renameSig (InlineSig b v p src_loc) = pushSrcLocRn src_loc $ lookupSigOccRn v `thenRn` \ new_v -> - returnRn (InlineSig new_v p src_loc) - -renameSig (NoInlineSig v p src_loc) - = pushSrcLocRn src_loc $ - lookupSigOccRn v `thenRn` \ new_v -> - returnRn (NoInlineSig new_v p src_loc) + returnRn (InlineSig b new_v p src_loc) \end{code} diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index dda823b..d3f7510 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -54,7 +54,6 @@ import ListSetOps ( removeDups, equivClasses ) import Util ( sortLt ) import List ( nub ) import UniqFM ( lookupWithDefaultUFM ) -import Maybes ( orElse ) import CmdLineOpts import FastString ( FastString ) \end{code} diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index dba30bd..8f38a09 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -43,7 +43,6 @@ import TysWiredIn ( intTyCon ) import Name ( NamedThing(..), mkSysLocalName, nameSrcLoc ) import NameSet import UniqFM ( isNullUFM ) -import FiniteMap ( elemFM ) import UniqSet ( emptyUniqSet ) import List ( intersectBy ) import ListSetOps ( removeDups ) diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs index 86d02aa..e5d6c0c 100644 --- a/ghc/compiler/rename/RnHiFiles.lhs +++ b/ghc/compiler/rename/RnHiFiles.lhs @@ -429,7 +429,7 @@ loadRules mod (rule_bag, n_slurped) (version, rules) loadRule :: Module -> RdrNameRuleDecl -> RnM d (GatedDecl RdrNameRuleDecl) -- "Gate" the rule simply by whether the rule variable is -- needed. We can refine this later. -loadRule mod decl@(IfaceRule _ _ var _ _ src_loc) +loadRule mod decl@(IfaceRule _ _ _ var _ _ src_loc) = lookupIfaceName var `thenRn` \ var_name -> returnRn (\vis_fn -> vis_fn var_name, (mod, decl)) @@ -677,9 +677,6 @@ warnRedundantSourceImport mod_name = ptext SLIT("Unnecessary {- SOURCE -} in the import of module") <+> quotes (ppr mod_name) -notLoaded mod - = ptext SLIT("Module") <+> quotes (ppr mod) <+> ptext SLIT("is not loaded") - warnSelfImport mod = ptext SLIT("Importing my own interface: module") <+> ppr mod \end{code} diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index 4789d89..f90eb76 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -167,8 +167,9 @@ instDeclFVs (InstDecl inst_ty _ _ maybe_dfun _) (case maybe_dfun of { Just n -> unitFV n; Nothing -> emptyFVs }) ---------------- -ruleDeclFVs (HsRule _ _ _ _ _ _) = emptyFVs -ruleDeclFVs (IfaceRule _ vars _ args rhs _) +ruleDeclFVs (HsRule _ _ _ _ _ _ _) = emptyFVs +ruleDeclFVs (IfaceRuleOut _ _) = emptyFVs +ruleDeclFVs (IfaceRule _ _ vars _ args rhs _) = delFVs (map ufBinderName vars) $ ufExprFVs rhs `plusFV` plusFVs (map ufExprFVs args) diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index f3ccf33..d02133f 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -217,15 +217,19 @@ finishSourceInstDecl (InstDecl _ mbinds uprags _ _ ) %********************************************************* \begin{code} -rnIfaceRuleDecl (IfaceRule rule_name vars fn args rhs src_loc) +rnIfaceRuleDecl (IfaceRule rule_name act vars fn args rhs src_loc) = pushSrcLocRn src_loc $ lookupOccRn fn `thenRn` \ fn' -> rnCoreBndrs vars $ \ vars' -> mapRn rnCoreExpr args `thenRn` \ args' -> rnCoreExpr rhs `thenRn` \ rhs' -> - returnRn (IfaceRule rule_name vars' fn' args' rhs' src_loc) + returnRn (IfaceRule rule_name act vars' fn' args' rhs' src_loc) -rnHsRuleDecl (HsRule rule_name tvs vars lhs rhs src_loc) +rnIfaceRuleDecl (IfaceRuleOut fn rule) -- Builtin rules come this way + = lookupOccRn fn `thenRn` \ fn' -> + returnRn (IfaceRuleOut fn' rule) + +rnHsRuleDecl (HsRule rule_name act tvs vars lhs rhs src_loc) = ASSERT( null tvs ) pushSrcLocRn src_loc $ @@ -241,7 +245,7 @@ rnHsRuleDecl (HsRule rule_name tvs vars lhs rhs src_loc) bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)] in mapRn (addErrRn . badRuleVar rule_name) bad_vars `thenRn_` - returnRn (HsRule rule_name sig_tvs' vars' lhs' rhs' src_loc, + returnRn (HsRule rule_name act sig_tvs' vars' lhs' rhs' src_loc, fv_vars `plusFV` fv_lhs `plusFV` fv_rhs) where doc = text "In the transformation rule" <+> ptext rule_name diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs index b3e305e..f806be1 100644 --- a/ghc/compiler/specialise/Rules.lhs +++ b/ghc/compiler/specialise/Rules.lhs @@ -31,6 +31,7 @@ import VarSet import VarEnv import TcType ( mkTyVarTy ) import qualified TcType ( match ) +import BasicTypes ( Activation, CompilerPhase, isActive ) import Outputable import Maybe ( isJust, isNothing, fromMaybe ) @@ -82,16 +83,20 @@ where pi' :: Lift Int# is the specialised version of pi. %************************************************************************ \begin{code} -matchRules :: InScopeSet -> [CoreRule] -> [CoreExpr] -> Maybe (RuleName, CoreExpr) +matchRules :: (Activation -> Bool) -> InScopeSet + -> [CoreRule] -> [CoreExpr] -> Maybe (RuleName, CoreExpr) -- See comments on matchRule -matchRules in_scope [] args = Nothing -matchRules in_scope (rule:rules) args - = case matchRule in_scope rule args of +matchRules is_active in_scope [] args = Nothing +matchRules is_active in_scope (rule:rules) args + = case matchRule is_active in_scope rule args of Just result -> Just result - Nothing -> matchRules in_scope rules args + Nothing -> matchRules is_active in_scope rules args +noBlackList :: Activation -> Bool +noBlackList act = False -- Nothing is black listed -matchRule :: InScopeSet -> CoreRule -> [CoreExpr] -> Maybe (RuleName, CoreExpr) +matchRule :: (Activation -> Bool) -> InScopeSet + -> CoreRule -> [CoreExpr] -> Maybe (RuleName, CoreExpr) -- If (matchRule rule args) returns Just (name,rhs) -- then (f args) matches the rule, and the corresponding @@ -136,12 +141,15 @@ matchRule :: InScopeSet -> CoreRule -> [CoreExpr] -> Maybe (RuleName, CoreExpr) -- (\x->E) matches (\x->F x) -matchRule in_scope rule@(BuiltinRule name match_fn) args +matchRule is_active in_scope rule@(BuiltinRule name match_fn) args = case match_fn args of Just expr -> Just (name,expr) Nothing -> Nothing -matchRule in_scope rule@(Rule rn tpl_vars tpl_args rhs) args +matchRule is_active in_scope rule@(Rule rn act tpl_vars tpl_args rhs) args + | not (is_active act) + = Nothing + | otherwise = go tpl_args args emptySubst -- We used to use the in_scope set, but I don't think that's necessary -- After all, the result is going to be simplified again with that in_scope set @@ -429,7 +437,7 @@ addRule id (Rules rules rhs_fvs) rule -- that shoudn't be. E.g. -- RULE: f (f x y) z ==> f x (f y z) -insertRule rules new_rule@(Rule _ tpl_vars tpl_args _) +insertRule rules new_rule@(Rule _ _ tpl_vars tpl_args _) = go rules where tpl_var_set = mkInScopeSet (mkVarSet tpl_vars) @@ -440,7 +448,7 @@ insertRule rules new_rule@(Rule _ tpl_vars tpl_args _) go (rule:rules) | new_is_more_specific rule = (new_rule:rule:rules) | otherwise = rule : go rules - new_is_more_specific rule = isJust (matchRule tpl_var_set rule tpl_args) + new_is_more_specific rule = isJust (matchRule noBlackList tpl_var_set rule tpl_args) addIdSpecialisations :: Id -> [CoreRule] -> Id addIdSpecialisations id rules @@ -457,10 +465,11 @@ addIdSpecialisations id rules %************************************************************************ \begin{code} -lookupRule :: InScopeSet -> Id -> [CoreExpr] -> Maybe (RuleName, CoreExpr) -lookupRule in_scope fn args +lookupRule :: (Activation -> Bool) -> InScopeSet + -> Id -> [CoreExpr] -> Maybe (RuleName, CoreExpr) +lookupRule is_active in_scope fn args = case idSpecialisation fn of - Rules rules _ -> matchRules in_scope rules args + Rules rules _ -> matchRules is_active in_scope rules args \end{code} @@ -483,10 +492,10 @@ all its (active) rules. No need to construct a rule base or anything like that. \begin{code} -ruleCheckProgram :: String -> [CoreBind] -> SDoc +ruleCheckProgram :: CompilerPhase -> String -> [CoreBind] -> SDoc -- Report partial matches for rules beginning -- with the specified string -ruleCheckProgram rule_pat binds +ruleCheckProgram phase rule_pat binds | isEmptyBag results = text "Rule check results: no rule application sites" | otherwise @@ -495,10 +504,10 @@ ruleCheckProgram rule_pat binds vcat [ p $$ line | p <- bagToList results ] ] where - results = unionManyBags (map (ruleCheckBind rule_pat) binds) + results = unionManyBags (map (ruleCheckBind (phase, rule_pat)) binds) line = text (take 20 (repeat '-')) -type RuleCheckEnv = String -- Pattern +type RuleCheckEnv = (CompilerPhase, String) -- Phase and Pattern ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc -- The Bag returned has one SDoc for each call site found @@ -519,29 +528,23 @@ ruleCheck env (Case e _ as) = ruleCheck env e `unionBags` ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as) ruleCheckApp env (Var f) as = ruleCheckFun env f as ruleCheckApp env other as = ruleCheck env other - -ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc -ruleCheckFun env fun args - = ruleAppCheck match fun args - where - match rule_name = env `isPrefixOf` _UNPK_ rule_name \end{code} \begin{code} -ruleAppCheck :: (RuleName -> Bool) -> Id -> [CoreExpr] -> Bag SDoc +ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc -- Produce a report for all rules matching the predicate -- saying why it doesn't match the specified application -ruleAppCheck name_match fn args +ruleCheckFun (phase, pat) fn args | null name_match_rules = emptyBag - | otherwise = unitBag (ruleAppCheck_help fn args name_match_rules) + | otherwise = unitBag (ruleAppCheck_help phase fn args name_match_rules) where name_match_rules = case idSpecialisation fn of Rules rules _ -> filter match rules - match rule = name_match (ruleName rule) + match rule = pat `isPrefixOf` _UNPK_ (ruleName rule) -ruleAppCheck_help :: Id -> [CoreExpr] -> [CoreRule] -> SDoc -ruleAppCheck_help fn args rules +ruleAppCheck_help :: CompilerPhase -> Id -> [CoreExpr] -> [CoreRule] -> SDoc +ruleAppCheck_help phase fn args rules = -- The rules match the pattern, so we want to print something vcat [text "Expression:" <+> ppr (mkApps (Var fn) args), vcat (map check_rule rules)] @@ -552,15 +555,16 @@ ruleAppCheck_help fn args rules check_rule rule = rule_herald rule <> colon <+> rule_info rule rule_herald (BuiltinRule name _) = text "Builtin rule" <+> doubleQuotes (ptext name) - rule_herald (Rule name _ _ _) = text "Rule" <+> doubleQuotes (ptext name) + rule_herald (Rule name _ _ _ _) = text "Rule" <+> doubleQuotes (ptext name) rule_info rule - | Just (name,_) <- matchRule emptyInScopeSet rule args + | Just (name,_) <- matchRule noBlackList emptyInScopeSet rule args = text "matches (which is very peculiar!)" rule_info (BuiltinRule name fn) = text "does not match" - rule_info (Rule name rule_bndrs rule_args _) + rule_info (Rule name act rule_bndrs rule_args _) + | not (isActive phase act) = text "active only in later phase" | n_args < n_rule_args = text "too few arguments" | n_mismatches == n_rule_args = text "no arguments match" | n_mismatches == 0 = text "all arguments match (considered individually), but the rule as a whole does not" diff --git a/ghc/compiler/specialise/SpecConstr.lhs b/ghc/compiler/specialise/SpecConstr.lhs index 7f2246a..32132c76 100644 --- a/ghc/compiler/specialise/SpecConstr.lhs +++ b/ghc/compiler/specialise/SpecConstr.lhs @@ -16,7 +16,7 @@ import CoreUtils ( exprType, eqExpr ) import CoreFVs ( exprsFreeVars ) import DataCon ( dataConRepArity ) import Type ( tyConAppArgs ) -import PprCore ( pprCoreRules, pprCoreRule ) +import PprCore ( pprCoreRules ) import Id ( Id, idName, idType, idSpecialisation, isDataConId_maybe, mkUserLocal, mkSysLocal ) @@ -28,6 +28,7 @@ import Rules ( addIdSpecialisations ) import OccName ( mkSpecOcc ) import ErrUtils ( dumpIfSet_dyn ) import CmdLineOpts ( DynFlags, DynFlag(..) ) +import BasicTypes ( Activation(..) ) import Outputable import Maybes ( orElse ) @@ -35,7 +36,6 @@ import Util ( mapAccumL ) import List ( nubBy, partition ) import UniqSupply import Outputable -import UniqFM ( ufmToList ) \end{code} ----------------------------------------------------- @@ -506,7 +506,7 @@ spec_one env fn rhs (pats, n) rule_name = _PK_ ("SC:" ++ showSDoc (ppr fn <> int n)) spec_rhs = mkLams bndrs (mkApps rhs pats) spec_id = mkUserLocal spec_occ spec_uniq (exprType spec_rhs) fn_loc - rule = Rule rule_name bndrs pats (mkVarApps (Var spec_id) bndrs) + rule = Rule rule_name AlwaysActive bndrs pats (mkVarApps (Var spec_id) bndrs) in returnUs (rule, (spec_id, spec_rhs)) \end{code} diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index d950200..0428772 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -9,7 +9,7 @@ module Specialise ( specProgram ) where #include "HsVersions.h" import CmdLineOpts ( DynFlags, DynFlag(..) ) -import Id ( Id, idName, idType, mkUserLocal, idSpecialisation ) +import Id ( Id, idName, idType, mkUserLocal, idSpecialisation, isDataConWrapId ) import TcType ( Type, mkTyVarTy, tcSplitSigmaTy, tyVarsOfTypes, tyVarsOfTheta, mkForAllTys, tcCmpType @@ -24,7 +24,6 @@ import VarSet import VarEnv import CoreSyn import CoreUtils ( applyTypeToArgs ) -import CoreUnfold ( certainlyWillInline ) import CoreFVs ( exprFreeVars, exprsFreeVars ) import CoreLint ( showPass, endPass ) import PprCore ( pprCoreRules ) @@ -38,6 +37,7 @@ import Name ( nameOccName, mkSpecOcc, getSrcLoc ) import FiniteMap import Maybes ( catMaybes, maybeToBool ) import ErrUtils ( dumpIfSet_dyn ) +import BasicTypes ( Activation( AlwaysActive ) ) import Bag import List ( partition ) import Util ( zipEqual, zipWithEqual, cmpList ) @@ -788,7 +788,14 @@ specDefn subst calls (fn, rhs) | n_tyvars == length rhs_tyvars -- Rhs of fn's defn has right number of big lambdas && n_dicts <= length rhs_bndrs -- and enough dict args && not (null calls_for_me) -- And there are some calls to specialise - && not (certainlyWillInline fn) -- And it's not small + && not (isDataConWrapId fn) -- And it's not a data con wrapper, which have + -- stupid overloading that simply discard the dictionary + +-- At one time I tried not specialising small functions +-- but sometimes there are big functions marked INLINE +-- that we'd like to specialise. In particular, dictionary +-- functions, which Marcin is keen to inline +-- && not (certainlyWillInline fn) -- And it's not small -- If it's small, it's better just to inline -- it than to construct lots of specialisations = -- Specialise the body of the function @@ -820,7 +827,11 @@ specDefn subst calls (fn, rhs) n_tyvars = length tyvars n_dicts = length theta - (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs + -- It's important that we "see past" any INLINE pragma + -- else we'll fail to specialise an INLINE thing + (inline_me, rhs') = dropInline rhs + (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs' + rhs_dicts = take n_dicts rhs_ids rhs_bndrs = rhs_tyvars ++ rhs_dicts body = mkLams (drop n_dicts rhs_ids) rhs_body @@ -878,14 +889,22 @@ specDefn subst calls (fn, rhs) -- The rule to put in the function's specialisation is: -- forall b,d, d1',d2'. f t1 b t3 d d1' d2' = f1 b d spec_env_rule = Rule (_PK_ ("SPEC " ++ showSDoc (ppr fn))) + AlwaysActive (poly_tyvars ++ rhs_dicts') inst_args (mkTyApps (Var spec_f) (map mkTyVarTy poly_tyvars)) -- Add the { d1' = dx1; d2' = dx2 } usage stuff final_uds = foldr addDictBind rhs_uds (my_zipEqual "spec_call" rhs_dicts' call_ds) + + -- NOTE: we don't add back in any INLINE pragma on the RHS, so even if + -- the original function said INLINE, the specialised copies won't. + -- The idea is that the point of inlining was precisely to specialise + -- the function at its call site, and that's not so important for the + -- specialised copies. But it still smells like an ad hoc decision. + in - returnSM ((spec_f, spec_rhs), + returnSM ((spec_f, spec_rhs), final_uds, spec_env_rule) @@ -893,6 +912,10 @@ specDefn subst calls (fn, rhs) my_zipEqual doc xs ys | length xs /= length ys = pprPanic "my_zipEqual" (ppr xs $$ ppr ys $$ (ppr fn <+> ppr call_ts) $$ ppr rhs) | otherwise = zipEqual doc xs ys + +dropInline :: CoreExpr -> (Bool, CoreExpr) +dropInline (Note InlineMe rhs) = (True, rhs) +dropInline rhs = (False, rhs) \end{code} %************************************************************************ @@ -983,7 +1006,7 @@ mkCallUDs subst f args | null theta || length spec_tys /= n_tyvars || length dicts /= n_dicts - || maybeToBool (lookupRule (substInScope subst) f args) + || maybeToBool (lookupRule (\act -> True) (substInScope subst) f args) -- There's already a rule covering this call. A typical case -- is where there's an explicit user-provided rule. Then -- we don't want to create a specialised version diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs index 2218a6a..666d7ff 100644 --- a/ghc/compiler/stranal/StrictAnal.lhs +++ b/ghc/compiler/stranal/StrictAnal.lhs @@ -17,13 +17,13 @@ import Id ( setIdStrictness, setInlinePragma, idDemandInfo, setIdDemandInfo, isBottomingId, Id ) -import IdInfo ( neverInlinePrag ) import CoreLint ( showPass, endPass ) import ErrUtils ( dumpIfSet_dyn ) import SaAbsInt import SaLib import Demand ( Demand, wwStrict, isStrict, isLazy ) import Util ( zipWith3Equal, stretchZipWith ) +import BasicTypes ( Activation( NeverActive ) ) import Outputable import FastTypes \end{code} @@ -196,7 +196,7 @@ saTopBind str_env abs_env (Rec pairs) -- This avoids fruitless inlining of top level error functions addStrictnessInfoToTopId str_val abs_val bndr = if isBottomingId new_id then - new_id `setInlinePragma` neverInlinePrag + new_id `setInlinePragma` NeverActive else new_id where diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs index 331b623..279a5f1 100644 --- a/ghc/compiler/stranal/WorkWrap.lhs +++ b/ghc/compiler/stranal/WorkWrap.lhs @@ -16,12 +16,12 @@ import Id ( Id, idType, idNewStrictness, idArity, isOneShotLambda, setIdNewStrictness, zapIdNewStrictness, idInlinePragma, mkWorkerId, setIdWorkerInfo, setInlinePragma ) import Type ( Type ) -import IdInfo ( InlinePragInfo(..), isNeverInlinePrag, WorkerInfo(..) ) +import IdInfo ( WorkerInfo(..) ) import NewDemand ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..), mkTopDmdType, isBotRes, returnsCPR ) import UniqSupply ( UniqSupply, initUs_, returnUs, thenUs, mapUs, getUniqueUs, UniqSM ) -import BasicTypes ( RecFlag(..), isNonRec ) +import BasicTypes ( RecFlag(..), isNonRec, Activation(..), isNeverActive ) import CmdLineOpts import WwLib import Outputable @@ -182,7 +182,7 @@ tryWW :: RecFlag -- if two, then a worker and a -- wrapper. tryWW is_rec fn_id rhs - | isNeverInlinePrag inline_prag + | isNeverActive inline_prag -- Don't split NOINLINE things, because they will never be inlined -- Furthermore, zap the strictess info in the Id. Why? Because -- the NOINLINE says "don't expose any of the inner workings at the call @@ -237,8 +237,8 @@ tryWW is_rec fn_id rhs wrap_rhs = wrap_fn work_id wrap_id = fn_id `setIdWorkerInfo` HasWorker work_id arity - `setInlinePragma` NoInlinePragInfo -- Zap any inline pragma; - -- Put it on the worker instead + `setInlinePragma` AlwaysActive -- Zap any inline pragma; + -- Put it on the worker instead in returnUs ([(work_id, work_rhs), (wrap_id, wrap_rhs)]) -- Worker first, because wrapper mentions it diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 9ace4e4..e5a83ab 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -45,15 +45,14 @@ import TcType ( mkTyVarTy, mkForAllTys, mkFunTys, tyVarsOfType, import CoreFVs ( idFreeTyVars ) import Id ( mkLocalId, setInlinePragma ) import Var ( idType, idName ) -import IdInfo ( InlinePragInfo(..) ) import Name ( Name, getOccName, getSrcLoc ) import NameSet import Var ( tyVarKind ) import VarSet import Bag import Util ( isIn ) -import Maybes ( maybeToBool ) -import BasicTypes ( TopLevelFlag(..), RecFlag(..), isNonRec, isNotTopLevel ) +import BasicTypes ( TopLevelFlag(..), RecFlag(..), isNonRec, isNotTopLevel, + isAlwaysActive ) import FiniteMap ( listToFM, lookupFM ) import Outputable \end{code} @@ -258,14 +257,10 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec exports = zipWith mk_export binder_names zonked_mono_ids dict_tys = map idType zonked_dict_ids - inlines = mkNameSet [name | InlineSig name _ loc <- inline_sigs] - no_inlines = listToFM ([(name, IMustNotBeINLINEd False phase) | NoInlineSig name phase loc <- inline_sigs] ++ - [(name, IMustNotBeINLINEd True phase) | InlineSig name phase loc <- inline_sigs, maybeToBool phase]) - -- "INLINE n foo" means inline foo, but not until at least phase n - -- "NOINLINE n foo" means don't inline foo until at least phase n, and even - -- then only if it is small enough etc. - -- "NOINLINE foo" means don't inline foo ever, which we signal with a (IMustNotBeINLINEd Nothing) - -- See comments in CoreUnfold.blackListed for the Authorised Version + inlines = mkNameSet [name | InlineSig True name _ loc <- inline_sigs] + no_inlines = listToFM [(name, phase) | InlineSig _ name phase _ <- inline_sigs, + not (isAlwaysActive phase)] + -- AlwaysActive is the default, so don't bother with them mk_export binder_name zonked_mono_id = (tyvars, @@ -660,8 +655,9 @@ tcMonoBinds mbinds tc_ty_sigs is_rec newTyVarTy kind `thenNF_Tc` \ pat_ty -> -- Now typecheck the pattern - -- We don't support binding fresh type variables in the - -- pattern of a pattern binding. For example, this is illegal: + -- We don't support binding fresh (not-already-in-scope) scoped + -- type variables in the pattern of a pattern binding. + -- For example, this is illegal: -- (x::a, y::b) = e -- whereas this is ok -- (x::Int, y::Bool) = e diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 0e37312..1e43296 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -607,10 +607,8 @@ find_bind sel_name meth_name other = Nothing -- Default case find_prags sel_name meth_name [] = [] find_prags sel_name meth_name (SpecSig name ty loc : prags) | name == sel_name = SpecSig meth_name ty loc : find_prags sel_name meth_name prags -find_prags sel_name meth_name (InlineSig name phase loc : prags) - | name == sel_name = InlineSig meth_name phase loc : find_prags sel_name meth_name prags -find_prags sel_name meth_name (NoInlineSig name phase loc : prags) - | name == sel_name = NoInlineSig meth_name phase loc : find_prags sel_name meth_name prags +find_prags sel_name meth_name (InlineSig sense name phase loc : prags) + | name == sel_name = InlineSig sense meth_name phase loc : find_prags sel_name meth_name prags find_prags sel_name meth_name (prag:prags) = find_prags sel_name meth_name prags \end{code} diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index fb866a3..9b281ed 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -71,7 +71,6 @@ import InstEnv ( InstEnv, emptyInstEnv ) import HscTypes ( lookupType, TyThing(..) ) import Util ( zipEqual ) import SrcLoc ( SrcLoc ) -import qualified PrelNames import Outputable import IOExts ( newIORef ) diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index 0008921..273572b 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -392,26 +392,6 @@ gen_Ord_binds tycon -- inexhaustive patterns | otherwise = eqTag_Expr -- Some nullary constructors; -- Tags are equal, no args => return EQ - -------------------------------------------------------------------- - -{- Not necessary: the default decls in PrelBase handle these - -defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_] - -lt = mk_easy_FunMonoBind generatedSrcLoc lt_RDR [a_Pat, b_Pat] [] ( - compare_Case true_Expr false_Expr false_Expr a_Expr b_Expr) -le = mk_easy_FunMonoBind generatedSrcLoc le_RDR [a_Pat, b_Pat] [] ( - compare_Case true_Expr true_Expr false_Expr a_Expr b_Expr) -ge = mk_easy_FunMonoBind generatedSrcLoc ge_RDR [a_Pat, b_Pat] [] ( - compare_Case false_Expr true_Expr true_Expr a_Expr b_Expr) -gt = mk_easy_FunMonoBind generatedSrcLoc gt_RDR [a_Pat, b_Pat] [] ( - compare_Case false_Expr false_Expr true_Expr a_Expr b_Expr) - -max_ = mk_easy_FunMonoBind generatedSrcLoc max_RDR [a_Pat, b_Pat] [] ( - compare_Case b_Expr a_Expr a_Expr a_Expr b_Expr) -min_ = mk_easy_FunMonoBind generatedSrcLoc min_RDR [a_Pat, b_Pat] [] ( - compare_Case a_Expr b_Expr b_Expr a_Expr b_Expr) --} \end{code} %************************************************************************ @@ -1067,12 +1047,6 @@ isLRAssoc get_fixity nm = Fixity _ InfixN -> (False, False) Fixity _ InfixR -> (False, True) Fixity _ InfixL -> (True, False) - -isInfixOccName :: String -> Bool -isInfixOccName str = - case str of - (':':_) -> True - _ -> False \end{code} @@ -1195,10 +1169,6 @@ mk_easy_App f xs = foldl HsApp (HsVar f) (map HsVar xs) ToDo: Better SrcLocs. \begin{code} -compare_Case :: - RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr - -> RdrNameHsExpr -> RdrNameHsExpr - -> RdrNameHsExpr compare_gen_Case :: RdrName -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr @@ -1210,7 +1180,6 @@ careful_compare_Case :: -- checks for primitive types... -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr -compare_Case = compare_gen_Case compare_RDR cmp_eq_Expr a b = HsApp (HsApp (HsVar cmp_eq_RDR) a) b -- Was: compare_gen_Case cmp_eq_RDR diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index da3bb70..58480b1 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -716,13 +716,13 @@ zonkForeignExport (ForeignExport i hs_ty spec src_loc) = zonkRules :: [TcRuleDecl] -> NF_TcM [TypecheckedRuleDecl] zonkRules rs = mapNF_Tc zonkRule rs -zonkRule (HsRule name tyvars vars lhs rhs loc) +zonkRule (HsRule name act tyvars vars lhs rhs loc) = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars -> mapNF_Tc zonkIdBndr [v | RuleBndr v <- vars] `thenNF_Tc` \ new_bndrs -> tcExtendGlobalValEnv new_bndrs $ zonkExpr lhs `thenNF_Tc` \ new_lhs -> zonkExpr rhs `thenNF_Tc` \ new_rhs -> - returnNF_Tc (HsRule name new_tyvars (map RuleBndr new_bndrs) new_lhs new_rhs loc) + returnNF_Tc (HsRule name act new_tyvars (map RuleBndr new_bndrs) new_lhs new_rhs loc) -- I hate this map RuleBndr stuff zonkRule (IfaceRuleOut fun rule) diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 540c92e..aef778a 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -58,7 +58,7 @@ import FunDeps ( checkInstFDs ) import Generics ( validGenericInstanceType ) import Module ( Module, foldModuleEnv ) import Name ( getSrcLoc ) -import NameSet ( unitNameSet, nameSetToList ) +import NameSet ( unitNameSet, emptyNameSet, nameSetToList ) import PrelInfo ( eRROR_ID ) import TyCon ( TyCon ) import Subst ( mkTopTyVarSubst, substTheta ) @@ -610,11 +610,16 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, dict_constr = classDataCon clas scs_and_meths = map instToId (sc_dicts ++ meth_insts) this_dict_id = instToId this_dict - inlines = unitNameSet (idName dfun_id) + inlines | null dfun_arg_dicts = emptyNameSet + | otherwise = unitNameSet (idName dfun_id) -- Always inline the dfun; this is an experimental decision -- because it makes a big performance difference sometimes. -- Often it means we can do the method selection, and then -- inline the method as well. Marcin's idea; see comments below. + -- + -- BUT: don't inline it if it's a constant dictionary; + -- we'll get all the benefit without inlining, and we get + -- a **lot** of code duplication if we inline it dict_rhs | null scs_and_meths @@ -646,7 +651,7 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, = AbsBinds zonked_inst_tyvars (map instToId dfun_arg_dicts) - [(inst_tyvars', dfun_id, this_dict_id)] + [(inst_tyvars', local_dfun_id, this_dict_id)] inlines (lie_binds1 `AndMonoBinds` lie_binds2 `AndMonoBinds` diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs index 0e18104..13b656b 100644 --- a/ghc/compiler/typecheck/TcMType.lhs +++ b/ghc/compiler/typecheck/TcMType.lhs @@ -60,7 +60,7 @@ import TcType ( tcEqType, tcCmpPred, liftedTypeKind, unliftedTypeKind, openTypeKind, defaultKind, superKind, superBoxity, liftedBoxity, hasMoreBoxityInfo, typeKind, - tyVarsOfType, tyVarsOfTypes, tidyOpenType, tidyOpenTypes, tidyTyVar, + tyVarsOfType, tyVarsOfTypes, tidyOpenType, tidyOpenTypes, tidyOpenTyVar, eqKind, isTypeKind, isFFIArgumentTy, isFFIImportResultTy @@ -1436,7 +1436,7 @@ unifyKindCtxt swapped tv1 ty2 tidy_env -- not swapped => tv1 expected, ty2 infer where (pp_expected, pp_actual) | swapped = (pp2, pp1) | otherwise = (pp1, pp2) - (env1, tv1') = tidyTyVar tidy_env tv1 + (env1, tv1') = tidyOpenTyVar tidy_env tv1 (env2, ty2') = tidyOpenType env1 ty2 pp1 = ppr tv1' pp2 = ppr ty2' @@ -1457,13 +1457,13 @@ unifyWithSigErr tyvar ty = (env2, hang (ptext SLIT("Cannot unify the type-signature variable") <+> quotes (ppr tidy_tyvar)) 4 (ptext SLIT("with the type") <+> quotes (ppr tidy_ty))) where - (env1, tidy_tyvar) = tidyTyVar emptyTidyEnv tyvar - (env2, tidy_ty) = tidyOpenType env1 ty + (env1, tidy_tyvar) = tidyOpenTyVar emptyTidyEnv tyvar + (env2, tidy_ty) = tidyOpenType env1 ty unifyOccurCheck tyvar ty = (env2, hang (ptext SLIT("Occurs check: cannot construct the infinite type:")) 4 (sep [ppr tidy_tyvar, char '=', ppr tidy_ty])) where - (env1, tidy_tyvar) = tidyTyVar emptyTidyEnv tyvar - (env2, tidy_ty) = tidyOpenType env1 ty + (env1, tidy_tyvar) = tidyOpenTyVar emptyTidyEnv tyvar + (env2, tidy_ty) = tidyOpenType env1 ty \end{code} diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index d57b53b..7277db7 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -43,7 +43,7 @@ import TcType ( Type, Kind, SourceType(..), ThetaType, mkAppTys, mkRhoTy, liftedTypeKind, unliftedTypeKind, mkArrowKind, mkArrowKinds, tcGetTyVar_maybe, tcGetTyVar, tcSplitFunTy_maybe, - tidyOpenType, tidyOpenTypes, tidyTyVar, tidyTyVars, + tidyOpenType, tidyOpenTypes, tidyOpenTyVar, tidyOpenTyVars, tyVarsOfType, mkForAllTys ) import Inst ( Inst, InstOrigin(..), newMethodWithGivenTy, instToId ) @@ -61,7 +61,7 @@ import Name ( Name ) import TysWiredIn ( mkListTy, mkTupleTy, genUnitTyCon ) import BasicTypes ( Boxity(..) ) import SrcLoc ( SrcLoc ) -import Util ( mapAccumL, isSingleton ) +import Util ( isSingleton ) import Outputable \end{code} @@ -696,8 +696,8 @@ checkSigTyVars sig_tyvars free_tyvars failWithTcM (env3, main_msg $$ nest 4 (vcat msgs)) where - (env1, tidy_tvs) = mapAccumL tidyTyVar emptyTidyEnv sig_tyvars - (env2, tidy_tys) = tidyOpenTypes env1 sig_tys + (env1, tidy_tvs) = tidyOpenTyVars emptyTidyEnv sig_tyvars + (env2, tidy_tys) = tidyOpenTypes env1 sig_tys main_msg = ptext SLIT("Inferred type is less polymorphic than expected") @@ -770,7 +770,7 @@ find_frees tv tidy_env acc (ftv:ftvs) = zonkTcTyVar ftv `thenNF_Tc` \ ty -> if tv `elemVarSet` tyVarsOfType ty then let - (tidy_env', ftv') = tidyTyVar tidy_env ftv + (tidy_env', ftv') = tidyOpenTyVar tidy_env ftv in find_frees tv tidy_env' (ftv':acc) ftvs else @@ -814,7 +814,7 @@ sigCtxt :: Message -> [TcTyVar] -> TcThetaType -> TcTauType sigCtxt when sig_tyvars sig_theta sig_tau tidy_env = zonkTcType sig_tau `thenNF_Tc` \ actual_tau -> let - (env1, tidy_sig_tyvars) = tidyTyVars tidy_env sig_tyvars + (env1, tidy_sig_tyvars) = tidyOpenTyVars tidy_env sig_tyvars (env2, tidy_sig_rho) = tidyOpenType env1 (mkRhoTy sig_theta sig_tau) (env3, tidy_actual_tau) = tidyOpenType env2 actual_tau msg = vcat [ptext SLIT("Signature type: ") <+> pprType (mkForAllTys tidy_sig_tyvars tidy_sig_rho), diff --git a/ghc/compiler/typecheck/TcRules.lhs b/ghc/compiler/typecheck/TcRules.lhs index d041fc9..ef54cfa 100644 --- a/ghc/compiler/typecheck/TcRules.lhs +++ b/ghc/compiler/typecheck/TcRules.lhs @@ -49,25 +49,25 @@ tcIfaceRules pkg_rule_base mod decls tcIfaceRule :: RenamedRuleDecl -> TcM TypecheckedRuleDecl -- No zonking necessary! -tcIfaceRule rule@(IfaceRule name vars fun args rhs src_loc) +tcIfaceRule (IfaceRule name act vars fun args rhs src_loc) = tcAddSrcLoc src_loc $ tcAddErrCtxt (ruleCtxt name) $ tcVar fun `thenTc` \ fun' -> tcCoreLamBndrs vars $ \ vars' -> mapTc tcCoreExpr args `thenTc` \ args' -> tcCoreExpr rhs `thenTc` \ rhs' -> - let - new_rule :: TypecheckedRuleDecl - new_rule = IfaceRuleOut fun' (Rule name vars' args' rhs') - in - returnTc new_rule + returnTc (IfaceRuleOut fun' (Rule name act vars' args' rhs')) + +tcIfaceRule (IfaceRuleOut fun rule) -- Built-in rules come this way + = tcVar fun `thenTc` \ fun' -> + returnTc (IfaceRuleOut fun' rule) tcSourceRules :: [RenamedRuleDecl] -> TcM (LIE, [TypecheckedRuleDecl]) tcSourceRules decls = mapAndUnzipTc tcSourceRule decls `thenTc` \ (lies, decls') -> returnTc (plusLIEs lies, decls') -tcSourceRule (HsRule name sig_tvs vars lhs rhs src_loc) +tcSourceRule (HsRule name act sig_tvs vars lhs rhs src_loc) = tcAddSrcLoc src_loc $ tcAddErrCtxt (ruleCtxt name) $ newTyVarTy openTypeKind `thenNF_Tc` \ rule_ty -> @@ -125,7 +125,7 @@ tcSourceRule (HsRule name sig_tvs vars lhs rhs src_loc) forall_tvs lhs_dicts rhs_lie `thenTc` \ (forall_tvs1, lie', rhs_binds) -> - returnTc (lie', HsRule name forall_tvs1 + returnTc (lie', HsRule name act forall_tvs1 (map RuleBndr tpl_ids) -- yuk (mkHsLet lhs_binds lhs') (mkHsLet rhs_binds rhs') diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index a62e698..c4cca7e 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -89,7 +89,7 @@ module TcType ( isPrimitiveType, tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes, - tidyTyVar, tidyTyVars, + tidyTyVarBndr, tidyOpenTyVar, tidyOpenTyVars, typeKind, eqKind, eqUsage, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta @@ -115,7 +115,7 @@ import Type ( -- Re-exports isUnLiftedType, isUnboxedTupleType, isPrimitiveType, splitNewType_maybe, splitTyConApp_maybe, tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes, - tidyTyVar, tidyTyVars, eqKind, eqUsage, + tidyTyVarBndr, tidyOpenTyVar, tidyOpenTyVars, eqKind, eqUsage, hasMoreBoxityInfo, liftedBoxity, superBoxity, typeKind, superKind ) import TyCon ( TyCon, isUnLiftedTyCon ) @@ -130,13 +130,12 @@ import CmdLineOpts ( DynFlags, DynFlag( Opt_GlasgowExts ), dopt ) import Name ( Name, NamedThing(..), mkLocalName ) import OccName ( OccName, mkDictOcc ) import NameSet -import PrelNames -- Lots (e.g. in isFFIArgumentTy +import PrelNames -- Lots (e.g. in isFFIArgumentTy) import TysWiredIn ( ptrTyCon, funPtrTyCon, addrTyCon, unitTyCon ) import Unique ( Unique, Uniquable(..) ) import SrcLoc ( SrcLoc ) import Util ( cmpList, thenCmp ) import Maybes ( maybeToBool, expectJust ) -import BasicTypes ( Boxity(..) ) import Outputable \end{code} diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index d16aa04..5fcba6d 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -62,10 +62,11 @@ module Type ( usageAnnOfType, typeKind, addFreeTyVars, -- Tidying up for printing - tidyType, tidyTypes, - tidyOpenType, tidyOpenTypes, - tidyTyVar, tidyTyVars, tidyFreeTyVars, - tidyTopType, tidyPred, + tidyType, tidyTypes, + tidyOpenType, tidyOpenTypes, + tidyTyVarBndr, tidyFreeTyVars, + tidyOpenTyVar, tidyOpenTyVars, + tidyTopType, tidyPred, -- Comparison eqType, eqKind, eqUsage, @@ -756,36 +757,34 @@ an interface file. It doesn't change the uniques at all, just the print names. \begin{code} -tidyTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar) -tidyTyVar env@(tidy_env, subst) tyvar - = case lookupVarEnv subst tyvar of - - Just tyvar' -> -- Already substituted - (env, tyvar') - - Nothing -> -- Make a new nice name for it - - case tidyOccName tidy_env (getOccName name) of - (tidy', occ') -> -- New occname reqd - ((tidy', subst'), tyvar') - where - subst' = extendVarEnv subst tyvar tyvar' - tyvar' = setTyVarName tyvar name' - name' = mkLocalName (getUnique name) occ' noSrcLoc - -- Note: make a *user* tyvar, so it printes nicely - -- Could extract src loc, but no need. +tidyTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar) +tidyTyVarBndr (tidy_env, subst) tyvar + = case tidyOccName tidy_env (getOccName name) of + (tidy', occ') -> -- New occname reqd + ((tidy', subst'), tyvar') + where + subst' = extendVarEnv subst tyvar tyvar' + tyvar' = setTyVarName tyvar name' + name' = mkLocalName (getUnique name) occ' noSrcLoc + -- Note: make a *user* tyvar, so it printes nicely + -- Could extract src loc, but no need. where name = tyVarName tyvar -tidyTyVars :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar]) -tidyTyVars env tyvars = mapAccumL tidyTyVar env tyvars - tidyFreeTyVars :: TidyEnv -> TyVarSet -> TidyEnv -- Add the free tyvars to the env in tidy form, -- so that we can tidy the type they are free in -tidyFreeTyVars env tyvars = foldl add env (varSetElems tyvars) - where - add env tv = fst (tidyTyVar env tv) +tidyFreeTyVars env tyvars = fst (tidyOpenTyVars env (varSetElems tyvars)) + +tidyOpenTyVars :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar]) +tidyOpenTyVars env tyvars = mapAccumL tidyOpenTyVar env tyvars + +tidyOpenTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar) +-- Treat a new tyvar as a binder, and give it a fresh tidy name +tidyOpenTyVar env@(tidy_env, subst) tyvar + = case lookupVarEnv subst tyvar of + Just tyvar' -> (env, tyvar') -- Already substituted + Nothing -> tidyTyVarBndr env tyvar -- Treat it as a binder tidyType :: TidyEnv -> Type -> Type tidyType env@(tidy_env, subst) ty @@ -802,7 +801,7 @@ tidyType env@(tidy_env, subst) ty go (FunTy fun arg) = (FunTy SAPPLY (go fun)) SAPPLY (go arg) go (ForAllTy tv ty) = ForAllTy tvp SAPPLY (tidyType envp ty) where - (envp, tvp) = tidyTyVar env tv + (envp, tvp) = tidyTyVarBndr env tv go (UsageTy u ty) = (UsageTy SAPPLY (go u)) SAPPLY (go ty) go_note (SynNote ty) = SynNote SAPPLY (go ty) @@ -964,7 +963,7 @@ eq_ty env (TyVarTy tv1) (TyVarTy tv2) = case lookupVarEnv env tv1 of Just tv1a -> tv1a == tv2 Nothing -> tv1 == tv2 eq_ty env (ForAllTy tv1 t1) (ForAllTy tv2 t2) - | tv1 == tv2 = eq_ty env t1 t2 + | tv1 == tv2 = eq_ty (delVarEnv env tv1) t1 t2 | otherwise = eq_ty (extendVarEnv env tv1 tv2) t1 t2 eq_ty env (AppTy s1 t1) (AppTy s2 t2) = (eq_ty env s1 s2) && (eq_ty env t1 t2) eq_ty env (FunTy s1 t1) (FunTy s2 t2) = (eq_ty env s1 s2) && (eq_ty env t1 t2) diff --git a/ghc/compiler/utils/OrdList.lhs b/ghc/compiler/utils/OrdList.lhs index 3e68eb7..d093e43 100644 --- a/ghc/compiler/utils/OrdList.lhs +++ b/ghc/compiler/utils/OrdList.lhs @@ -11,7 +11,7 @@ can be appended in linear time. module OrdList ( OrdList, nilOL, isNilOL, unitOL, appOL, consOL, snocOL, concatOL, - fromOL, toOL, foldOL + fromOL, toOL, foldrOL, foldlOL ) where infixl 5 `appOL` @@ -48,11 +48,17 @@ appOL None bs = bs appOL as None = as appOL as bs = Two as bs -foldOL :: (a->b->b) -> b -> OrdList a -> b -foldOL k z None = z -foldOL k z (One x) = k x z -foldOL k z (Two b1 b2) = foldOL k (foldOL k z b2) b1 -foldOL k z (Many xs) = foldr k z xs +foldrOL :: (a->b->b) -> b -> OrdList a -> b +foldrOL k z None = z +foldrOL k z (One x) = k x z +foldrOL k z (Two b1 b2) = foldrOL k (foldrOL k z b2) b1 +foldrOL k z (Many xs) = foldr k z xs + +foldlOL :: (b->a->b) -> b -> OrdList a -> b +foldlOL k z None = z +foldlOL k z (One x) = k z x +foldlOL k z (Two b1 b2) = foldlOL k (foldlOL k z b1) b2 +foldlOL k z (Many xs) = foldl k z xs fromOL :: OrdList a -> [a] fromOL ol diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs index 7aa2461..ef8614e 100644 --- a/ghc/compiler/utils/Outputable.lhs +++ b/ghc/compiler/utils/Outputable.lhs @@ -58,7 +58,10 @@ import Panic import Word ( Word32 ) import IO ( Handle, hPutChar, hPutStr, stderr, stdout ) -import Char ( chr, ord, isDigit ) +import Char ( chr ) +#if __GLASGOW_HASKELL__ < 410 +import Char ( ord, isDigit ) +#endif \end{code} diff --git a/ghc/compiler/utils/UniqSet.lhs b/ghc/compiler/utils/UniqSet.lhs index 3123c7c..129e333 100644 --- a/ghc/compiler/utils/UniqSet.lhs +++ b/ghc/compiler/utils/UniqSet.lhs @@ -12,7 +12,7 @@ module UniqSet ( UniqSet, -- abstract type: NOT mkUniqSet, uniqSetToList, emptyUniqSet, unitUniqSet, - addOneToUniqSet, addListToUniqSet, delOneFromUniqSet, + addOneToUniqSet, addListToUniqSet, delOneFromUniqSet, delListFromUniqSet, unionUniqSets, unionManyUniqSets, minusUniqSet, elementOfUniqSet, mapUniqSet, intersectUniqSets, isEmptyUniqSet, filterUniqSet, sizeUniqSet, foldUniqSet, @@ -70,6 +70,9 @@ addOneToUniqSet (MkUniqSet set) x = MkUniqSet (addToUFM set x x) delOneFromUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a delOneFromUniqSet (MkUniqSet set) x = MkUniqSet (delFromUFM set x) +delListFromUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a +delListFromUniqSet (MkUniqSet set) xs = MkUniqSet (delListFromUFM set xs) + addListToUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a addListToUniqSet (MkUniqSet set) xs = MkUniqSet (addListToUFM set [(x,x) | x<-xs]) diff --git a/ghc/lib/std/PrelBase.lhs b/ghc/lib/std/PrelBase.lhs index 4230561..3407e1e 100644 --- a/ghc/lib/std/PrelBase.lhs +++ b/ghc/lib/std/PrelBase.lhs @@ -1,5 +1,5 @@ % ----------------------------------------------------------------------------- -% $Id: PrelBase.lhs,v 1.51 2001/08/17 17:18:54 apt Exp $ +% $Id: PrelBase.lhs,v 1.52 2001/09/26 15:12:37 simonpj Exp $ % % (c) The University of Glasgow, 1992-2000 % @@ -243,25 +243,26 @@ The rest of the prelude list functions are in PrelList. foldr :: (a -> b -> b) -> b -> [a] -> b -- foldr _ z [] = z -- foldr f z (x:xs) = f x (foldr f z xs) -{-# INLINE foldr #-} +{-# INLINE [0] foldr #-} +-- Inline only in the final stage, after the foldr/cons rule has had a chance foldr k z xs = go xs where go [] = z go (y:ys) = y `k` go ys build :: forall a. (forall b. (a -> b -> b) -> b -> b) -> [a] -{-# INLINE 2 build #-} +{-# INLINE [1] build #-} -- The INLINE is important, even though build is tiny, -- because it prevents [] getting inlined in the version that -- appears in the interface file. If [] *is* inlined, it -- won't match with [] appearing in rules in an importing module. -- - -- The "2" says to inline in phase 2 + -- The "1" says to inline in phase 1 build g = g (:) [] augment :: forall a. (forall b. (a->b->b) -> b -> b) -> [a] -> [a] -{-# INLINE 2 augment #-} +{-# INLINE [1] augment #-} augment g xs = g (:) xs {-# RULES @@ -295,6 +296,7 @@ augment g xs = g (:) xs \begin{code} map :: (a -> b) -> [a] -> [b] +{-# NOINLINE [1] map #-} map = mapList -- Note eta expanded @@ -318,6 +320,7 @@ mapList f (x:xs) = f x : mapList f xs ---------------------------------------------- \begin{code} (++) :: [a] -> [a] -> [a] +{-# NOINLINE [1] (++) #-} (++) = append {-# RULES @@ -450,6 +453,8 @@ String equality is used when desugaring pattern-matches against strings. \begin{code} eqString :: String -> String -> Bool eqString = (==) + +{-# RULES "eqString" (==) = eqString #-} \end{code} %********************************************************* @@ -687,6 +692,7 @@ unpacking the strings of error messages. \begin{code} unpackCString# :: Addr# -> [Char] +{-# NOINLINE [1] unpackCString# #-} unpackCString# a = unpackCStringList# a unpackCStringList# :: Addr# -> [Char] @@ -710,6 +716,9 @@ unpackAppendCString# addr rest ch = indexCharOffAddr# addr nh unpackFoldrCString# :: Addr# -> (Char -> a -> a) -> a -> a +{-# NOINLINE [0] unpackFoldrCString# #-} +-- Don't inline till right at the end; +-- usually the unpack-list rule turns it into unpackCStringList unpackFoldrCString# addr f z = unpack 0# where diff --git a/ghc/lib/std/PrelEnum.lhs b/ghc/lib/std/PrelEnum.lhs index 48abe32..5ede58a 100644 --- a/ghc/lib/std/PrelEnum.lhs +++ b/ghc/lib/std/PrelEnum.lhs @@ -1,5 +1,5 @@ % ----------------------------------------------------------------------------- -% $Id: PrelEnum.lhs,v 1.16 2001/08/29 09:34:05 simonmar Exp $ +% $Id: PrelEnum.lhs,v 1.17 2001/09/26 15:12:37 simonpj Exp $ % % (c) The University of Glasgow, 1992-2001 % @@ -204,11 +204,13 @@ instance Enum Char where {-# INLINE enumFromThenTo #-} enumFromThenTo (C# x1) (C# x2) (C# y) = efdtChar (ord# x1) (ord# x2) (ord# y) +{-# NOINLINE [1] eftChar #-} +{-# NOINLINE [1] efdChar #-} +{-# NOINLINE [1] efdtChar #-} eftChar = eftCharList efdChar = efdCharList efdtChar = efdtCharList - {-# RULES "eftChar" forall x y. eftChar x y = build (\c n -> eftCharFB c n x y) "efdChar" forall x1 x2. efdChar x1 x2 = build (\ c n -> efdCharFB c n x1 x2) @@ -221,7 +223,7 @@ efdtChar = efdtCharList -- We can do better than for Ints because we don't -- have hassles about arithmetic overflow at maxBound -{-# INLINE eftCharFB #-} +{-# INLINE [0] eftCharFB #-} eftCharFB c n x y = go x where go x | x ># y = n @@ -232,6 +234,7 @@ eftCharList x y | x ># y = [] -- For enumFromThenTo we give up on inlining +{-# NOINLINE [0] efdCharFB #-} efdCharFB c n x1 x2 | delta >=# 0# = go_up_char_fb c n x1 delta 0x10FFFF# | otherwise = go_dn_char_fb c n x1 delta 0# @@ -244,6 +247,7 @@ efdCharList x1 x2 where delta = x2 -# x1 +{-# NOINLINE [0] efdtCharFB #-} efdtCharFB c n x1 x2 lim | delta >=# 0# = go_up_char_fb c n x1 delta lim | otherwise = go_dn_char_fb c n x1 delta lim @@ -325,6 +329,9 @@ instance Enum Int where {-# INLINE enumFromThenTo #-} enumFromThenTo (I# x1) (I# x2) (I# y) = efdtInt x1 x2 y +{-# NOINLINE [1] eftInt #-} +{-# NOINLINE [1] efdInt #-} +{-# NOINLINE [1] efdtInt #-} eftInt = eftIntList efdInt = efdIntList efdtInt = efdtIntList @@ -340,7 +347,7 @@ efdtInt = efdtIntList #-} -{-# INLINE eftIntFB #-} +{-# INLINE [0] eftIntFB #-} eftIntFB c n x y | x ># y = n | otherwise = go x where @@ -358,6 +365,7 @@ eftIntList x y | x ># y = [] -- For enumFromThenTo we give up on inlining; so we don't worry -- about duplicating occurrences of "c" +{-# NOINLINE [0] efdtIntFB #-} efdtIntFB c n x1 x2 y | delta >=# 0# = if x1 ># y then n else go_up_int_fb c n x1 delta lim | otherwise = if x1 <# y then n else go_dn_int_fb c n x1 delta lim @@ -372,6 +380,7 @@ efdtIntList x1 x2 y delta = x2 -# x1 lim = y -# delta +{-# NOINLINE [0] efdIntFB #-} efdIntFB c n x1 x2 | delta >=# 0# = case maxInt of I# y -> go_up_int_fb c n x1 delta (y -# delta) | otherwise = case minInt of I# y -> go_dn_int_fb c n x1 delta (y -# delta) diff --git a/ghc/lib/std/PrelList.lhs b/ghc/lib/std/PrelList.lhs index 3a7ce28..c4b5336 100644 --- a/ghc/lib/std/PrelList.lhs +++ b/ghc/lib/std/PrelList.lhs @@ -1,5 +1,5 @@ % ------------------------------------------------------------------------------ -% $Id: PrelList.lhs,v 1.27 2001/08/28 15:12:37 simonmar Exp $ +% $Id: PrelList.lhs,v 1.28 2001/09/26 15:12:37 simonpj Exp $ % % (c) The University of Glasgow, 1994-2000 % @@ -118,9 +118,11 @@ length l = len l 0# -- filter, applied to a predicate and a list, returns the list of those -- elements that satisfy the predicate; i.e., -- filter p xs = [ x | x <- xs, p x] +{-# NOINLINE [1] filter #-} filter :: (a -> Bool) -> [a] -> [a] filter = filterList +{-# INLINE [0] filter #-} filterFB c p x r | p x = x `c` r | otherwise = r @@ -202,6 +204,7 @@ scanr1 f (x:xs) = f x q : qs -- iterate f x returns an infinite list of repeated applications of f to x: -- iterate f x == [x, f x, f (f x), ...] iterate :: (a -> a) -> a -> [a] +{-# NOINLINE [1] iterate #-} iterate = iterateList iterateFB c f x = x `c` iterateFB c f (f x) @@ -216,9 +219,12 @@ iterateList f x = x : iterateList f (f x) -- repeat x is an infinite list, with x the value of every element. repeat :: a -> [a] +{-# NOINLINE [1] repeat #-} repeat = repeatList +{-# INLINE [0] repeatFB #-} repeatFB c x = xs where xs = x `c` xs + repeatList x = xs where xs = x : xs {-# RULES @@ -514,8 +520,10 @@ tuples are in the List module. \begin{code} ---------------------------------------------- zip :: [a] -> [b] -> [(a,b)] +{-# NOINLINE [1] zip #-} zip = zipList +{-# INLINE [0] zipFB #-} zipFB c x y r = (x,y) `c` r @@ -548,9 +556,10 @@ zip3 _ _ _ = [] \begin{code} ---------------------------------------------- zipWith :: (a->b->c) -> [a]->[b]->[c] +{-# NOINLINE [1] zipWith #-} zipWith = zipWithList - +{-# INLINE [0] zipWithFB #-} zipWithFB c f x y r = (x `f` y) `c` r zipWithList :: (a->b->c) -> [a] -> [b] -> [c] diff --git a/ghc/lib/std/PrelST.lhs b/ghc/lib/std/PrelST.lhs index 9efa299..8cf8f37 100644 --- a/ghc/lib/std/PrelST.lhs +++ b/ghc/lib/std/PrelST.lhs @@ -1,5 +1,5 @@ % ------------------------------------------------------------------------------ -% $Id: PrelST.lhs,v 1.20 2001/02/22 16:48:24 qrczak Exp $ +% $Id: PrelST.lhs,v 1.21 2001/09/26 15:12:37 simonpj Exp $ % % (c) The University of Glasgow, 1992-2000 % @@ -111,9 +111,9 @@ runST :: (forall s. ST s a) -> a runST st = runSTRep (case st of { ST st_rep -> st_rep }) -- I'm only letting runSTRep be inlined right at the end, in particular *after* full laziness --- That's what the "INLINE 100" says. +-- That's what the "INLINE [0]" says. -- SLPJ Apr 99 -{-# INLINE 100 runSTRep #-} +{-# INLINE [0] runSTRep #-} runSTRep :: (forall s. STRep s a) -> a runSTRep st_rep = case st_rep realWorld# of (# _, r #) -> r -- 1.7.10.4