From 9d38678ea60ff32f756390a30c659daa22c98c93 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Tue, 6 Jul 1999 16:46:12 +0000
Subject: [PATCH] [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.
---
ghc/compiler/basicTypes/Id.lhs | 17 ++-
ghc/compiler/basicTypes/IdInfo.lhs | 15 ++-
ghc/compiler/coreSyn/CoreSyn.lhs | 4 +-
ghc/compiler/coreSyn/CoreTidy.lhs | 27 +++--
ghc/compiler/coreSyn/CoreUnfold.lhs | 31 ++---
ghc/compiler/coreSyn/CoreUtils.lhs | 104 ++++++++++++-----
ghc/compiler/coreSyn/PprCore.lhs | 4 +-
ghc/compiler/coreSyn/Subst.lhs | 35 +++++-
ghc/compiler/main/MkIface.lhs | 26 ++---
ghc/compiler/rename/ParseIface.y | 24 +---
ghc/compiler/rename/Rename.lhs | 102 +++++++++--------
ghc/compiler/rename/RnIfaces.lhs | 14 ++-
ghc/compiler/simplCore/FloatOut.lhs | 52 +++++----
ghc/compiler/simplCore/OccurAnal.lhs | 18 +--
ghc/compiler/simplCore/SetLevels.lhs | 12 +-
ghc/compiler/simplCore/SimplUtils.lhs | 23 ++--
ghc/compiler/simplCore/Simplify.lhs | 90 ++++++++++-----
ghc/compiler/specialise/Rules.lhs | 14 ++-
ghc/compiler/stranal/WorkWrap.lhs | 52 +++++++--
ghc/compiler/stranal/WwLib.lhs | 159 +++++++++++++++++---------
ghc/compiler/typecheck/TcGenDeriv.lhs | 8 +-
ghc/compiler/typecheck/TcIfaceSig.lhs | 9 +-
ghc/compiler/types/Type.lhs | 36 ++++--
ghc/driver/ghc.lprl | 5 +
ghc/lib/concurrent/Channel.lhs | 8 +-
ghc/lib/exts/GetOpt.lhs | 2 +-
ghc/lib/exts/MutableArray.lhs | 2 +-
ghc/lib/posix/Posix.lhs | 2 +-
ghc/lib/posix/PosixIO.lhs | 4 +-
ghc/lib/posix/PosixProcEnv.lhs | 6 +-
ghc/lib/posix/PosixProcPrim.lhs | 2 +-
ghc/lib/std/Ix.lhs | 12 +-
ghc/lib/std/List.lhs | 8 +-
ghc/lib/std/Monad.lhs | 4 +
ghc/lib/std/PrelArr.lhs | 31 ++---
ghc/lib/std/PrelBase.lhs | 10 +-
ghc/lib/std/PrelEnum.lhs | 10 +-
ghc/lib/std/PrelHandle.lhs | 4 -
ghc/lib/std/PrelList.lhs | 20 ++--
ghc/lib/std/PrelNum.lhs | 24 ++--
ghc/lib/std/PrelShow.lhs | 8 +-
ghc/lib/std/Random.lhs | 4 +-
42 files changed, 646 insertions(+), 396 deletions(-)
diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs
index 3ba8763b5e2a..1c8e02619761 100644
--- a/ghc/compiler/basicTypes/Id.lhs
+++ b/ghc/compiler/basicTypes/Id.lhs
@@ -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
diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs
index d5e2ccc4e89b..2c36363b4e0d 100644
--- a/ghc/compiler/basicTypes/IdInfo.lhs
+++ b/ghc/compiler/basicTypes/IdInfo.lhs
@@ -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})
diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs
index 285ecc2724a3..e59fec1b7c53 100644
--- a/ghc/compiler/coreSyn/CoreSyn.lhs
+++ b/ghc/compiler/coreSyn/CoreSyn.lhs
@@ -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
diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs
index bec784c7fcde..27843e820bad 100644
--- a/ghc/compiler/coreSyn/CoreTidy.lhs
+++ b/ghc/compiler/coreSyn/CoreTidy.lhs
@@ -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)
diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs
index 6fd0fd9b4db1..f27289ec0e92 100644
--- a/ghc/compiler/coreSyn/CoreUnfold.lhs
+++ b/ghc/compiler/coreSyn/CoreUnfold.lhs
@@ -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)
diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs
index bc6b37611be5..9b9b03c85ee7 100644
--- a/ghc/compiler/coreSyn/CoreUtils.lhs
+++ b/ghc/compiler/coreSyn/CoreUtils.lhs
@@ -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}
diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs
index 3f3b5a073c26..e4f2d7bb6088 100644
--- a/ghc/compiler/coreSyn/PprCore.lhs
+++ b/ghc/compiler/coreSyn/PprCore.lhs
@@ -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,
diff --git a/ghc/compiler/coreSyn/Subst.lhs b/ghc/compiler/coreSyn/Subst.lhs
index b3f93eac2118..64d4d502f683 100644
--- a/ghc/compiler/coreSyn/Subst.lhs
+++ b/ghc/compiler/coreSyn/Subst.lhs
@@ -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)
diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs
index 0766eeaa2049..2fec609e8568 100644
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -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
diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y
index 5d58b407a6e1..6df655d7abd0 100644
--- a/ghc/compiler/rename/ParseIface.y
+++ b/ghc/compiler/rename/ParseIface.y
@@ -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 }
diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs
index ca22b19a0ef5..baf7b300dde4 100644
--- a/ghc/compiler/rename/Rename.lhs
+++ b/ghc/compiler/rename/Rename.lhs
@@ -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)
+
+ go_outer decls fvs all_gates refs -- refs are not necessarily slurped yet
+ = traceRn (text "go_outer" <+> ppr refs) `thenRn_`
+ go_inner decls fvs emptyFVs refs `thenRn` \ (decls1, fvs1, gates1) ->
+ getImportedInstDecls (all_gates `plusFV` gates1) `thenRn` \ inst_decls ->
+ rnInstDecls decls1 fvs1 gates1 inst_decls `thenRn` \ (decls2, fvs2, gates2) ->
+ go_outer decls2 fvs2 (all_gates `plusFV` gates2)
+ (nameSetToList (gates2 `minusNameSet` all_gates))
+ -- Knock out the all_gates because even ifwe don't slurp any new
+ -- decls we can get some apparently-new gates from wired-in names
+
+ go_inner decls fvs gates []
= returnRn (decls, fvs, gates)
- go decls fvs gates (wanted_name:refs)
+ go_inner decls fvs gates (wanted_name:refs)
| isWiredInName wanted_name
= load_home wanted_name `thenRn_`
- go decls fvs (gates `plusFV` getWiredInGates wanted_name) refs
+ go_inner decls fvs (gates `plusFV` getWiredInGates wanted_name) refs
| otherwise
= importDecl wanted_name `thenRn` \ maybe_decl ->
case maybe_decl of
- -- No declaration... (already slurped, or local)
- Nothing -> go decls fvs gates refs
+ Nothing -> go_inner decls fvs gates refs -- No declaration... (already slurped, or local)
Just decl -> rnIfaceDecl decl `thenRn` \ (new_decl, fvs1) ->
- go (new_decl : decls)
- (fvs1 `plusFV` fvs)
- (gates `plusFV` getGates source_fvs new_decl)
- refs
+ go_inner (new_decl : decls)
+ (fvs1 `plusFV` fvs)
+ (gates `plusFV` getGates source_fvs new_decl)
+ refs
-- When we find a wired-in name we must load its
-- home module so that we find any instance decls therein
@@ -297,39 +319,19 @@ slurpSourceRefs source_binders source_fvs
returnRn ()
where
doc = ptext SLIT("need home module for wired in thing") <+> ppr name
-\end{code}
-%
-@slurpInstDecls@ imports appropriate instance decls.
-It has to incorporate a loop, because consider
-\begin{verbatim}
- instance Foo a => Baz (Maybe a) where ...
-\end{verbatim}
-It may be that @Baz@ and @Maybe@ are used in the source module,
-but not @Foo@; so we need to chase @Foo@ too.
-\begin{code}
-slurpInstDecls decls needed gates
- = go decls needed gates gates
- where
- go decls needed all_gates new_gates
- | isEmptyFVs new_gates
- = returnRn (decls, needed)
-
- | otherwise
- = getImportedInstDecls all_gates `thenRn` \ inst_decls ->
- rnInstDecls decls needed emptyFVs inst_decls `thenRn` \ (decls1, needed1, new_gates) ->
- go decls1 needed1 (all_gates `plusFV` new_gates) new_gates
+rnInstDecls decls fvs gates []
+ = returnRn (decls, fvs, gates)
+rnInstDecls decls fvs gates (d:ds)
+ = rnIfaceDecl d `thenRn` \ (new_decl, fvs1) ->
+ rnInstDecls (new_decl:decls)
+ (fvs1 `plusFV` fvs)
+ (gates `plusFV` getInstDeclGates new_decl)
+ ds
+\end{code}
- rnInstDecls decls fvs gates []
- = returnRn (decls, fvs, gates)
- rnInstDecls decls fvs gates (d:ds)
- = rnIfaceDecl d `thenRn` \ (new_decl, fvs1) ->
- rnInstDecls (new_decl:decls)
- (fvs1 `plusFV` fvs)
- (gates `plusFV` getInstDeclGates new_decl)
- ds
-
+\begin{code}
-------------------------------------------------------
-- closeDecls keeps going until the free-var set is empty
closeDecls decls needed
diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs
index f7276b8ba745..c5018a4c8177 100644
--- a/ghc/compiler/rename/RnIfaces.lhs
+++ b/ghc/compiler/rename/RnIfaces.lhs
@@ -537,10 +537,7 @@ getInterfaceExports mod_name from
\begin{code}
getImportedInstDecls :: NameSet -> RnMG [(Module,RdrNameHsDecl)]
getImportedInstDecls gates
- = -- First, ensure that the home module of each gate is loaded
- mapRn_ load_home gate_list `thenRn_`
-
- -- Next, load any orphan-instance modules that aren't aready loaded
+ = -- First, load any orphan-instance modules that aren't aready loaded
-- Orphan-instance modules are recorded in the module dependecnies
getIfacesRn `thenRn` \ ifaces ->
let
@@ -560,8 +557,8 @@ getImportedInstDecls gates
traceRn (sep [text "getImportedInstDecls:",
nest 4 (fsep (map ppr gate_list)),
- text "Slurped" <+> int (length decls)
- <+> text "instance declarations"]) `thenRn_`
+ text "Slurped" <+> int (length decls) <+> text "instance declarations",
+ nest 4 (vcat (map ppr_brief_inst_decl decls))]) `thenRn_`
returnRn decls
where
gate_list = nameSetToList gates
@@ -572,6 +569,11 @@ getImportedInstDecls gates
= loadHomeInterface (ppr gate <+> text "is an instance gate") gate `thenRn_`
returnRn ()
+ppr_brief_inst_decl (mod, InstD (InstDecl inst_ty _ _ _ _))
+ = case inst_ty of
+ HsForAllTy _ _ tau -> ppr tau
+ other -> ppr inst_ty
+
getImportedRules :: RnMG [(Module,RdrNameHsDecl)]
getImportedRules
= getIfacesRn `thenRn` \ ifaces ->
diff --git a/ghc/compiler/simplCore/FloatOut.lhs b/ghc/compiler/simplCore/FloatOut.lhs
index e4e47f757e83..d41f3d91e9eb 100644
--- a/ghc/compiler/simplCore/FloatOut.lhs
+++ b/ghc/compiler/simplCore/FloatOut.lhs
@@ -128,15 +128,11 @@ floatBind :: IdEnv Level
-> (FloatStats, FloatBinds, CoreBind, IdEnv Level)
floatBind env lvl (NonRec (name,level) rhs)
- = case (floatExpr env level rhs) of { (fs, rhs_floats, rhs') ->
-
- -- A good dumping point
- case (partitionByMajorLevel level rhs_floats) of { (rhs_floats', heres) ->
-
- (fs, rhs_floats',
- NonRec name (install heres rhs'),
+ = case (floatRhs env level rhs) of { (fs, rhs_floats, rhs') ->
+ (fs, rhs_floats,
+ NonRec name rhs',
extendVarEnv env name level)
- }}
+ }
floatBind env lvl bind@(Rec pairs)
= case (unzip3 (map do_pair pairs)) of { (fss, rhss_floats, new_pairs) ->
@@ -172,13 +168,9 @@ floatBind env lvl bind@(Rec pairs)
bind_level = getBindLevel bind
do_pair ((name, level), rhs)
- = case (floatExpr new_env level rhs) of { (fs, rhs_floats, rhs') ->
-
- -- A good dumping point
- case (partitionByMajorLevel level rhs_floats) of { (rhs_floats', heres) ->
-
- (fs, rhs_floats', (name, install heres rhs'))
- }}
+ = case (floatRhs new_env level rhs) of { (fs, rhs_floats, rhs') ->
+ (fs, rhs_floats, (name, rhs'))
+ }
\end{code}
%************************************************************************
@@ -188,20 +180,32 @@ floatBind env lvl bind@(Rec pairs)
%************************************************************************
\begin{code}
-floatExpr :: IdEnv Level
- -> Level
- -> LevelledExpr
- -> (FloatStats, FloatBinds, CoreExpr)
+floatExpr, floatRhs
+ :: IdEnv Level
+ -> Level
+ -> LevelledExpr
+ -> (FloatStats, FloatBinds, CoreExpr)
+
+floatRhs env lvl arg
+ = case (floatExpr env lvl arg) of { (fsa, floats, arg') ->
+ case (partitionByMajorLevel lvl floats) of { (floats', heres) ->
+ -- Dump bindings that aren't going to escape from a lambda
+ -- This is to avoid floating the x binding out of
+ -- f (let x = e in b)
+ -- unnecessarily. It even causes a bug to do so if we have
+ -- y = writeArr# a n (let x = e in b)
+ -- because the y binding is an expr-ok-for-speculation one.
+ (fsa, floats', install heres arg') }}
floatExpr env _ (Var v) = (zeroStats, [], Var v)
floatExpr env _ (Type ty) = (zeroStats, [], Type ty)
floatExpr env lvl (Con con as)
- = case floatList (floatExpr env lvl) as of { (stats, floats, as') ->
+ = case floatList (floatRhs env lvl) as of { (stats, floats, as') ->
(stats, floats, Con con as') }
floatExpr env lvl (App e a)
= case (floatExpr env lvl e) of { (fse, floats_e, e') ->
- case (floatExpr env lvl a) of { (fsa, floats_a, a') ->
+ case (floatRhs env lvl a) of { (fsa, floats_a, a') ->
(fse `add_stats` fsa, floats_e ++ floats_a, App e' a') }}
floatExpr env lvl (Lam (tv,incd_lvl) e)
@@ -355,8 +359,10 @@ partitionByMajorLevel, partitionByLevel
partitionByMajorLevel ctxt_lvl defns
= partition float_further defns
where
- float_further (my_lvl, _) = my_lvl `ltMajLvl` ctxt_lvl ||
- isTopLvl my_lvl
+ float_further (my_lvl, _) = my_lvl `lt_major` ctxt_lvl
+
+my_lvl `lt_major` ctxt_lvl = my_lvl `ltMajLvl` ctxt_lvl ||
+ isTopLvl my_lvl
partitionByLevel ctxt_lvl defns
= partition float_further defns
diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs
index 87927ece4821..e137536997bf 100644
--- a/ghc/compiler/simplCore/OccurAnal.lhs
+++ b/ghc/compiler/simplCore/OccurAnal.lhs
@@ -25,7 +25,7 @@ import CoreSyn
import CoreFVs ( idRuleVars )
import CoreUtils ( exprIsTrivial )
import Const ( Con(..), Literal(..) )
-import Id ( isSpecPragmaId,
+import Id ( isSpecPragmaId, isOneShotLambda,
getInlinePragma, setInlinePragma,
isExportedId, modifyIdInfo, idInfo,
getIdSpecialisation,
@@ -635,7 +635,7 @@ occAnal env expr@(Lam _ _)
mkLams tagged_binders body') }
where
(binders, body) = collectBinders expr
- (linear, env_body) = getCtxt env (count isId binders)
+ (linear, env_body) = oneShotGroup env (filter isId binders)
occAnal env (Case scrut bndr alts)
= case mapAndUnzip (occAnalAlt alt_env) alts of { (alts_usage_s, alts') ->
@@ -764,11 +764,15 @@ addNewCand (OccEnv ifun cands ctxt) id
setCtxt :: OccEnv -> CtxtTy -> OccEnv
setCtxt (OccEnv ifun cands _) ctxt = OccEnv ifun cands ctxt
-getCtxt :: OccEnv -> Int -> (Bool, OccEnv) -- True <=> this is a linear lambda
- -- The Int is the number of lambdas
-getCtxt env@(OccEnv ifun cands []) n = (False, env)
-getCtxt (OccEnv ifun cands ctxt) n = (and (take n ctxt), OccEnv ifun cands (drop n ctxt))
- -- Only return True if *all* the lambdas are linear
+oneShotGroup :: OccEnv -> [Id] -> (Bool, OccEnv) -- True <=> this is a one-shot linear lambda group
+ -- The [Id] are the binders
+oneShotGroup (OccEnv ifun cands ctxt) bndrs
+ = (go bndrs ctxt, OccEnv ifun cands (drop (length bndrs) ctxt))
+ where
+ -- Only return True if *all* the lambdas are linear
+ go (bndr:bndrs) (lin:ctxt) = (lin || isOneShotLambda bndr) && go bndrs ctxt
+ go [] ctxt = True
+ go bndrs [] = all isOneShotLambda bndrs
zapCtxt env@(OccEnv ifun cands []) = env
zapCtxt (OccEnv ifun cands _ ) = OccEnv ifun cands []
diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs
index 2937890e93ba..e74525d0349b 100644
--- a/ghc/compiler/simplCore/SetLevels.lhs
+++ b/ghc/compiler/simplCore/SetLevels.lhs
@@ -663,7 +663,7 @@ cloneVar NotTopLevel (lvl_env, subst_env) v lvl
let
subst = mkSubst emptyVarSet subst_env
v' = setVarUnique v uniq
- v'' = apply_to_rules subst v'
+ v'' = modifyIdInfo (substIdInfo subst) v'
subst_env' = extendSubstEnv subst_env v (DoneEx (Var v''))
lvl_env' = extendVarEnv lvl_env v lvl
in
@@ -672,20 +672,14 @@ cloneVar NotTopLevel (lvl_env, subst_env) v lvl
cloneVars :: TopLevelFlag -> LevelEnv -> [Id] -> Level -> LvlM (LevelEnv, [Id])
cloneVars TopLevel env vs lvl
= returnUs (env, vs) -- Don't clone top level things
-cloneVars NotTopLevel (lvl_env, subst_env) vs lvl
+cloneVars NotTopLevel (lvl_env, subst_env) vs lvl
= getUniquesUs (length vs) `thenLvl` \ uniqs ->
let
subst = mkSubst emptyVarSet subst_env'
vs' = zipWith setVarUnique vs uniqs
- vs'' = map (apply_to_rules subst) vs'
+ vs'' = map (modifyIdInfo (substIdInfo subst)) vs'
subst_env' = extendSubstEnvList subst_env vs [DoneEx (Var v'') | v'' <- vs'']
lvl_env' = extendVarEnvList lvl_env (vs `zip` repeat lvl)
in
returnUs ((lvl_env', subst_env'), vs'')
-
--- Apply the substitution to the rules
-apply_to_rules subst id
- = modifyIdInfo go_spec id
- where
- go_spec info = info `setSpecInfo` substRules subst (specInfo info)
\end{code}
diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs
index 4ef7937e36b6..7ce7e2770f18 100644
--- a/ghc/compiler/simplCore/SimplUtils.lhs
+++ b/ghc/compiler/simplCore/SimplUtils.lhs
@@ -18,7 +18,7 @@ import BinderInfo
import CmdLineOpts ( opt_SimplDoLambdaEtaExpansion, opt_SimplCaseMerge )
import CoreSyn
import CoreFVs ( exprFreeVars )
-import CoreUtils ( exprIsTrivial, cheapEqExpr, coreExprType, exprIsCheap )
+import CoreUtils ( exprIsTrivial, cheapEqExpr, coreExprType, exprIsCheap, exprGenerousArity )
import Subst ( substBndrs, substBndr, substIds )
import Id ( Id, idType, getIdArity, isId, idName,
getInlinePragma, setInlinePragma,
@@ -287,7 +287,7 @@ where (in both cases) N is a NORMAL FORM (i.e. no redexes anywhere)
wanting a suitable number of extra args.
NB: the Ei may have unlifted type, but the simplifier (which is applied
-to the result) deals OK with this).
+to the result) deals OK with this.
There is no point in looking for a combination of the two,
because that would leave use with some lets sandwiched between lambdas;
@@ -314,9 +314,7 @@ tryEtaExpansion rhs
(x_bndrs, body) = collectValBinders rhs
(fun, args) = collectArgs body
trivial_args = map exprIsTrivial args
- fun_arity = case fun of
- Var v -> arityLowerBound (getIdArity v)
- other -> 0
+ fun_arity = exprGenerousArity fun
bind_z_arg (arg, trivial_arg)
| trivial_arg = returnSmpl (Nothing, arg)
@@ -335,7 +333,7 @@ tryEtaExpansion rhs
y_tys = take no_extras_wanted potential_extra_arg_tys
no_extras_wanted :: Int
- no_extras_wanted =
+ no_extras_wanted = 0 `max`
-- We used to expand the arity to the previous arity fo the
-- function; but this is pretty dangerous. Consdier
@@ -349,8 +347,9 @@ tryEtaExpansion rhs
-- (bndr_arity - no_of_xs) `max`
-- See if the body could obviously do with more args
- (fun_arity - valArgCount args) `max`
+ (fun_arity - valArgCount args)
+-- This case is now deal with by exprGenerousArity
-- Finally, see if it's a state transformer, and xs is non-null
-- (so it's also a function not a thunk) in which
-- case we eta-expand on principle! This can waste work,
@@ -360,11 +359,11 @@ tryEtaExpansion rhs
-- \ x -> let {..} in \ s -> f (...) s
-- AND f RETURNED A FUNCTION. That is, 's' wasn't the only
-- potential extra arg.
- case (x_bndrs, potential_extra_arg_tys) of
- (_:_, ty:_) -> case splitTyConApp_maybe ty of
- Just (tycon,_) | tycon == statePrimTyCon -> 1
- other -> 0
- other -> 0
+-- case (x_bndrs, potential_extra_arg_tys) of
+-- (_:_, ty:_) -> case splitTyConApp_maybe ty of
+-- Just (tycon,_) | tycon == statePrimTyCon -> 1
+-- other -> 0
+-- other -> 0
\end{code}
diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index 6c365b73485b..bb7fc9e919b2 100644
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -24,14 +24,14 @@ import Id ( Id, idType, idInfo, idUnique,
getIdUnfolding, setIdUnfolding, isExportedId,
getIdSpecialisation, setIdSpecialisation,
getIdDemandInfo, setIdDemandInfo,
- getIdArity, setIdArity,
+ getIdArity, setIdArity, setIdInfo,
getIdStrictness,
setInlinePragma, getInlinePragma, idMustBeINLINEd,
setOneShotLambda
)
import IdInfo ( InlinePragInfo(..), OccInfo(..), StrictnessInfo(..),
ArityInfo(..), atLeastArity, arityLowerBound, unknownArity,
- specInfo, inlinePragInfo, zapLamIdInfo
+ specInfo, inlinePragInfo, zapLamIdInfo, setArityInfo, setInlinePragInfo, setUnfoldingInfo
)
import Demand ( Demand, isStrict, wwLazy )
import Const ( isWHNFCon, conOkForAlt )
@@ -43,7 +43,7 @@ import Name ( isLocallyDefined )
import CoreSyn
import CoreFVs ( exprFreeVars )
import CoreUnfold ( Unfolding, mkOtherCon, mkUnfolding, otherCons,
- callSiteInline, blackListed
+ callSiteInline, blackListed, hasSomeUnfolding
)
import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsCheap, exprIsTrivial,
coreExprType, coreAltsType, exprArity, exprIsValue,
@@ -56,7 +56,7 @@ import Type ( Type, mkTyVarTy, mkTyVarTys, isUnLiftedType,
funResultTy, isDictTy, isDataType, applyTy, applyTys, mkFunTys
)
import Subst ( Subst, mkSubst, emptySubst, substExpr, substTy,
- substEnv, lookupInScope, lookupSubst, substRules
+ substEnv, lookupInScope, lookupSubst, substIdInfo
)
import TyCon ( isDataTyCon, tyConDataCons, tyConClass_maybe, tyConArity, isDataTyCon )
import TysPrim ( realWorldStatePrimTy )
@@ -531,25 +531,23 @@ completeBinding old_bndr new_bndr new_rhs thing_inside
| otherwise
= getSubst `thenSmpl` \ subst ->
let
- bndr_info = idInfo old_bndr
- old_rules = specInfo bndr_info
- new_rules = substRules subst old_rules
-
- -- The new binding site Id needs its specialisations re-attached
- bndr_w_arity = new_bndr `setIdArity` ArityAtLeast (exprArity new_rhs)
-
- binding_site_id
- | isEmptyCoreRules old_rules = bndr_w_arity
- | otherwise = bndr_w_arity `setIdSpecialisation` new_rules
-
+ -- We make new IdInfo for the new binder by starting from the old binder,
+ -- doing appropriate substitutions,
+ old_bndr_info = idInfo old_bndr
+ new_bndr_info = substIdInfo subst old_bndr_info
+ `setArityInfo` ArityAtLeast (exprArity new_rhs)
+
+ -- At the *binding* site we want to zap the now-out-of-date inline
+ -- pragma, in case the expression is simplified a second time.
+ -- This has already been done in new_bndr, so we get it from there
+ binding_site_id = new_bndr `setIdInfo`
+ (new_bndr_info `setInlinePragInfo` getInlinePragma new_bndr)
+
-- At the occurrence sites we want to know the unfolding,
- -- and the occurrence info of the original
- -- (simplBinder cleaned up the inline prag of the original
- -- to eliminate un-stable info, in case this expression is
- -- simplified a second time; hence the need to reattach it)
- occ_site_id = binding_site_id
- `setIdUnfolding` mkUnfolding new_rhs
- `setInlinePragma` inlinePragInfo bndr_info
+ -- We want the occurrence info of the *original*, which is already
+ -- in new_bndr_info
+ occ_site_id = new_bndr `setIdInfo`
+ (new_bndr_info `setUnfoldingInfo` mkUnfolding new_rhs)
in
modifyInScope occ_site_id thing_inside `thenSmpl` \ stuff ->
returnSmpl (addBind (NonRec binding_site_id new_rhs) stuff)
@@ -741,6 +739,8 @@ completeCall black_list_fn in_scope var cont
(args', result_cont) = contArgs in_scope cont
+ val_args = filter isValArg args'
+ arg_infos = map (interestingArg in_scope) val_args
inline_call = contIsInline result_cont
interesting_cont = contIsInteresting result_cont
discard_inline_cont | inline_call = discardInline cont
@@ -748,7 +748,7 @@ completeCall black_list_fn in_scope var cont
---------- Unfolding stuff
maybe_inline = callSiteInline black_listed inline_call
- var args' interesting_cont
+ var arg_infos interesting_cont
Just unf_template = maybe_inline
black_listed = black_list_fn var
@@ -757,6 +757,22 @@ completeCall black_list_fn in_scope var cont
Just (rule_name, rule_rhs, rule_args) = maybe_rule_match
+
+-- 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 in_scope (Type _) = False
+interestingArg in_scope (App fn (Type _)) = interestingArg in_scope fn
+interestingArg in_scope (Var v) = hasSomeUnfolding (getIdUnfolding v')
+ where
+ v' = case lookupVarSet in_scope v of
+ Just v' -> v'
+ other -> v
+interestingArg in_scope other = True
+
+
-- First a special case
-- Don't actually inline the scrutinee when we see
-- case x of y { .... }
@@ -976,8 +992,15 @@ rebuild scrut (Select _ bndr alts se cont)
all (cheapEqExpr rhs1) other_rhss && all binders_unused alts
-- Check that the scrutinee can be let-bound instead of case-bound
- && ( (isUnLiftedType (idType bndr) && -- It's unlifted and floatable
- exprOkForSpeculation scrut) -- NB: scrut = an unboxed variable satisfies
+ && ( exprOkForSpeculation scrut
+ -- OK not to evaluate it
+ -- This includes things like (==# a# b#)::Bool
+ -- so that we simplify
+ -- case ==# a# b# of { True -> x; False -> x }
+ -- to just
+ -- x
+ -- This particular example shows up in default methods for
+ -- comparision operations (e.g. in (>=) for Int.Int32)
|| exprIsValue scrut -- It's already evaluated
|| var_demanded_later scrut -- It'll be demanded later
@@ -1349,7 +1372,7 @@ mkDupableCont join_arg_ty (ArgOf _ cont_ty cont_fn) thing_inside
newId join_arg_ty' ( \ arg_id ->
getSwitchChecker `thenSmpl` \ chkr ->
cont_fn (Var arg_id) `thenSmpl` \ (binds, (_, rhs)) ->
- returnSmpl (Lam arg_id (mkLets binds rhs))
+ returnSmpl (Lam (setOneShotLambda arg_id) (mkLets binds rhs))
) `thenSmpl` \ join_rhs ->
-- Build the join Id and continuation
@@ -1397,7 +1420,22 @@ mkDupableCont ty (Select _ case_bndr alts se cont) thing_inside
mkDupableAlt :: InId -> OutId -> SimplCont -> InAlt -> SimplM (OutStuff InAlt)
+mkDupableAlt case_bndr case_bndr' (Stop _) alt@(con, bndrs, rhs)
+ | exprIsDupable rhs
+ = -- It is worth checking for a small RHS because otherwise we
+ -- get extra let bindings that may cause an extra iteration of the simplifier to
+ -- inline back in place. Quite often the rhs is just a variable or constructor.
+ -- The Ord instance of Maybe in PrelMaybe.lhs, for example, took several extra
+ -- iterations because the version with the let bindings looked big, and so wasn't
+ -- inlined, but after the join points had been inlined it looked smaller, and so
+ -- was inlined.
+ --
+ -- But since the continuation is absorbed into the rhs, we only do this
+ -- for a Stop continuation.
+ returnSmpl ([], alt)
+
mkDupableAlt case_bndr case_bndr' cont alt@(con, bndrs, rhs)
+ | otherwise
= -- Not worth checking whether the rhs is small; the
-- inliner will inline it if so.
simplBinders bndrs $ \ bndrs' ->
diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs
index 99da2e2d705b..8406b0a49876 100644
--- a/ghc/compiler/specialise/Rules.lhs
+++ b/ghc/compiler/specialise/Rules.lhs
@@ -159,7 +159,17 @@ matchRule in_scope (Rule rn tpl_vars tpl_args rhs) args
-- One tiresome way to terminate: check for excess unmatched
-- template arguments
- go tpl_args [] subst
+ go tpl_args [] subst = Nothing -- Failure
+
+
+{- The code below tries to match even if there are more
+ template args than real args.
+
+ I now think this is probably a bad idea.
+ Should the template (map f xs) match (map g)? I think not.
+ For a start, in general eta expansion wastes work.
+ SLPJ July 99
+
= case eta_complete tpl_args (mkVarSet leftovers) of
Just leftovers' -> Just (rn, mkLams done (mkLams leftovers' rhs),
mk_result_args subst done)
@@ -188,6 +198,7 @@ matchRule in_scope (Rule rn tpl_vars tpl_args rhs) args
Nothing -> Nothing
eta_complete other vars = Nothing
+-}
-----------------------
mk_result_args subst vs = map go vs
@@ -198,6 +209,7 @@ matchRule in_scope (Rule rn tpl_vars tpl_args rhs) args
Just (DoneTy ty) -> Type ty
-- Substitution should bind them all!
+
zapOccInfo bndr | isTyVar bndr = bndr
| otherwise = maybeModifyIdInfo zapLamIdInfo bndr
\end{code}
diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs
index 472cfd9f0165..7a95e55cded6 100644
--- a/ghc/compiler/stranal/WorkWrap.lhs
+++ b/ghc/compiler/stranal/WorkWrap.lhs
@@ -4,7 +4,7 @@
\section[WorkWrap]{Worker/wrapper-generating back-end of strictness analyser}
\begin{code}
-module WorkWrap ( wwTopBinds, getWorkerId ) where
+module WorkWrap ( wwTopBinds ) where
#include "HsVersions.h"
@@ -22,7 +22,7 @@ import Id ( Id, getIdStrictness, setIdArity,
setIdStrictness,
setIdWorkerInfo, getIdCprInfo )
import VarSet
-import Type ( splitAlgTyConApp_maybe )
+import Type ( isNewType )
import IdInfo ( mkStrictnessInfo, noStrictnessInfo, StrictnessInfo(..),
CprInfo(..), exactArity
)
@@ -205,20 +205,40 @@ tryWW :: Bool -- True <=> a non-recursive binding
-- if two, then a worker and a
-- wrapper.
tryWW non_rec fn_id rhs
- | (non_rec && -- Don't split if its non-recursive and small
- certainlySmallEnoughToInline unfold_guidance
+ | (non_rec && -- Don't split if its non-recursive and small
+ certainlySmallEnoughToInline (calcUnfoldingGuidance opt_UF_CreationThreshold rhs) &&
+ -- No point in worker/wrappering something that is going to be
+ -- INLINEd wholesale anyway. If the strictness analyser is run
+ -- twice, this test also prevents wrappers (which are INLINEd)
+ -- from being re-done.
+
+ not (null wrap_args && do_coerce_ww)
+ -- However, if we have f = coerce T E
+ -- then we want to w/w anyway, to get
+ -- fw = E
+ -- f = coerce T fw
+ -- We want to do this even if the binding is small and non-rec.
+ -- Reason: I've seen this situation:
+ -- let f = coerce T (\s -> E)
+ -- in \x -> case x of
+ -- p -> coerce T' f
+ -- q -> \s -> E2
+ -- If only we w/w'd f, we'd inline the coerce (because it's trivial)
+ -- to get
+ -- let fw = \s -> E
+ -- in \x -> case x of
+ -- p -> fw
+ -- q -> \s -> E2
+ -- Now we'll see that fw has arity 1, and will arity expand
+ -- the \x to get what we want.
)
- -- No point in worker/wrappering something that is going to be
- -- INLINEd wholesale anyway. If the strictness analyser is run
- -- twice, this test also prevents wrappers (which are INLINEd)
- -- from being re-done.
- || not (do_strict_ww || do_cpr_ww)
+ || not (do_strict_ww || do_cpr_ww || do_coerce_ww)
= returnUs [ (fn_id, rhs) ]
| otherwise -- Do w/w split
= mkWwBodies tyvars wrap_args
- (coreExprType body)
+ body_ty
wrap_demands
cpr_info
`thenUs` \ (wrap_fn, work_fn, work_demands) ->
@@ -245,7 +265,7 @@ tryWW non_rec fn_id rhs
where
(tyvars, wrap_args, body) = collectTyAndValBinders rhs
n_wrap_args = length wrap_args
-
+ body_ty = coreExprType body
strictness_info = getIdStrictness fn_id
has_strictness_info = case strictness_info of
StrictnessInfo _ _ -> True
@@ -264,13 +284,20 @@ tryWW non_rec fn_id rhs
do_strict_ww = has_strictness_info && worthSplitting wrap_demands result_bot
+ -------------------------------------------------------------
cpr_info = getIdCprInfo fn_id
has_cpr_info = case cpr_info of
CPRInfo _ -> True
other -> False
do_cpr_ww = has_cpr_info
- unfold_guidance = calcUnfoldingGuidance opt_UF_CreationThreshold rhs
+
+ -------------------------------------------------------------
+ -- Do the coercion thing if the body is of a newtype
+ do_coerce_ww = isNewType body_ty
+
+
+{- July 99: removed again by Simon
-- This rather (nay! extremely!) crude function looks at a wrapper function, and
-- snaffles out the worker Id from the wrapper.
@@ -313,4 +340,5 @@ getWorkerId wrap_id wrapper_fn
work_id_try2 (App fn _) = work_id_try2 fn
work_id_try2 (Var work_id) = [work_id]
work_id_try2 other = []
+-}
\end{code}
diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs
index 7d68fc97ba46..4eefd47a1907 100644
--- a/ghc/compiler/stranal/WwLib.lhs
+++ b/ghc/compiler/stranal/WwLib.lhs
@@ -26,7 +26,8 @@ import TysPrim ( realWorldStatePrimTy )
import TysWiredIn ( unboxedTupleCon, unboxedTupleTyCon )
import Type ( isUnLiftedType, mkTyVarTys, mkTyVarTy, mkFunTys,
splitForAllTys, splitFunTys, splitFunTysN,
- splitAlgTyConApp_maybe, mkTyConApp,
+ splitAlgTyConApp_maybe, splitAlgTyConApp,
+ mkTyConApp, newTypeRep, isNewType,
Type
)
import TyCon ( isNewTyCon,
@@ -270,89 +271,130 @@ mkWwBodies :: [TyVar] -> [Id] -> Type -- Original fn args and body type
CoreExpr -> CoreExpr, -- Worker body, lacking the original function body
[Demand]) -- Strictness info for worker
-mkWwBodies tyvars args body_ty demands cpr_info
- | allAbsent demands &&
- isUnLiftedType body_ty
- = -- Horrid special case. If the worker would have no arguments, and the
- -- function returns a primitive type value, that would make the worker into
- -- an unboxed value. We box it by passing a dummy void argument, thus:
- --
- -- f = /\abc. \xyz. fw abc void
- -- fw = /\abc. \v. body
- --
- -- We use the state-token type which generates no code
- getUniqueUs `thenUs` \ void_arg_uniq ->
- let
- void_arg = mk_ww_local void_arg_uniq realWorldStatePrimTy
- in
- returnUs (\ work_id -> Note InlineMe $ -- Inline the wrapper
- mkLams tyvars $ mkLams args $
- mkApps (Var work_id)
- (map (Type . mkTyVarTy) tyvars ++ [Var realWorldPrimId]),
- \ body -> mkLams (tyvars ++ [void_arg]) body,
- [WwLazy True])
-
mkWwBodies tyvars wrap_args body_ty demands cpr_info
- | otherwise
= let
-- demands may be longer than number of args. If we aren't doing w/w
-- for strictness then demands is an infinite list of 'lazy' args.
wrap_args_w_demands = zipWith setIdDemandInfo wrap_args demands
+ (wrap_fn_coerce, work_fn_coerce) = mkWWcoerce body_ty
in
- mkWW wrap_args_w_demands `thenUs` \ (wrap_fn, work_args_w_demands, work_fn) ->
+ mkWWstr body_ty wrap_args_w_demands `thenUs` \ (work_args_w_demands, wrap_fn_str, work_fn_str) ->
- mkWWcpr body_ty cpr_info `thenUs` \ (wrap_fn_w_cpr, work_fn_w_cpr) ->
+ mkWWcpr body_ty cpr_info `thenUs` \ (wrap_fn_cpr, work_fn_cpr) ->
returnUs (\ work_id -> Note InlineMe $
mkLams tyvars $ mkLams wrap_args_w_demands $
- (wrap_fn_w_cpr . wrap_fn) (mkTyApps (Var work_id) (mkTyVarTys tyvars)),
+ (wrap_fn_coerce . wrap_fn_str . wrap_fn_cpr) $
+ mkVarApps (Var work_id) (tyvars ++ work_args_w_demands),
- \ body -> mkLams tyvars $ mkLams work_args_w_demands $
- (work_fn_w_cpr . work_fn) body,
+ \ work_body -> mkLams tyvars $ mkLams work_args_w_demands $
+ (work_fn_coerce . work_fn_str . work_fn_cpr)
+ work_body,
map getIdDemandInfo work_args_w_demands)
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Coercion stuff}
+%* *
+%************************************************************************
+
+The "coerce" transformation is
+ f :: T1 -> T2 -> R
+ f = \xy -> e
+===>
+ f = \xy -> coerce R R' (fw x y)
+ fw = \xy -> coerce R' R e
+
+where R' is the representation type for R.
+
+\begin{code}
+mkWWcoerce body_ty
+ | not (isNewType body_ty)
+ = (id, id)
+
+ | otherwise
+ = (wrap_fn . mkNote (Coerce body_ty rep_ty),
+ mkNote (Coerce rep_ty body_ty) . work_fn)
+ where
+ (tycon, args, _) = splitAlgTyConApp body_ty
+ rep_ty = newTypeRep tycon args
+ (wrap_fn, work_fn) = mkWWcoerce rep_ty
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Strictness stuff}
+%* *
+%************************************************************************
+
+
\begin{code}
-mkWW :: [Id] -- Wrapper args; have their demand info on them
- -> UniqSM (CoreExpr -> CoreExpr, -- Wrapper body, lacking the inner call to the worker
- -- and without its lambdas
- [Id], -- Worker args; have their demand info on them
- CoreExpr -> CoreExpr) -- Worker body, lacking the original body of the function
+mkWWstr :: Type -- Body type
+ -> [Id] -- Wrapper args; have their demand info on them
+ -> UniqSM ([Id], -- Worker args; have their demand info on them
+
+ CoreExpr -> CoreExpr, -- Wrapper body, lacking the inner call to the worker
+ -- and without its lambdas
+ -- At the call site, the worker args are bound
+
+ CoreExpr -> CoreExpr) -- Worker body, lacking the original body of the function,
+ -- and without its lambdas
+
+mkWWstr body_ty wrap_args
+ = mk_ww wrap_args `thenUs` \ (work_args, wrap_fn, work_fn) ->
+
+ if null work_args && isUnLiftedType body_ty then
+ -- Horrid special case. If the worker would have no arguments, and the
+ -- function returns a primitive type value, that would make the worker into
+ -- an unboxed value. We box it by passing a dummy void argument, thus:
+ --
+ -- f = /\abc. \xyz. fw abc void
+ -- fw = /\abc. \v. body
+ --
+ -- We use the state-token type which generates no code
+ getUniqueUs `thenUs` \ void_arg_uniq ->
+ let
+ void_arg = mk_ww_local void_arg_uniq realWorldStatePrimTy
+ in
+ returnUs ([void_arg],
+ wrap_fn . Let (NonRec void_arg (Var realWorldPrimId)),
+ work_fn)
+ else
+ returnUs (work_args, wrap_fn, work_fn)
+
-- Empty case
-mkWW []
- = returnUs (\ wrapper_body -> wrapper_body,
- [],
+mk_ww []
+ = returnUs ([],
+ \ wrapper_body -> wrapper_body,
\ worker_body -> worker_body)
-mkWW (arg : ds)
+mk_ww (arg : ds)
= case getIdDemandInfo arg of
-- Absent case
WwLazy True ->
- mkWW ds `thenUs` \ (wrap_fn, worker_args, work_fn) ->
- returnUs (\ wrapper_body -> wrap_fn wrapper_body,
- worker_args,
- \ worker_body -> mk_absent_let arg (work_fn worker_body))
-
+ mk_ww ds `thenUs` \ (worker_args, wrap_fn, work_fn) ->
+ returnUs (worker_args, wrap_fn, mk_absent_let arg . work_fn)
-- Unpack case
WwUnpack new_or_data True cs ->
getUniquesUs (length inst_con_arg_tys) `thenUs` \ uniqs ->
let
unpk_args = zipWith mk_ww_local uniqs inst_con_arg_tys
- unpk_args_w_ds = zipWithEqual "mkWW" setIdDemandInfo unpk_args cs
+ unpk_args_w_ds = zipWithEqual "mk_ww" setIdDemandInfo unpk_args cs
in
- mkWW (unpk_args_w_ds ++ ds) `thenUs` \ (wrap_fn, worker_args, work_fn) ->
- returnUs (\ wrapper_body -> mk_unpk_case new_or_data arg unpk_args data_con arg_tycon
- (wrap_fn wrapper_body),
- worker_args,
- \ worker_body -> work_fn (mk_pk_let new_or_data arg data_con
- tycon_arg_tys unpk_args worker_body))
+ mk_ww (unpk_args_w_ds ++ ds) `thenUs` \ (worker_args, wrap_fn, work_fn) ->
+ returnUs (worker_args,
+ mk_unpk_case new_or_data arg unpk_args data_con arg_tycon . wrap_fn,
+ work_fn . mk_pk_let new_or_data arg data_con tycon_arg_tys unpk_args)
where
inst_con_arg_tys = dataConArgTys data_con tycon_arg_tys
(arg_tycon, tycon_arg_tys, data_con)
@@ -370,15 +412,20 @@ mkWW (arg : ds)
Nothing ->
panic "mk_ww_arg_processing: not datatype"
-
-- Other cases
other_demand ->
- mkWW ds `thenUs` \ (wrap_fn, worker_args, work_fn) ->
- returnUs (\ wrapper_body -> wrap_fn (App wrapper_body (Var arg)),
- arg : worker_args,
- work_fn)
+ mk_ww ds `thenUs` \ (worker_args, wrap_fn, work_fn) ->
+ returnUs (arg : worker_args, wrap_fn, work_fn)
\end{code}
+
+%************************************************************************
+%* *
+\subsection{CPR stuff}
+%* *
+%************************************************************************
+
+
@mkWWcpr@ takes the worker/wrapper pair produced from the strictness
info and adds in the CPR transformation. The worker returns an
unboxed tuple containing non-CPR components. The wrapper takes this
@@ -613,6 +660,4 @@ mk_unboxed_tuple contents
map fst contents),
mkTyConApp (unboxedTupleTyCon (length contents))
(map snd contents))
-
-
\end{code}
diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs
index a95ffe91a725..4937d47d7326 100644
--- a/ghc/compiler/typecheck/TcGenDeriv.lhs
+++ b/ghc/compiler/typecheck/TcGenDeriv.lhs
@@ -61,7 +61,7 @@ import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
import Util ( mapAccumL, zipEqual, zipWithEqual,
zipWith3Equal, nOfThem, assocDefault )
import Panic ( panic, assertPanic )
-import Maybes ( maybeToBool, assocMaybe )
+import Maybes ( maybeToBool )
import Constants
import List ( partition, intersperse )
import Char ( isAlpha )
@@ -1068,6 +1068,12 @@ isLRAssoc fixs_assoc nm =
lookupFixity :: Fixities -> Name -> Fixity
lookupFixity fixs_assoc nm = assocDefault defaultFixity fixs_assoc nm
+isInfixOccName :: String -> Bool
+isInfixOccName str =
+ case str of
+ (':':_) -> True
+ _ -> False
+
\end{code}
diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs
index 0e15147dd9ce..556980d486ab 100644
--- a/ghc/compiler/typecheck/TcIfaceSig.lhs
+++ b/ghc/compiler/typecheck/TcIfaceSig.lhs
@@ -114,7 +114,7 @@ tcIdInfo unf_env name ty info info_ins
\begin{code}
tcWorkerInfo unf_env ty info worker_name
- | arity == 0
+ | not (hasArity arity_info)
= pprPanic "Worker with no arity info" (ppr worker_name)
| otherwise
@@ -131,9 +131,10 @@ tcWorkerInfo unf_env ty info worker_name
where
-- We are relying here on arity, cpr and strictness info always appearing
-- before worker info, fingers crossed ....
- arity = arityLowerBound (arityInfo info)
- cpr_info = cprInfo info
- demands = case strictnessInfo info of
+ arity_info = arityInfo info
+ arity = arityLowerBound arity_info
+ cpr_info = cprInfo info
+ demands = case strictnessInfo info of
StrictnessInfo d _ -> d
_ -> repeat wwLazy -- Noncommittal
\end{code}
diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index a7b6572e4d1d..d77827790a12 100644
--- a/ghc/compiler/types/Type.lhs
+++ b/ghc/compiler/types/Type.lhs
@@ -25,14 +25,15 @@ module Type (
mkAppTy, mkAppTys, splitAppTy, splitAppTys, splitAppTy_maybe,
- mkFunTy, mkFunTys, splitFunTy_maybe, splitFunTys, splitFunTysN, funResultTy,
+ mkFunTy, mkFunTys, splitFunTy_maybe, splitFunTys, splitFunTysN,
+ funResultTy, funArgTy,
zipFunTys,
mkTyConApp, mkTyConTy, splitTyConApp_maybe,
splitAlgTyConApp_maybe, splitAlgTyConApp,
mkDictTy, splitDictTy_maybe, isDictTy,
- mkSynTy, isSynTy, deNoteType, repType,
+ mkSynTy, isSynTy, deNoteType, repType, newTypeRep,
mkUsgTy, isUsgTy{- dont use -}, isNotUsgTy, splitUsgTy, unUsgTy, tyUsg,
@@ -45,7 +46,7 @@ module Type (
mkSigmaTy, splitSigmaTy,
-- Lifting and boxity
- isUnLiftedType, isUnboxedType, isUnboxedTupleType, isAlgType, isDataType,
+ isUnLiftedType, isUnboxedType, isUnboxedTupleType, isAlgType, isDataType, isNewType,
typePrimRep,
-- Free variables
@@ -450,6 +451,11 @@ funResultTy :: Type -> Type
funResultTy (FunTy arg res) = res
funResultTy (NoteTy _ ty) = funResultTy ty
funResultTy ty = pprPanic "funResultTy" (pprType ty)
+
+funArgTy :: Type -> Type
+funArgTy (FunTy arg res) = arg
+funArgTy (NoteTy _ ty) = funArgTy ty
+funArgTy ty = pprPanic "funArgTy" (pprType ty)
\end{code}
@@ -579,12 +585,18 @@ interested in newtypes anymore.
\begin{code}
repType :: Type -> Type
-repType (NoteTy _ ty) = repType ty
-repType (ForAllTy _ ty) = repType ty
-repType (TyConApp tc tys) | isNewTyCon tc
- = case splitFunTy_maybe (applyTys (dataConType (head (tyConDataCons tc))) tys) of
- Just (rep_ty, _) -> repType rep_ty
-repType other_ty = other_ty
+repType (NoteTy _ ty) = repType ty
+repType (ForAllTy _ ty) = repType ty
+repType (TyConApp tc tys) | isNewTyCon tc = repType (newTypeRep tc tys)
+repType other_ty = other_ty
+
+newTypeRep :: TyCon -> [Type] -> Type
+-- The representation type for (T t1 .. tn), where T is a newtype
+-- Looks through one layer only
+newTypeRep tc tys
+ = ASSERT( isNewTyCon tc )
+ case splitFunTy_maybe (applyTys (dataConType (head (tyConDataCons tc))) tys) of
+ Just (rep_ty, _) -> rep_ty
\end{code}
@@ -985,6 +997,12 @@ isDataType ty = case splitTyConApp_maybe ty of
isDataTyCon tc
other -> False
+isNewType :: Type -> Bool
+isNewType ty = case splitTyConApp_maybe ty of
+ Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
+ isNewTyCon tc
+ other -> False
+
typePrimRep :: Type -> PrimRep
typePrimRep ty = case splitTyConApp_maybe ty of
Just (tc, ty_args) -> tyConPrimRep tc
diff --git a/ghc/driver/ghc.lprl b/ghc/driver/ghc.lprl
index a05f14755b73..5e93214df655 100644
--- a/ghc/driver/ghc.lprl
+++ b/ghc/driver/ghc.lprl
@@ -775,6 +775,11 @@ sub setupOptimiseFlags {
'-fcse', # CSE must immediately follow a simplification pass, because it relies
# on the no-shadowing invariant. See comments at the top of CSE.lhs
+ '-ffull-laziness', # nofib/spectral/hartel/wang doubles in speed if you
+ # do full laziness late in the day. It only happens
+ # after fusion and other stuff, so the early pass doesn't
+ # catch it. For the record, the redex is
+ # f_el22 (f_el21 r_midblock)
'-ffloat-inwards',
# Case-liberation for -O2. This should be after
diff --git a/ghc/lib/concurrent/Channel.lhs b/ghc/lib/concurrent/Channel.lhs
index fca29df8249f..18dd20e57c95 100644
--- a/ghc/lib/concurrent/Channel.lhs
+++ b/ghc/lib/concurrent/Channel.lhs
@@ -70,14 +70,14 @@ new hole.
\begin{code}
writeChan :: Chan a -> a -> IO ()
-writeChan (Chan read write) val = do
+writeChan (Chan _read write) val = do
new_hole <- newEmptyMVar
old_hole <- takeMVar write
putMVar write new_hole
putMVar old_hole (ChItem val new_hole)
readChan :: Chan a -> IO a
-readChan (Chan read write) = do
+readChan (Chan read _write) = do
read_end <- takeMVar read
(ChItem val new_read_end) <- takeMVar read_end
putMVar read new_read_end
@@ -85,14 +85,14 @@ readChan (Chan read write) = do
dupChan :: Chan a -> IO (Chan a)
-dupChan (Chan read write) = do
+dupChan (Chan _read write) = do
new_read <- newEmptyMVar
hole <- readMVar write
putMVar new_read hole
return (Chan new_read write)
unGetChan :: Chan a -> a -> IO ()
-unGetChan (Chan read write) val = do
+unGetChan (Chan read _write) val = do
new_read_end <- newEmptyMVar
read_end <- takeMVar read
putMVar new_read_end (ChItem val read_end)
diff --git a/ghc/lib/exts/GetOpt.lhs b/ghc/lib/exts/GetOpt.lhs
index f8c464695310..2a934dfc7f6c 100644
--- a/ghc/lib/exts/GetOpt.lhs
+++ b/ghc/lib/exts/GetOpt.lhs
@@ -125,7 +125,7 @@ shortOpt x xs rest optDescr = short ads xs rest
short (_:_:_) _ rest = (errAmbig options optStr,rest)
short (NoArg a :_) [] rest = (Opt a,rest)
short (NoArg a :_) xs rest = (Opt a,('-':xs):rest)
- short (ReqArg f d:_) [] [] = (errReq d optStr,[])
+ short (ReqArg _ d:_) [] [] = (errReq d optStr,[])
short (ReqArg f _:_) [] (r:rest) = (Opt (f r),rest)
short (ReqArg f _:_) xs rest = (Opt (f xs),rest)
short (OptArg f _:_) [] rest = (Opt (f Nothing),rest)
diff --git a/ghc/lib/exts/MutableArray.lhs b/ghc/lib/exts/MutableArray.lhs
index 205d71c7b5ea..7c8698228c24 100644
--- a/ghc/lib/exts/MutableArray.lhs
+++ b/ghc/lib/exts/MutableArray.lhs
@@ -327,7 +327,7 @@ writeInt16Array (MutableByteArray ixs arr#) n i = ST $ \ s# ->
(# s2# , v# #) ->
let w' = word2Int# (int2Word# i# `or#` (int2Word# v# `and#` mask))
in
- case writeIntArray# arr# (n# `quotInt#` 2#) w' s# of
+ case writeIntArray# arr# (n# `quotInt#` 2#) w' s2# of
s2# -> (# s2# , () #)
writeInt32Array (MutableByteArray ixs arr#) n i = ST $ \ s# ->
diff --git a/ghc/lib/posix/Posix.lhs b/ghc/lib/posix/Posix.lhs
index 93f70a226a1b..b758e07367e9 100644
--- a/ghc/lib/posix/Posix.lhs
+++ b/ghc/lib/posix/Posix.lhs
@@ -84,7 +84,7 @@ runProcess path args env dir stdin stdout stderr = do
pid <- forkProcess
case pid of
Nothing -> doTheBusiness
- Just x -> return ()
+ Just _ -> return ()
where
doTheBusiness :: IO ()
doTheBusiness = do
diff --git a/ghc/lib/posix/PosixIO.lhs b/ghc/lib/posix/PosixIO.lhs
index 8a0713be489c..4baf00764832 100644
--- a/ghc/lib/posix/PosixIO.lhs
+++ b/ghc/lib/posix/PosixIO.lhs
@@ -128,8 +128,8 @@ fdToHandle fd@(FD# fd#) = do
fd_str = "<file descriptor: " ++ show (I# fd#) ++ ">"
fdRead :: Fd -> ByteCount -> IO (String, ByteCount)
-fdRead fd 0 = return ("", 0)
-fdRead fd nbytes = do
+fdRead _fd 0 = return ("", 0)
+fdRead fd nbytes = do
bytes <- allocChars nbytes
rc <- _ccall_ read fd bytes nbytes
case rc of
diff --git a/ghc/lib/posix/PosixProcEnv.lhs b/ghc/lib/posix/PosixProcEnv.lhs
index 7d33f0ea8497..bd0394adf29c 100644
--- a/ghc/lib/posix/PosixProcEnv.lhs
+++ b/ghc/lib/posix/PosixProcEnv.lhs
@@ -245,10 +245,10 @@ getTerminalName fd = do
if str == nullAddr
then do
err <- try (queryTerminal fd)
- either (\err -> syserr "getTerminalName")
- (\succ -> if succ then ioError (IOError Nothing NoSuchThing
+ either (\ _err -> syserr "getTerminalName")
+ (\ succ -> if succ then ioError (IOError Nothing NoSuchThing
"getTerminalName" "no name")
- else ioError (IOError Nothing InappropriateType
+ else ioError (IOError Nothing InappropriateType
"getTerminalName" "not a terminal"))
err
else strcpy str
diff --git a/ghc/lib/posix/PosixProcPrim.lhs b/ghc/lib/posix/PosixProcPrim.lhs
index 7e93a2111bad..ffe72145f29f 100644
--- a/ghc/lib/posix/PosixProcPrim.lhs
+++ b/ghc/lib/posix/PosixProcPrim.lhs
@@ -178,7 +178,7 @@ getGroupProcessStatus block stopped pgid = do
getAnyProcessStatus :: Bool -> Bool -> IO (Maybe (ProcessID, ProcessStatus))
getAnyProcessStatus block stopped =
getGroupProcessStatus block stopped 1 `catch`
- \ err -> syserr "getAnyProcessStatus"
+ \ _err -> syserr "getAnyProcessStatus"
exitImmediately :: ExitCode -> IO ()
exitImmediately exitcode = do
diff --git a/ghc/lib/std/Ix.lhs b/ghc/lib/std/Ix.lhs
index 9b25f62970df..1ed8bc256709 100644
--- a/ghc/lib/std/Ix.lhs
+++ b/ghc/lib/std/Ix.lhs
@@ -80,7 +80,7 @@ instance Ix Char where
range (m,n) = [m..n]
{-# INLINE unsafeIndex #-}
- unsafeIndex (m,n) i = fromEnum i - fromEnum m
+ unsafeIndex (m,_n) i = fromEnum i - fromEnum m
index b i | inRange b i = unsafeIndex b i
| otherwise = indexError b i "Char"
@@ -95,7 +95,7 @@ instance Ix Int where
range (m,n) = [m..n]
{-# INLINE unsafeIndex #-}
- unsafeIndex (m,n) i = i - m
+ unsafeIndex (m,_n) i = i - m
index b i | inRange b i = unsafeIndex b i
| otherwise = indexError b i "Int"
@@ -109,7 +109,7 @@ instance Ix Integer where
range (m,n) = [m..n]
{-# INLINE unsafeIndex #-}
- unsafeIndex (m,n) i = fromInteger (i - m)
+ unsafeIndex (m,_n) i = fromInteger (i - m)
index b i | inRange b i = unsafeIndex b i
| otherwise = indexError b i "Integer"
@@ -249,13 +249,13 @@ in the range for an @Ix@ pair.
{-# SPECIALISE unsafeRangeSize :: (Int,Int) -> Int #-}
{-# SPECIALISE unsafeRangeSize :: ((Int,Int),(Int,Int)) -> Int #-}
unsafeRangeSize :: (Ix a) => (a,a) -> Int
-unsafeRangeSize b@(l,h) = unsafeIndex b h + 1
+unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1
{-# SPECIALISE rangeSize :: (Int,Int) -> Int #-}
{-# SPECIALISE rangeSize :: ((Int,Int),(Int,Int)) -> Int #-}
rangeSize :: (Ix a) => (a,a) -> Int
-rangeSize b@(l,h) | inRange b h = unsafeIndex b h + 1
- | otherwise = 0
+rangeSize b@(_l,h) | inRange b h = unsafeIndex b h + 1
+ | otherwise = 0
-- Note that the following is NOT right
-- rangeSize (l,h) | l <= h = index b h + 1
diff --git a/ghc/lib/std/List.lhs b/ghc/lib/std/List.lhs
index 680c5c39747e..abdde601ff1a 100644
--- a/ghc/lib/std/List.lhs
+++ b/ghc/lib/std/List.lhs
@@ -253,9 +253,11 @@ transpose ((x:xs) : xss) = (x : [h | (h:t) <- xss]) : transpose (xs : [ t | (h:t
-- predicate, respectively; i,e,,
-- partition p xs == (filter p xs, filter (not . p) xs).
partition :: (a -> Bool) -> [a] -> ([a],[a])
-partition p xs = foldr select ([],[]) xs
- where select x (ts,fs) | p x = (x:ts,fs)
- | otherwise = (ts, x:fs)
+{-# INLINE partition #-}
+partition p xs = foldr (select p) ([],[]) xs
+
+select p x (ts,fs) | p x = (x:ts,fs)
+ | otherwise = (ts, x:fs)
\end{code}
@mapAccumL@ behaves like a combination
diff --git a/ghc/lib/std/Monad.lhs b/ghc/lib/std/Monad.lhs
index 8f631159bf5d..f95e1cb91bec 100644
--- a/ghc/lib/std/Monad.lhs
+++ b/ghc/lib/std/Monad.lhs
@@ -83,12 +83,15 @@ sequence [] = return []
sequence (m:ms) = do { x <- m; xs <- sequence ms; return (x:xs) }
sequence_ :: Monad m => [m a] -> m ()
+{-# INLINE sequence_ #-}
sequence_ = foldr (>>) (return ())
mapM :: Monad m => (a -> m b) -> [a] -> m [b]
+{-# INLINE mapM #-}
mapM f as = sequence (map f as)
mapM_ :: Monad m => (a -> m b) -> [a] -> m ()
+{-# INLINE mapM_ #-}
mapM_ f as = sequence_ (map f as)
guard :: MonadPlus m => Bool -> m ()
@@ -108,6 +111,7 @@ filterM predM (x:xs) = do
-- This subsumes the list-based concat function.
msum :: MonadPlus m => [m a] -> m a
+{-# INLINE msum #-}
msum = foldr mplus mzero
{-# SPECIALISE (=<<) :: (a -> [b]) -> [a] -> [b] #-}
diff --git a/ghc/lib/std/PrelArr.lhs b/ghc/lib/std/PrelArr.lhs
index c0da09cf8db6..8165fac1ff80 100644
--- a/ghc/lib/std/PrelArr.lhs
+++ b/ghc/lib/std/PrelArr.lhs
@@ -145,8 +145,10 @@ arrEleBottom = error "(Array.!): undefined array element"
-----------------------------------------------------------------------
--- these also go better with magic: (//), accum, accumArray
+-- These also go better with magic: (//), accum, accumArray
+-- *** NB *** We INLINE them all so that their foldr's get to the call site
+{-# INLINE (//) #-}
old_array // ivs
= runST (do
-- copy the old array:
@@ -157,23 +159,25 @@ old_array // ivs
)
fill_it_in :: Ix ix => MutableArray s ix elt -> [(ix, elt)] -> ST s ()
-fill_it_in arr lst
- = foldr fill_one_in (return ()) lst
- where -- **** STRICT **** (but that's OK...)
- fill_one_in (i, v) rst
- = writeArray arr i v >> rst
+{-# INLINE fill_it_in #-}
+fill_it_in arr lst = foldr (fill_one_in arr) (return ()) lst
+ -- **** STRICT **** (but that's OK...)
+
+fill_one_in arr (i, v) rst = writeArray arr i v >> rst
zap_with_f :: Ix ix => (elt -> elt2 -> elt) -> MutableArray s ix elt -> [(ix,elt2)] -> ST s ()
-- zap_with_f: reads an elem out first, then uses "f" on that and the new value
+{-# INLINE zap_with_f #-}
zap_with_f f arr lst
- = foldr zap_one (return ()) lst
- where
- zap_one (i, new_v) rst = do
- old_v <- readArray arr i
+ = foldr (zap_one f arr) (return ()) lst
+
+zap_one f arr (i, new_v) rst = do
+ old_v <- readArray arr i
writeArray arr i (f old_v new_v)
rst
+{-# INLINE accum #-}
accum f old_array ivs
= runST (do
-- copy the old array:
@@ -183,11 +187,12 @@ accum f old_array ivs
freezeArray arr
)
+{-# INLINE accumArray #-}
accumArray f zero ixs ivs
= runST (do
- arr# <- newArray ixs zero
- zap_with_f f arr# ivs
- freezeArray arr#
+ arr <- newArray ixs zero
+ zap_with_f f arr ivs
+ freezeArray arr
)
\end{code}
diff --git a/ghc/lib/std/PrelBase.lhs b/ghc/lib/std/PrelBase.lhs
index e3d4d6f2284f..b48a3e619b6c 100644
--- a/ghc/lib/std/PrelBase.lhs
+++ b/ghc/lib/std/PrelBase.lhs
@@ -55,10 +55,10 @@ class (Eq a) => Ord a where
-- be defined for an instance of Ord
| otherwise = GT
- x <= y = case compare x y of { GT -> False; other -> True }
- x < y = case compare x y of { LT -> True; other -> False }
- x >= y = case compare x y of { LT -> False; other -> True }
- x > y = case compare x y of { GT -> True; other -> False }
+ x <= y = case compare x y of { GT -> False; _other -> True }
+ x < y = case compare x y of { LT -> True; _other -> False }
+ x >= y = case compare x y of { LT -> False; _other -> True }
+ x > y = case compare x y of { GT -> True; _other -> False }
-- These two default methods use '>' rather than compare
-- because the latter is often more expensive
@@ -99,6 +99,7 @@ data [] a = [] | a : [a] -- do explicitly: deriving (Eq, Ord)
-- to avoid weird names like con2tag_[]#
instance (Eq a) => Eq [a] where
+ {-# SPECIALISE instance Eq [Char] #-}
[] == [] = True
(x:xs) == (y:ys) = x == y && xs == ys
_xs == _ys = False
@@ -106,6 +107,7 @@ instance (Eq a) => Eq [a] where
xs /= ys = if (xs == ys) then False else True
instance (Ord a) => Ord [a] where
+ {-# SPECIALISE instance Ord [Char] #-}
a < b = case compare a b of { LT -> True; EQ -> False; GT -> False }
a <= b = case compare a b of { LT -> True; EQ -> True; GT -> False }
a >= b = case compare a b of { LT -> False; EQ -> True; GT -> True }
diff --git a/ghc/lib/std/PrelEnum.lhs b/ghc/lib/std/PrelEnum.lhs
index 05eb48aba73d..8d88920c69df 100644
--- a/ghc/lib/std/PrelEnum.lhs
+++ b/ghc/lib/std/PrelEnum.lhs
@@ -72,8 +72,8 @@ instance Bounded () where
maxBound = ()
instance Enum () where
- succ x = error "Prelude.Enum.().succ: bad argment"
- pred x = error "Prelude.Enum.().pred: bad argument"
+ succ _ = error "Prelude.Enum.().succ: bad argment"
+ pred _ = error "Prelude.Enum.().pred: bad argument"
toEnum x | x == zeroInt = ()
| otherwise = error "Prelude.Enum.().toEnum: bad argument"
@@ -153,7 +153,7 @@ instance Enum Ordering where
toEnum n | n == zeroInt = LT
| n == oneInt = EQ
| n == twoInt = GT
- toEnum n = error "Prelude.Enum.Ordering.toEnum: bad argment"
+ toEnum _ = error "Prelude.Enum.Ordering.toEnum: bad argment"
fromEnum LT = zeroInt
fromEnum EQ = oneInt
@@ -176,10 +176,10 @@ instance Bounded Char where
maxBound = '\255'
instance Enum Char where
- succ c@(C# c#)
+ succ (C# c#)
| not (ord# c# ==# 255#) = C# (chr# (ord# c# +# 1#))
| otherwise = error ("Prelude.Enum.Char.succ: bad argument")
- pred c@(C# c#)
+ pred (C# c#)
| not (ord# c# ==# 0#) = C# (chr# (ord# c# -# 1#))
| otherwise = error ("Prelude.Enum.Char.pred: bad argument")
diff --git a/ghc/lib/std/PrelHandle.lhs b/ghc/lib/std/PrelHandle.lhs
index 27c214330fa0..337184f2e26e 100644
--- a/ghc/lib/std/PrelHandle.lhs
+++ b/ghc/lib/std/PrelHandle.lhs
@@ -1123,10 +1123,6 @@ wantRWHandle fun handle act =
ClosedHandle -> ioe_closedHandle fun handle
SemiClosedHandle -> ioe_closedHandle fun handle
_ -> act handle_
- where
- not_rw_error =
- IOError (Just handle) IllegalOperation fun
- ("handle is not open for reading or writing")
wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
wantSeekableHandle fun handle act =
diff --git a/ghc/lib/std/PrelList.lhs b/ghc/lib/std/PrelList.lhs
index 6983e85fd15a..1d32fd72b945 100644
--- a/ghc/lib/std/PrelList.lhs
+++ b/ghc/lib/std/PrelList.lhs
@@ -181,7 +181,7 @@ scanr1 _ [] = errorEmptyList "scanr1"
-- iterate f x == [x, f x, f (f x), ...]
iterate :: (a -> a) -> a -> [a]
{-# INLINE iterate #-}
-iterate f x = build (\c n -> iterateFB c f x)
+iterate f x = build (\c _n -> iterateFB c f x)
iterateFB c f x = x `c` iterateFB c f (f x)
@@ -195,7 +195,7 @@ iterateList f x = x : iterateList f (f x)
-- repeat x is an infinite list, with x the value of every element.
repeat :: a -> [a]
{-# INLINE repeat #-}
-repeat x = build (\c n -> repeatFB c x)
+repeat x = build (\c _n -> repeatFB c x)
repeatFB c x = xs where xs = x `c` xs
repeatList x = xs where xs = x : xs
@@ -456,15 +456,15 @@ xs !! (I# n) | n <# 0# = error "Prelude.(!!): negative index\n"
%*********************************************************
\begin{code}
-foldr2 k z [] ys = z
-foldr2 k z xs [] = z
+foldr2 _k z [] _ys = z
+foldr2 _k z _xs [] = z
foldr2 k z (x:xs) (y:ys) = k x y (foldr2 k z xs ys)
-foldr2_left k z x r [] = z
-foldr2_left k z x r (y:ys) = k x y (r ys)
+foldr2_left _k z _x _r [] = z
+foldr2_left k _z x r (y:ys) = k x y (r ys)
-foldr2_right k z y r [] = z
-foldr2_right k z y r (x:xs) = k x y (r xs)
+foldr2_right _k z _y _r [] = z
+foldr2_right k _z y r (x:xs) = k x y (r xs)
-- foldr2 k z xs ys = foldr (foldr2_left k z) (\_ -> z) xs ys
-- foldr2 k z xs ys = foldr (foldr2_right k z) (\_ -> z) ys xs
@@ -526,7 +526,7 @@ zipWithFB c f x y r = (x `f` y) `c` r
zipWithList :: (a->b->c) -> [a] -> [b] -> [c]
zipWithList f (a:as) (b:bs) = f a b : zipWithList f as bs
-zipWithList f _ _ = []
+zipWithList _ _ _ = []
{-# RULES
"zipWithList" forall f. foldr2 (zipWithFB (:) f) [] = zipWithList f
@@ -541,9 +541,11 @@ zipWith3 _ _ _ _ = []
-- unzip transforms a list of pairs into a pair of lists.
unzip :: [(a,b)] -> ([a],[b])
+{-# INLINE unzip #-}
unzip = foldr (\(a,b) ~(as,bs) -> (a:as,b:bs)) ([],[])
unzip3 :: [(a,b,c)] -> ([a],[b],[c])
+{-# INLINE unzip3 #-}
unzip3 = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))
([],[],[])
\end{code}
diff --git a/ghc/lib/std/PrelNum.lhs b/ghc/lib/std/PrelNum.lhs
index b6fc0d1cfeaf..a946e1b3f994 100644
--- a/ghc/lib/std/PrelNum.lhs
+++ b/ghc/lib/std/PrelNum.lhs
@@ -247,15 +247,15 @@ instance Ord Integer where
}
toBig (S# i) = case int2Integer# i of { (# s, d #) -> J# s d }
-toBig i@(J# s d) = i
+toBig i@(J# _ _) = i
instance Num Integer where
(+) i1@(S# i) i2@(S# j)
= case addIntC# i j of { (# r, c #) ->
if c ==# 0# then S# r
else toBig i1 + toBig i2 }
- (+) i1@(J# s d) i2@(S# i) = i1 + toBig i2
- (+) i1@(S# i) i2@(J# s d) = toBig i1 + i2
+ (+) i1@(J# _ _) i2@(S# _) = i1 + toBig i2
+ (+) i1@(S# _) i2@(J# _ _) = toBig i1 + i2
(+) (J# s1 d1) (J# s2 d2)
= case plusInteger# s1 d1 s2 d2 of (# s, d #) -> J# s d
@@ -263,8 +263,8 @@ instance Num Integer where
= case subIntC# i j of { (# r, c #) ->
if c ==# 0# then S# r
else toBig i1 - toBig i2 }
- (-) i1@(J# s d) i2@(S# i) = i1 - toBig i2
- (-) i1@(S# i) i2@(J# s d) = toBig i1 - i2
+ (-) i1@(J# _ _) i2@(S# _) = i1 - toBig i2
+ (-) i1@(S# _) i2@(J# _ _) = toBig i1 - i2
(-) (J# s1 d1) (J# s2 d2)
= case minusInteger# s1 d1 s2 d2 of (# s, d #) -> J# s d
@@ -272,12 +272,12 @@ instance Num Integer where
= case mulIntC# i j of { (# r, c #) ->
if c ==# 0# then S# r
else toBig i1 * toBig i2 }
- (*) i1@(J# s d) i2@(S# i) = i1 * toBig i2
- (*) i1@(S# i) i2@(J# s d) = toBig i1 * i2
+ (*) i1@(J# _ _) i2@(S# _) = i1 * toBig i2
+ (*) i1@(S# _) i2@(J# _ _) = toBig i1 * i2
(*) (J# s1 d1) (J# s2 d2)
= case timesInteger# s1 d1 s2 d2 of (# s, d #) -> J# s d
- negate i@(S# (-2147483648#)) = 2147483648
+ negate (S# (-2147483648#)) = 2147483648
negate (S# i) = S# (negateInt# i)
negate (J# s d) = J# (negateInt# s) d
@@ -310,8 +310,8 @@ instance Integral Integer where
-- a `quot` b returns a small integer if a is small.
quotRem (S# i) (S# j)
= case quotRem (I# i) (I# j) of ( I# i, I# j ) -> ( S# i, S# j)
- quotRem i1@(J# s d) i2@(S# i) = quotRem i1 (toBig i2)
- quotRem i1@(S# i) i2@(J# s d) = quotRem (toBig i1) i2
+ quotRem i1@(J# _ _) i2@(S# _) = quotRem i1 (toBig i2)
+ quotRem i1@(S# _) i2@(J# _ _) = quotRem (toBig i1) i2
quotRem (J# s1 d1) (J# s2 d2)
= case (quotRemInteger# s1 d1 s2 d2) of
(# s3, d3, s4, d4 #)
@@ -359,8 +359,8 @@ instance Enum Integer where
{-# INLINE enumFromThen #-}
{-# INLINE enumFromTo #-}
{-# INLINE enumFromThenTo #-}
- enumFrom x = build (\c n -> enumDeltaIntegerFB c x 1)
- enumFromThen x y = build (\c n -> enumDeltaIntegerFB c x (y-x))
+ enumFrom x = build (\c _ -> enumDeltaIntegerFB c x 1)
+ enumFromThen x y = build (\c _ -> enumDeltaIntegerFB c x (y-x))
enumFromTo x lim = build (\c n -> enumDeltaToIntegerFB c n x 1 lim)
enumFromThenTo x y lim = build (\c n -> enumDeltaToIntegerFB c n x (y-x) lim)
diff --git a/ghc/lib/std/PrelShow.lhs b/ghc/lib/std/PrelShow.lhs
index 59b768b5e65b..b9ee6233c8bc 100644
--- a/ghc/lib/std/PrelShow.lhs
+++ b/ghc/lib/std/PrelShow.lhs
@@ -99,13 +99,13 @@ instance Show Int where
showsPrec p n = showSignedInt p n
instance Show a => Show (Maybe a) where
- showsPrec p Nothing = showString "Nothing"
- showsPrec p (Just x) = showString "Just " . shows x
+ showsPrec _p Nothing = showString "Nothing"
+ showsPrec _p (Just x) = showString "Just " . shows x
-- Not sure I have the priorities right here
instance (Show a, Show b) => Show (Either a b) where
- showsPrec p (Left a) = showString "Left " . shows a
- showsPrec p (Right b) = showString "Right " . shows b
+ showsPrec _p (Left a) = showString "Left " . shows a
+ showsPrec _p (Right b) = showString "Right " . shows b
-- Not sure I have the priorities right here
\end{code}
diff --git a/ghc/lib/std/Random.lhs b/ghc/lib/std/Random.lhs
index e6135c28d9e5..998ed0f08fbd 100644
--- a/ghc/lib/std/Random.lhs
+++ b/ghc/lib/std/Random.lhs
@@ -63,7 +63,7 @@ instance Show StdGen where
showSignedInt p s2
instance Read StdGen where
- readsPrec p = \ r ->
+ readsPrec _p = \ r ->
case try_read r of
r@[_] -> r
_ -> [stdFromString r] -- because it shouldn't ever fail.
@@ -220,7 +220,7 @@ stdNext (StdGen s1 s2) = (z', StdGen s1'' s2'')
s2'' = if s2' < 0 then s2' + 2147483399 else s2'
stdSplit :: StdGen -> (StdGen, StdGen)
-stdSplit std@(StdGen s1 s2) = (std, unsafePerformIO (mkStdRNG (fromInt s1)))
+stdSplit std@(StdGen s1 _) = (std, unsafePerformIO (mkStdRNG (fromInt s1)))
\end{code}
--
GitLab