Commit 9d38678e authored by simonpj's avatar simonpj
Browse files

[project @ 1999-07-06 16:45:31 by simonpj]

All Simon's recent tuning changes.  Rough summary follows:

* Fix Kevin Atkinson's cant-find-instance bug.  Turns out that Rename.slurpSourceRefs
  needs to repeatedly call getImportedInstDecls, and then go back to slurping
  source-refs.  Comments with Rename.slurpSourceRefs.

* Add a case to Simplify.mkDupableAlt for the quite-common case where there's
  a very simple alternative, in which case there's no point in creating a
  join-point binding.

* Fix CoreUtils.exprOkForSpeculation so that it returns True of (==# a# b#).
  This lack meant that
	case ==# a# b# of { True -> x; False -> x }
  was not simplifying

* Make float-out dump bindings at the top of a function argument, as
  at the top of a let(rec) rhs.  See notes with FloatOut.floatRhs

* Make the ArgOf case of mkDupableAlt generate a OneShot lambda.
  This gave a noticeable boost to spectral/boyer2


* Reduce the number of coerces, using worker/wrapper stuff.
  The main idea is in WwLib.mkWWcoerce.  The gloss is that we must do
  the w/w split even for small non-recursive things.  See notes with
  WorkWrap.tryWw.

* This further complicated getWorkerId, so I finally bit the bullet and
  make the workerInfo field of the IdInfo work properly, including
  under substitutions.  Death to getWorkerId.  Kevin Glynn will be happy.

* Make all lambdas over realWorldStatePrimTy
  into one-shot lambdas.  This is a GROSS HACK.

* Also make the occurrence analyser aware of one-shot lambdas.

* Make various Prelude things into INLINE, so that foldr doesn't
  get inlined in their body, so that the caller gets the benefit
  of fusion.  Notably in PrelArr.lhs.
parent 47a40c89
......@@ -83,6 +83,7 @@ import Name ( Name, OccName,
import Const ( Con(..) )
import PrimRep ( PrimRep )
import PrimOp ( PrimOp )
import TysPrim ( realWorldStatePrimTy )
import FieldLabel ( FieldLabel(..) )
import SrcLoc ( SrcLoc )
import Unique ( Unique, mkBuiltinUnique, getBuiltinUniques )
......@@ -371,7 +372,21 @@ idMustBeINLINEd id = case getInlinePragma id of
isOneShotLambda :: Id -> Bool
isOneShotLambda id = case lbvarInfo (idInfo id) of
IsOneShotLambda -> True
NoLBVarInfo -> False
NoLBVarInfo -> idType id == realWorldStatePrimTy
-- The last clause is a gross hack. It claims that
-- every function over realWorldStatePrimTy is a one-shot
-- function. This is pretty true in practice, and makes a big
-- difference. For example, consider
-- a `thenST` \ r -> ...E...
-- The early full laziness pass, if it doesn't know that r is one-shot
-- will pull out E (let's say it doesn't mention r) to give
-- let lvl = E in a `thenST` \ r -> ...lvl...
-- When `thenST` gets inlined, we end up with
-- let lvl = E in \s -> case a s of (r, s') -> ...lvl...
-- and we don't re-inline E.
--
-- It would be better to spot that r was one-shot to start with, but
-- I don't want to rely on that.
setOneShotLambda :: Id -> Id
setOneShotLambda id = modifyIdInfo (`setLBVarInfo` IsOneShotLambda) id
......
......@@ -19,7 +19,7 @@ module IdInfo (
-- Arity
ArityInfo(..),
exactArity, atLeastArity, unknownArity,
exactArity, atLeastArity, unknownArity, hasArity,
arityInfo, setArityInfo, ppArityInfo, arityLowerBound,
-- Strictness
......@@ -31,7 +31,7 @@ module IdInfo (
-- Worker
WorkerInfo, workerExists,
workerInfo, setWorkerInfo,
workerInfo, setWorkerInfo, ppWorkerInfo,
-- Unfolding
unfoldingInfo, setUnfoldingInfo,
......@@ -267,6 +267,9 @@ arityLowerBound UnknownArity = 0
arityLowerBound (ArityAtLeast n) = n
arityLowerBound (ArityExactly n) = n
hasArity :: ArityInfo -> Bool
hasArity UnknownArity = False
hasArity other = True
ppArityInfo UnknownArity = empty
ppArityInfo (ArityExactly arity) = hsep [ptext SLIT("__A"), int arity]
......@@ -409,10 +412,10 @@ type WorkerInfo = Maybe Id
{- UNUSED:
mkWorkerInfo :: Id -> WorkerInfo
mkWorkerInfo wk_id = Just wk_id
-}
ppWorkerInfo Nothing = empty
ppWorkerInfo (Just wk_id) = ppr wk_id
-}
ppWorkerInfo (Just wk_id) = ptext SLIT("__P") <+> ppr wk_id
noWorkerInfo = Nothing
......@@ -497,6 +500,7 @@ substitution to be correct. (They get pinned back on separately.)
\begin{code}
zapFragileIdInfo :: IdInfo -> Maybe IdInfo
zapFragileIdInfo info@(IdInfo {inlinePragInfo = inline_prag,
workerInfo = wrkr,
specInfo = rules,
unfoldingInfo = unfolding})
| not is_fragile_inline_prag
......@@ -508,6 +512,8 @@ zapFragileIdInfo info@(IdInfo {inlinePragInfo = inline_prag,
-- Specialisations would need substituting. They get pinned
-- back on separately.
&& not (workerExists wrkr)
&& not (hasUnfolding unfolding)
-- This is very important; occasionally a let-bound binder is used
-- as a binder in some lambda, in which case its unfolding is utterly
......@@ -518,6 +524,7 @@ zapFragileIdInfo info@(IdInfo {inlinePragInfo = inline_prag,
| otherwise
= Just (info {inlinePragInfo = safe_inline_prag,
workerInfo = noWorkerInfo,
specInfo = emptyCoreRules,
unfoldingInfo = noUnfolding})
......
......@@ -10,7 +10,7 @@ module CoreSyn (
TaggedExpr, TaggedAlt, TaggedBind, TaggedArg,
mkLets, mkLams,
mkApps, mkTyApps, mkValApps,
mkApps, mkTyApps, mkValApps, mkVarApps,
mkLit, mkStringLit, mkConApp, mkPrimApp, mkNote,
bindNonRec, mkIfThenElse, varToCoreExpr,
......@@ -171,10 +171,12 @@ type TaggedAlt t = Alt (Tagged t)
mkApps :: Expr b -> [Arg b] -> Expr b
mkTyApps :: Expr b -> [Type] -> Expr b
mkValApps :: Expr b -> [Expr b] -> Expr b
mkVarApps :: CoreExpr -> [IdOrTyVar] -> CoreExpr
mkApps f args = foldl App f args
mkTyApps f args = foldl (\ e a -> App e (Type a)) f args
mkValApps f args = foldl (\ e a -> App e a) f args
mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
mkLit :: Literal -> Expr b
mkStringLit :: String -> Expr b
......
......@@ -27,7 +27,8 @@ import Id ( idType, idInfo, idName,
)
import IdInfo ( specInfo, setSpecInfo,
inlinePragInfo, setInlinePragInfo, InlinePragInfo(..),
setUnfoldingInfo, setDemandInfo
setUnfoldingInfo, setDemandInfo,
workerInfo, setWorkerInfo
)
import Demand ( wwLazy )
import Name ( getOccName, tidyTopName, mkLocalName, isLocallyDefined )
......@@ -101,7 +102,7 @@ tidyBind :: Maybe Module -- (Just m) for top level, Nothing for nested
-> (TidyEnv, CoreBind)
tidyBind maybe_mod env (NonRec bndr rhs)
= let
(env', bndr') = tidy_bndr maybe_mod env bndr
(env', bndr') = tidy_bndr maybe_mod env env bndr
rhs' = tidyExpr env rhs
in
(env', NonRec bndr' rhs')
......@@ -116,7 +117,7 @@ tidyBind maybe_mod env (Rec pairs)
-- So I left it out for now
(bndrs, rhss) = unzip pairs
(env', bndrs') = mapAccumL (tidy_bndr maybe_mod) env bndrs
(env', bndrs') = mapAccumL (tidy_bndr maybe_mod env') env bndrs
rhss' = map (tidyExpr env') rhss
in
(env', Rec (zip bndrs' rhss'))
......@@ -154,8 +155,8 @@ tidyVarOcc (_, var_env) v = case lookupVarEnv var_env v of
\end{code}
\begin{code}
tidy_bndr (Just mod) env id = tidyTopId mod env id
tidy_bndr Nothing env var = tidyBndr env var
tidy_bndr (Just mod) env_idinfo env var = tidyTopId mod env env_idinfo var
tidy_bndr Nothing env_idinfo env var = tidyBndr env var
\end{code}
......@@ -198,14 +199,18 @@ tidyId env@(tidy_env, var_env) id
in
((tidy_env', var_env'), id')
tidyTopId :: Module -> TidyEnv -> Id -> (TidyEnv, Id)
tidyTopId mod env@(tidy_env, var_env) id
tidyTopId :: Module -> TidyEnv -> TidyEnv -> Id -> (TidyEnv, Id)
-- The second env is the one to use for the IdInfo
-- It's necessary because when we are dealing with a recursive
-- group, a variable late in the group might be mentioned
-- in the IdInfo of one early in the group
tidyTopId mod env@(tidy_env, var_env) env_idinfo id
= -- Top level variables
let
(tidy_env', name') | isUserExportedId id = (tidy_env, idName id)
| otherwise = tidyTopName mod tidy_env (idName id)
ty' = tidyTopType (idType id)
idinfo' = tidyIdInfo env (idInfo id)
idinfo' = tidyIdInfo env_idinfo (idInfo id)
id' = mkId name' ty' idinfo'
var_env' = extendVarEnv var_env id id'
in
......@@ -220,7 +225,7 @@ tidyTopId mod env@(tidy_env, var_env) id
-- The latter two are to avoid space leaks
tidyIdInfo env info
= info4
= info5
where
rules = specInfo info
......@@ -234,6 +239,10 @@ tidyIdInfo env info
info3 = info2 `setUnfoldingInfo` noUnfolding
info4 = info3 `setDemandInfo` wwLazy -- I don't understand why...
info5 = case workerInfo info of
Nothing -> info4
Just w -> info4 `setWorkerInfo` Just (tidyVarOcc env w)
tidyProtoRules :: TidyEnv -> [ProtoCoreRule] -> [ProtoCoreRule]
tidyProtoRules env rules
= [ ProtoCoreRule is_local (tidyVarOcc env fn) (tidyRule env rule)
......
......@@ -20,7 +20,7 @@ module CoreUnfold (
mkOtherCon, otherCons,
unfoldingTemplate, maybeUnfoldingTemplate,
isEvaldUnfolding, isCheapUnfolding,
hasUnfolding,
hasUnfolding, hasSomeUnfolding,
couldBeSmallEnoughToInline,
certainlySmallEnoughToInline,
......@@ -471,12 +471,12 @@ so we can inline if it occurs once, or is small
callSiteInline :: Bool -- True <=> the Id is black listed
-> Bool -- 'inline' note at call site
-> Id -- The Id
-> [CoreExpr] -- Arguments
-> [Bool] -- One for each value arg; True if it is interesting
-> Bool -- True <=> continuation is interesting
-> Maybe CoreExpr -- Unfolding, if any
callSiteInline black_listed inline_call id args interesting_cont
callSiteInline black_listed inline_call id arg_infos interesting_cont
= case getIdUnfolding id of {
NoUnfolding -> Nothing ;
OtherCon _ -> Nothing ;
......@@ -487,8 +487,7 @@ callSiteInline black_listed inline_call id args interesting_cont
| otherwise = Nothing
inline_prag = getInlinePragma id
arg_infos = map interestingArg val_args
val_args = filter isValArg args
n_val_args = length arg_infos
yes_or_no =
case inline_prag of
......@@ -511,7 +510,7 @@ callSiteInline black_listed inline_call id args interesting_cont
text "callSiteInline:oneOcc" <+> ppr id )
-- If it has one occurrence, not inside a lambda, PreInlineUnconditionally
-- should have zapped it already
is_cheap && (not (null args) || interesting_cont)
is_cheap && (not (null arg_infos) || interesting_cont)
| otherwise -- Occurs (textually) more than once, so look at its size
= case guidance of
......@@ -539,11 +538,10 @@ callSiteInline black_listed inline_call id args interesting_cont
InsideLam -> is_cheap && small_enough
where
n_args = length arg_infos
enough_args = n_args >= n_vals_wanted
really_interesting_cont | n_args < n_vals_wanted = False -- Too few args
| n_args == n_vals_wanted = interesting_cont
| otherwise = True -- Extra args
enough_args = n_val_args >= n_vals_wanted
really_interesting_cont | n_val_args < n_vals_wanted = False -- Too few args
| n_val_args == n_vals_wanted = interesting_cont
| otherwise = True -- Extra args
-- This rather elaborate defn for really_interesting_cont is important
-- Consider an I# = INLINE (\x -> I# {x})
-- The unfolding guidance deems it to have size 2, and no arguments.
......@@ -575,17 +573,6 @@ callSiteInline black_listed inline_call id args interesting_cont
result
}
-- An argument is interesting if it has *some* structure
-- We are here trying to avoid unfolding a function that
-- is applied only to variables that have no unfolding
-- (i.e. they are probably lambda bound): f x y z
-- There is little point in inlining f here.
interestingArg (Type _) = False
interestingArg (App fn (Type _)) = interestingArg fn
interestingArg (Var v) = hasSomeUnfolding (getIdUnfolding v)
interestingArg other = True
computeDiscount :: Int -> [Int] -> Int -> [Bool] -> Bool -> Int
computeDiscount n_vals_wanted arg_discounts res_discount arg_infos result_used
-- We multiple the raw discounts (args_discount and result_discount)
......
......@@ -7,9 +7,10 @@
module CoreUtils (
coreExprType, coreAltsType,
exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap, exprIsValue,
exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap,
exprIsValue,
exprOkForSpeculation, exprIsBig, hashExpr,
exprArity,
exprArity, exprGenerousArity,
cheapEqExpr, eqExpr, applyTypeToArgs
) where
......@@ -192,13 +193,6 @@ exprIsCheap (Var _) = True
exprIsCheap (Con con args) = conIsCheap con && all exprIsCheap args
exprIsCheap (Note _ e) = exprIsCheap e
exprIsCheap (Lam x e) = if isId x then True else exprIsCheap e
-- I'm not at all convinced about these two!!
-- [SLPJ June 99]
-- exprIsCheap (Let bind body) = all exprIsCheap (rhssOfBind bind) && exprIsCheap body
-- exprIsCheap (Case scrut _ alts) = exprIsCheap scrut &&
-- all (\(_,_,rhs) -> exprIsCheap rhs) alts
exprIsCheap other_expr -- look for manifest partial application
= case collectArgs other_expr of
(f, args) -> isPap f (valArgCount args) && all exprIsCheap args
......@@ -224,9 +218,20 @@ isPap (Var f) n_val_args
isPap fun n_val_args = False
\end{code}
exprOkForSpeculation returns True of an UNLIFTED-TYPE expression that it is safe
to evaluate even if normal order eval might not evaluate the expression
at all. E.G.
exprOkForSpeculation returns True of an expression that it is
* safe to evaluate even if normal order eval might not
evaluate the expression at all, or
* safe *not* to evaluate even if normal order would do so
It returns True iff
the expression guarantees to terminate,
soon,
without raising an exceptoin
E.G.
let x = case y# +# 1# of { r# -> I# r# }
in E
==>
......@@ -240,26 +245,17 @@ side effects, and can't diverge or raise an exception.
\begin{code}
exprOkForSpeculation :: CoreExpr -> Bool
exprOkForSpeculation (Var v) = True -- Unlifted type => already evaluated
exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
exprOkForSpeculation (Let (NonRec b r) e) = isUnLiftedType (idType b) &&
exprOkForSpeculation r &&
exprOkForSpeculation e
exprOkForSpeculation (Let (Rec _) _) = False
exprOkForSpeculation (Case _ _ _) = False -- Conservative
exprOkForSpeculation (App _ _) = False
exprOkForSpeculation (Con con args)
= conOkForSpeculation con &&
and (zipWith ok (filter isValArg args) (fst (conStrictness con)))
where
ok arg demand | isLazy demand = True
| isPrim demand = exprOkForSpeculation arg
| otherwise = False
| otherwise = exprOkForSpeculation arg
exprOkForSpeculation other = panic "exprOkForSpeculation"
-- Lam, Type
exprOkForSpeculation other = False -- Conservative
\end{code}
......@@ -304,9 +300,63 @@ exprIsValue e@(App _ _) = case collectArgs e of
\begin{code}
exprArity :: CoreExpr -> Int -- How many value lambdas are at the top
exprArity (Lam b e) | isTyVar b = exprArity e
| otherwise = 1 + exprArity e
exprArity other = 0
exprArity (Lam b e) | isTyVar b = exprArity e
| otherwise = 1 + exprArity e
exprArity (Note note e) | ok_note note = exprArity e
exprArity other = 0
\end{code}
\begin{code}
exprGenerousArity :: CoreExpr -> Int -- The number of args the thing can be applied to
-- without doing much work
-- This is used when eta expanding
-- e ==> \xy -> e x y
--
-- It returns 1 (or more) to:
-- 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
-- Hence "generous" arity
exprGenerousArity (Var v) = arityLowerBound (getIdArity v)
exprGenerousArity (Note note e)
| ok_note note = exprGenerousArity e
exprGenerousArity (Lam x e)
| isId x = 1 + exprGenerousArity e
| otherwise = exprGenerousArity e
exprGenerousArity (Let bind body)
| all exprIsCheap (rhssOfBind bind) = exprGenerousArity body
exprGenerousArity (Case scrut _ alts)
| exprIsCheap scrut = min_zero [exprGenerousArity rhs | (_,_,rhs) <- alts]
exprGenerousArity other = 0 -- Could do better for applications
min_zero :: [Int] -> Int -- Find the minimum, but zero is the smallest
min_zero (x:xs) = go x xs
where
go 0 xs = 0 -- Nothing beats zero
go min [] = min
go min (x:xs) | x < min = go x xs
| otherwise = go min xs
ok_note (SCC _) = False -- (Over?) conservative
ok_note (TermUsg _) = False -- Doesn't matter much
ok_note (Coerce _ _) = True
-- We *do* look through coerces when getting arities.
-- Reason: arities are to do with *representation* and
-- work duplication.
ok_note InlineCall = True
ok_note InlineMe = False
-- This one is a bit more 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}
......
......@@ -24,7 +24,8 @@ import IdInfo ( IdInfo,
arityInfo, ppArityInfo, ppFlavourInfo, flavourInfo,
demandInfo, updateInfo, ppUpdateInfo, specInfo,
strictnessInfo, ppStrictnessInfo, cafInfo, ppCafInfo,
cprInfo, ppCprInfo, lbvarInfo
cprInfo, ppCprInfo, lbvarInfo,
workerInfo, ppWorkerInfo
)
import Const ( Con(..), DataCon )
import DataCon ( isTupleCon, isUnboxedTupleCon )
......@@ -344,6 +345,7 @@ ppIdInfo info
ppFlavourInfo (flavourInfo info),
ppArityInfo a,
ppUpdateInfo u,
ppWorkerInfo (workerInfo info),
ppStrictnessInfo s,
ppr d,
ppCafInfo c,
......
......@@ -26,12 +26,11 @@ module Subst (
substTy, substTheta,
-- Expression stuff
substExpr, substRules
substExpr, substIdInfo
) where
#include "HsVersions.h"
import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr, CoreBndr,
CoreRules(..), CoreRule(..), emptyCoreRules, isEmptyCoreRules
)
......@@ -43,7 +42,10 @@ import VarSet
import VarEnv
import Var ( setVarUnique, isId )
import Id ( idType, setIdType )
import IdInfo ( zapFragileIdInfo )
import IdInfo ( IdInfo, zapFragileIdInfo,
specInfo, setSpecInfo,
workerExists, workerInfo, setWorkerInfo, WorkerInfo
)
import UniqSupply ( UniqSupply, uniqFromSupply, splitUniqSupply )
import Var ( Var, IdOrTyVar, Id, TyVar, isTyVar, maybeModifyIdInfo )
import Outputable
......@@ -400,11 +402,36 @@ substAndCloneId subst@(Subst in_scope env) us old_id
%************************************************************************
%* *
\section{Rule substitution}
\section{IdInfo substitution}
%* *
%************************************************************************
\begin{code}
substIdInfo :: Subst -> IdInfo -> IdInfo
substIdInfo subst info
= info2
where
info1 | isEmptyCoreRules old_rules = info
| otherwise = info `setSpecInfo` substRules subst old_rules
info2 | not (workerExists old_wrkr) = info1
| otherwise = info1 `setWorkerInfo` substWorker subst old_wrkr
old_rules = specInfo info
old_wrkr = workerInfo info
substWorker :: Subst -> WorkerInfo -> WorkerInfo
substWorker subst Nothing
= Nothing
substWorker subst (Just w)
= case lookupSubst subst w of
Nothing -> Just w
Just (DoneEx (Var w1)) -> Just w1
Just (DoneEx other) -> WARN( True, text "substWorker: DoneEx" <+> ppr w )
Nothing -- Worker has got substituted away altogether
Just (ContEx se1 e) -> WARN( True, text "substWorker: ContEx" <+> ppr w )
Nothing -- Ditto
substRules :: Subst -> CoreRules -> CoreRules
substRules subst (Rules rules rhs_fvs)
= Rules (map do_subst rules)
......
......@@ -19,7 +19,6 @@ import RnMonad
import RnEnv ( availName )
import TcInstUtil ( InstInfo(..) )
import WorkWrap ( getWorkerId )
import CmdLineOpts
import Id ( Id, idType, idInfo, omitIfaceSigForId, isUserExportedId,
......@@ -30,10 +29,10 @@ import VarSet
import DataCon ( StrictnessMark(..), dataConSig, dataConFieldLabels, dataConStrictMarks )
import IdInfo ( IdInfo, StrictnessInfo, ArityInfo, InlinePragInfo(..), inlinePragInfo,
arityInfo, ppArityInfo,
strictnessInfo, ppStrictnessInfo,
strictnessInfo, ppStrictnessInfo, isBottomingStrictness,
cafInfo, ppCafInfo, specInfo,
cprInfo, ppCprInfo,
workerExists, workerInfo, isBottomingStrictness
workerExists, workerInfo, ppWorkerInfo
)
import CoreSyn ( CoreExpr, CoreBind, Bind(..), rulesRules, rulesRhsFreeVars )
import CoreFVs ( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars )
......@@ -304,7 +303,8 @@ ifaceId get_idinfo needed_ids is_rec id rhs
arity_pretty,
caf_pretty,
cpr_pretty,
strict_pretty,
strict_pretty,
wrkr_pretty,
unfold_pretty,
ptext SLIT("##-}")]
......@@ -317,21 +317,17 @@ ifaceId get_idinfo needed_ids is_rec id rhs
------------ CPR Info --------------
cpr_pretty = ppCprInfo (cprInfo idinfo)
------------ Strictness and Worker --------------
------------ Strictness --------------
strict_info = strictnessInfo idinfo
work_info = workerInfo idinfo
has_worker = workerExists work_info
bottoming_fn = isBottomingStrictness strict_info
strict_pretty = ppStrictnessInfo strict_info <+> wrkr_pretty
strict_pretty = ppStrictnessInfo strict_info
wrkr_pretty | not has_worker = empty
| otherwise = ppr work_id
------------ Worker --------------
work_info = workerInfo idinfo
has_worker = workerExists work_info
wrkr_pretty = ppWorkerInfo work_info
Just work_id = work_info
-- (Just work_id) = work_info
-- Temporary fix. We can't use the worker id saved by the w/w
-- pass because later optimisations may have changed it. So try
-- to snaffle from the wrapper code again ...
work_id = getWorkerId id rhs
------------ Unfolding --------------
inline_pragma = inlinePragInfo idinfo
......
......@@ -576,31 +576,15 @@ akind :: { Kind }
id_info :: { [HsIdInfo RdrName] }
: { [] }
| id_info_item id_info { $1 : $2 }
| strict_info id_info { $1 ++ $2 }
id_info_item :: { HsIdInfo RdrName }
: '__A' arity_info { HsArity $2 }
: '__A' INTEGER { HsArity (exactArity (fromInteger $2)) }
| '__U' core_expr { HsUnfold $1 (Just $2) }
| '__U' { HsUnfold $1 Nothing }
| '__M' { HsCprInfo $1 }
| '__S' { HsStrictness (HsStrictnessInfo $1) }
| '__C' { HsNoCafRefs }
strict_info :: { [HsIdInfo RdrName] }
: cpr worker { ($1:$2) }
| strict worker { ($1:$2) }
| cpr strict worker { ($1:$2:$3) }
cpr :: { HsIdInfo RdrName }
: '__M' { HsCprInfo $1 }
strict :: { HsIdInfo RdrName }
: '__S' { HsStrictness (HsStrictnessInfo $1) }
worker :: { [HsIdInfo RdrName] }
: qvar_name { [HsWorker $1] }
| {- nothing -} { [] }
arity_info :: { ArityInfo }
: INTEGER { exactArity (fromInteger $1) }
| '__P' qvar_name { HsWorker $2 }
-------------------------------------------------------
core_expr :: { UfExpr RdrName }
......
......@@ -240,47 +240,69 @@ slurpImpDecls source_fvs
-- The current slurped-set records all local things
getSlurped `thenRn` \ source_binders ->
slurpSourceRefs source_binders source_fvs `thenRn` \ (decls1, needed1, inst_gates) ->
-- Now we can get the instance decls
slurpInstDecls decls1 needed1 inst_gates `thenRn` \ (decls2, needed2) ->
slurpSourceRefs source_binders source_fvs `thenRn` \ (decls, needed) ->
-- And finally get everything else
closeDecls decls2 needed2
closeDecls decls needed
-------------------------------------------------------
slurpSourceRefs :: NameSet -- Variables defined in source
-> FreeVars -- Variables referenced in source
-> RnMG ([RenamedHsDecl],
FreeVars, -- Un-satisfied needs
FreeVars) -- "Gates"
FreeVars) -- Un-satisfied needs
-- The declaration (and hence home module) of each gate has
-- already been loaded
slurpSourceRefs source_binders source_fvs
= go [] -- Accumulating decls
emptyFVs -- Unsatisfied needs
source_fvs -- Accumulating gates
(nameSetToList source_fvs) -- Gates whose defn hasn't been loaded yet
= go_outer [] -- Accumulating decls
emptyFVs -- Unsatisfied needs
emptyFVs -- Accumulating gates
(nameSetToList source_fvs) -- Things whose defn hasn't been loaded yet
where
go decls fvs gates []
-- The outer loop repeatedly slurps the decls for the current gates
-- and the instance decls
-- The outer loop is needed because consider
-- instance Foo a => Baz (Maybe a) where ...
-- It may be that @Baz@ and @Maybe@ are used in the source module,
-- but not @Foo@; so we need to chase @Foo@ too.
--
-- We also need to follow superclass refs. In particular, 'chasing @Foo@' must
-- include actually getting in Foo's class decl
-- class Wib a => Foo a where ..
-- so that its superclasses are discovered. The point is that Wib is a gate too.
-- We do this for tycons too, so that we look through type synonyms.
go_outer decls fvs all_gates []
= returnRn (decls, fvs)