EP(..),
- StrictnessMark(..), isMarkedUnboxed, isMarkedStrict
+ StrictnessMark(..), isMarkedUnboxed, isMarkedStrict,
+
+ CompilerPhase, pprPhase,
+ Activation(..), isActive, isNeverActive, isAlwaysActive
) where
#include "HsVersions.h"
isFragileOcc :: OccInfo -> Bool
isFragileOcc (OneOcc _ _) = True
-isFragileOcc other = False
+isFragileOcc other = False
\end{code}
\begin{code}
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
zapDemandIdInfo id = maybeModifyIdInfo zapDemandInfo id
\end{code}
+
-- Inline prags
InlinePragInfo(..),
- inlinePragInfo, setInlinePragInfo, pprInlinePragInfo,
- isNeverInlinePrag, neverInlinePrag,
+ inlinePragInfo, setInlinePragInfo,
-- Occurrence info
OccInfo(..), isFragileOcc, isDeadOcc, isLoopBreaker,
import BasicTypes ( OccInfo(..), isFragileOcc, isDeadOcc, seqOccInfo, isLoopBreaker,
InsideLam, insideLam, notInsideLam,
OneBranch, oneBranch, notOneBranch,
- Arity
+ Arity,
+ Activation(..)
)
import DataCon ( DataCon )
import ForeignCall ( ForeignCall )
unfoldingInfo = noUnfolding,
cprInfo = NoCPRInfo,
lbvarInfo = NoLBVarInfo,
- inlinePragInfo = NoInlinePragInfo,
+ inlinePragInfo = AlwaysActive,
occInfo = NoOccInfo,
newDemandInfo = topDmd,
newStrictnessInfo = Nothing
%************************************************************************
\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}
`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
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
elemVarSet, varSetElems, subVarSet,
unionVarSet, unionVarSets,
intersectVarSet, intersectsVarSet,
- isEmptyVarSet, delVarSet, delVarSetByKey,
+ isEmptyVarSet, delVarSet, delVarSetList, delVarSetByKey,
minusVarSet, foldVarSet, filterVarSet,
lookupVarSet, mapVarSet, sizeVarSet, seqVarSet
) where
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
elemVarSet = elementOfUniqSet
minusVarSet = minusUniqSet
delVarSet = delOneFromUniqSet
+delVarSetList = delListFromUniqSet
isEmptyVarSet = isEmptyUniqSet
mkVarSet = mkUniqSet
foldVarSet = foldUniqSet
\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
\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 $
-- 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}
#include "HsVersions.h"
-import CoreUtils( exprIsAtom, exprType, exprIsValue, etaExpand )
+import CoreUtils( exprIsAtom, exprType, exprIsValue, etaExpand, exprOkForSpeculation )
import CoreFVs ( exprFreeVars )
import CoreLint ( endPass )
import CoreSyn
-- ---------------------------------------------------------------------------
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 []
= 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
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
-- 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
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)
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
isTyVar, isId,
bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts,
collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders,
- collectArgs, collectBindersIgnoringNotes,
+ collectArgs,
coreExprCc,
flattenBinds,
import Type ( Type, mkTyVarTy, seqType )
import Literal ( Literal, mkMachInt )
import DataCon ( DataCon, dataConId )
+import BasicTypes ( Activation )
import VarSet
import Outputable
\end{code}
data CoreRule
= Rule RuleName
+ Activation -- When the rule is active
[CoreBndr] -- Forall'd variables
[CoreExpr] -- LHS args
CoreExpr -- RHS
isBuiltinRule _ = False
ruleName :: CoreRule -> RuleName
-ruleName (Rule n _ _ _) = n
+ruleName (Rule n _ _ _ _) = n
ruleName (BuiltinRule n _) = n
\end{code}
\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)
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
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}
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 ),
)
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}
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)
}
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)
-- 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
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
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}
%************************************************************************
-> (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'))
-- 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
-- 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
certainlyWillInline,
okToUnfoldInHiFile,
- callSiteInline, blackListed
+ callSiteInline
) where
#include "HsVersions.h"
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
mkUnfolding top_lvl expr
= CoreUnfolding (occurAnalyseGlobalExpr expr)
top_lvl
+
(exprIsValue expr)
-- Already evaluated
| 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)
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#
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
\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
-> 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 ;
-- 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 ->
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
-- 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
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
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,
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<n *and* foo appears on LHS of rule
- INLINE foo phase is Just p *and* foo appears on LHS of rule
- NOINLINE n foo phase is Just p *and* (p<n *or* foo appears on LHS of rule)
- NOINLINE foo always
-(most black listing, least inlining)
-
-\begin{code}
-blackListed :: IdSet -- Used in transformation rules
- -> 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.
-
module CoreUtils (
-- Construction
mkNote, mkInlineMe, mkSCC, mkCoerce,
- bindNonRec, mkIfThenElse, mkAltExpr,
- mkPiType,
+ bindNonRec, needsCaseBinding,
+ mkIfThenElse, mkAltExpr, mkPiType,
-- Taking expressions apart
findDefault, findAlt, hasDefault,
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}
-- 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}
\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`
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
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
-- 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
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 ->
}}}
\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
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
import IdInfo ( IdInfo, megaSeqIdInfo,
arityInfo, ppArityInfo,
specInfo, cprInfo, ppCprInfo,
- strictnessInfo, ppStrictnessInfo, cgInfo,
+ strictnessInfo, ppStrictnessInfo,
cprInfo, ppCprInfo,
workerInfo, ppWorkerInfo,
tyGenInfo, ppTyGenInfo,
ppWorkerInfo (workerInfo info),
ppStrictnessInfo s,
ppr (newStrictnessInfo info),
--- pprCgInfo c,
ppCprInfo m,
pprCoreRules b p
-- Inline pragma, occ, demand, lbvar info
a = arityInfo info
g = tyGenInfo info
s = strictnessInfo info
--- c = cgInfo info
m = cprInfo info
p = specInfo info
\end{code}
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)),
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
\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)
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,
import PrelNames ( hasKey, ioTyConKey, deRefStablePtrName, newStablePtrName,
bindIOName, returnIOName
)
+import BasicTypes ( Activation( NeverActive ) )
import Outputable
-
import Maybe ( fromJust )
\end{code}
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
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 )
(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
| 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
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}
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}
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 "#-}"]
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
\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 _) =
-- 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 )
-- 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")
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:
\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
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
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
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
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
\begin{code}
module CmdLineOpts (
- CoreToDo(..),
- SimplifierSwitch(..), isAmongSimpl,
- StgToDo(..),
- SwitchResult(..),
+ CoreToDo(..), StgToDo(..),
+ SimplifierSwitch(..),
+ SimplifierMode(..),
HscLang(..),
DynFlag(..), -- needed non-abstractly by DriverFlags
v_Static_hsc_opts,
- intSwitchSet,
- switchIsOn,
isStaticHscFlag,
-- Manipulating DynFlags
#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}
%************************************************************************
%************************************************************************
\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
| 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}
\end{code}
\begin{code}
+data SimplifierMode -- See comments in SimplMonad
+ = SimplGently
+ | SimplPhase Int
+
data SimplifierSwitch
= MaxSimplifierIterations Int
- | SimplInlinePhase Int
- | DontApplyRules
| NoCaseOfCase
- | SimplLetToCase
\end{code}
%************************************************************************
"fno-prune-tydecls",
"static",
"funregisterised",
- "fext-core"
+ "fext-core",
+ "frule-check"
]
|| any (flip prefixMatch f) [
"fcontext-stack",
%************************************************************************
%* *
-\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
-----------------------------------------------------------------------------
--- $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
--
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
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.
-- ==> 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
-- 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
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 ]
#include "HsVersions.h"
#ifdef GHCI
+import Interpreter
import ByteCodeGen ( byteCodeGen )
import CoreTidy ( tidyCoreExpr )
import CorePrep ( corePrepExpr )
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 )
import Rename ( checkOldIface, renameModule, closeIfaceDecls )
import Rules ( emptyRuleBase )
import PrelInfo ( wiredInThingEnv, wiredInThings )
+import PrelRules ( builtinRules )
import PrelNames ( knownKeyNames )
import MkIface ( mkFinalIface )
import TcModule
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 )
import IOExts ( newIORef, readIORef, writeIORef, unsafePerformIO )
import Monad ( when )
-import Maybe ( isJust, fromJust, catMaybes )
+import Maybe ( isJust, fromJust )
import IO
import MkExternalCore ( emitExternalCore )
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
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 _)
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 )
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}
import Char ( isSpace, toUpper )
import List ( isSuffixOf )
-import IdInfo ( InlinePragInfo(..) )
import PrelNames ( mkTupNameStr )
import CmdLineOpts ( opt_HiVersion, opt_NoHiCheck )
import ForeignCall ( Safety(..) )
| ITarity
| ITspecialise
| ITnocaf
- | ITunfold InlinePragInfo
+ | ITunfold
| ITstrict StrictSig
| ITrules
| ITcprinfo
("__C", ITnocaf),
("__R", ITrules),
("__D", ITdeprecated),
- ("__U", ITunfold NoInlinePragInfo),
+ ("__U", ITunfold),
("__ccall", ITccall (False, False, PlayRisky)),
("__ccall_GC", ITccall (False, False, PlaySafe)),
{-
-----------------------------------------------------------------------------
-$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.
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
'__A' { ITarity }
'__P' { ITspecialise }
'__C' { ITnocaf }
- '__U' { ITunfold $$ }
+ '__U' { ITunfold }
'__S' { ITstrict $$ }
'__M' { ITcprinfo $$ }
-}
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) }
| {- 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 }
ext_name :: { Maybe CLabelString }
: STRING { Just $1 }
+ | STRING STRING { Just $2 } -- Ignore "module name" for now
| {- empty -} { Nothing }
\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
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 )
'__A' { ITarity }
'__P' { ITspecialise }
'__C' { ITnocaf }
- '__U' { ITunfold $$ }
+ '__U' { ITunfold }
'__S' { ITstrict $$ }
'__R' { ITrules }
'__M' { ITcprinfo }
| 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 }
| '__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 }
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}
import Util ( sortLt )
import List ( nub )
import UniqFM ( lookupWithDefaultUFM )
-import Maybes ( orElse )
import CmdLineOpts
import FastString ( FastString )
\end{code}
import Name ( NamedThing(..), mkSysLocalName, nameSrcLoc )
import NameSet
import UniqFM ( isNullUFM )
-import FiniteMap ( elemFM )
import UniqSet ( emptyUniqSet )
import List ( intersectBy )
import ListSetOps ( removeDups )
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))
= 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}
(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)
%*********************************************************
\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 $
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
import VarEnv
import TcType ( mkTyVarTy )
import qualified TcType ( match )
+import BasicTypes ( Activation, CompilerPhase, isActive )
import Outputable
import Maybe ( isJust, isNothing, fromMaybe )
%************************************************************************
\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
-- (\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
-- 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)
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
%************************************************************************
\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}
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
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
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)]
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"
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 )
import OccName ( mkSpecOcc )
import ErrUtils ( dumpIfSet_dyn )
import CmdLineOpts ( DynFlags, DynFlag(..) )
+import BasicTypes ( Activation(..) )
import Outputable
import Maybes ( orElse )
import List ( nubBy, partition )
import UniqSupply
import Outputable
-import UniqFM ( ufmToList )
\end{code}
-----------------------------------------------------
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}
#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
import VarEnv
import CoreSyn
import CoreUtils ( applyTypeToArgs )
-import CoreUnfold ( certainlyWillInline )
import CoreFVs ( exprFreeVars, exprsFreeVars )
import CoreLint ( showPass, endPass )
import PprCore ( pprCoreRules )
import FiniteMap
import Maybes ( catMaybes, maybeToBool )
import ErrUtils ( dumpIfSet_dyn )
+import BasicTypes ( Activation( AlwaysActive ) )
import Bag
import List ( partition )
import Util ( zipEqual, zipWithEqual, cmpList )
| 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
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
-- 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)
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}
%************************************************************************
| 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
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}
-- 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
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
-- 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
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
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}
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,
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
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}
import HscTypes ( lookupType, TyThing(..) )
import Util ( zipEqual )
import SrcLoc ( SrcLoc )
-import qualified PrelNames
import Outputable
import IOExts ( newIORef )
-- 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}
%************************************************************************
Fixity _ InfixN -> (False, False)
Fixity _ InfixR -> (False, True)
Fixity _ InfixL -> (True, False)
-
-isInfixOccName :: String -> Bool
-isInfixOccName str =
- case str of
- (':':_) -> True
- _ -> False
\end{code}
ToDo: Better SrcLocs.
\begin{code}
-compare_Case ::
- RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
- -> RdrNameHsExpr -> RdrNameHsExpr
- -> RdrNameHsExpr
compare_gen_Case ::
RdrName
-> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
-> 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
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)
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 )
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
= 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`
liftedTypeKind, unliftedTypeKind, openTypeKind, defaultKind, superKind,
superBoxity, liftedBoxity, hasMoreBoxityInfo, typeKind,
- tyVarsOfType, tyVarsOfTypes, tidyOpenType, tidyOpenTypes, tidyTyVar,
+ tyVarsOfType, tyVarsOfTypes, tidyOpenType, tidyOpenTypes, tidyOpenTyVar,
eqKind, isTypeKind,
isFFIArgumentTy, isFFIImportResultTy
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'
= (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}
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 )
import TysWiredIn ( mkListTy, mkTupleTy, genUnitTyCon )
import BasicTypes ( Boxity(..) )
import SrcLoc ( SrcLoc )
-import Util ( mapAccumL, isSingleton )
+import Util ( isSingleton )
import Outputable
\end{code}
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")
= 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
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),
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 ->
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')
isPrimitiveType,
tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
- tidyTyVar, tidyTyVars,
+ tidyTyVarBndr, tidyOpenTyVar, tidyOpenTyVars,
typeKind, eqKind, eqUsage,
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta
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 )
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}
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,
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
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)
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)
module OrdList (
OrdList,
nilOL, isNilOL, unitOL, appOL, consOL, snocOL, concatOL,
- fromOL, toOL, foldOL
+ fromOL, toOL, foldrOL, foldlOL
) where
infixl 5 `appOL`
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
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}
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,
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])
% -----------------------------------------------------------------------------
-% $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
%
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
\begin{code}
map :: (a -> b) -> [a] -> [b]
+{-# NOINLINE [1] map #-}
map = mapList
-- Note eta expanded
----------------------------------------------
\begin{code}
(++) :: [a] -> [a] -> [a]
+{-# NOINLINE [1] (++) #-}
(++) = append
{-# RULES
\begin{code}
eqString :: String -> String -> Bool
eqString = (==)
+
+{-# RULES "eqString" (==) = eqString #-}
\end{code}
%*********************************************************
\begin{code}
unpackCString# :: Addr# -> [Char]
+{-# NOINLINE [1] unpackCString# #-}
unpackCString# a = unpackCStringList# a
unpackCStringList# :: Addr# -> [Char]
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
% -----------------------------------------------------------------------------
-% $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
%
{-# 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)
-- 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
-- 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#
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
{-# 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
#-}
-{-# INLINE eftIntFB #-}
+{-# INLINE [0] eftIntFB #-}
eftIntFB c n x y | x ># y = n
| otherwise = go x
where
-- 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
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)
% ------------------------------------------------------------------------------
-% $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
%
-- 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
-- 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)
-- 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
\begin{code}
----------------------------------------------
zip :: [a] -> [b] -> [(a,b)]
+{-# NOINLINE [1] zip #-}
zip = zipList
+{-# INLINE [0] zipFB #-}
zipFB c x y r = (x,y) `c` r
\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]
% ------------------------------------------------------------------------------
-% $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
%
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
projects / ghc-hetmet.git / commitdiff