diff options
| author | simonpj <unknown> | 1999-07-06 16:46:12 +0000 |
|---|---|---|
| committer | simonpj <unknown> | 1999-07-06 16:46:12 +0000 |
| commit | 9d38678ea60ff32f756390a30c659daa22c98c93 (patch) | |
| tree | 520970e39a3c81cdeb22271b83e576e726abdb37 | |
| parent | 47a40c89ca2e588b62d986a58907e178bce1de4f (diff) | |
| download | haskell-9d38678ea60ff32f756390a30c659daa22c98c93.tar.gz | |
[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.
42 files changed, 646 insertions, 396 deletions
diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 3ba8763b5e..1c8e026197 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 d5e2ccc4e8..2c36363b4e 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 285ecc2724..e59fec1b7c 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 bec784c7fc..27843e820b 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 6fd0fd9b4d..f27289ec0e 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 bc6b37611b..9b9b03c85e 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 3f3b5a073c..e4f2d7bb60 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 b3f93eac21..64d4d502f6 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 0766eeaa20..2fec609e85 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 5d58b407a6..6df655d7ab 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 ca22b19a0e..baf7b300dd 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 f7276b8ba7..c5018a4c81 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 e4e47f757e..d41f3d91e9 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 87927ece48..e137536997 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 2937890e93..e74525d034 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 4ef7937e36..7ce7e2770f 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 6c365b7348..bb7fc9e919 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 99da2e2d70..8406b0a498 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 472cfd9f01..7a95e55cde 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 7d68fc97ba..4eefd47a19 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 a95ffe91a7..4937d47d73 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 0e15147dd9..556980d486 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 a7b6572e4d..d77827790a 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 a05f14755b..5e93214df6 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 fca29df824..18dd20e57c 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 f8c4646953..2a934dfc7f 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 205d71c7b5..7c8698228c 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 93f70a226a..b758e07367 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 8a0713be48..4baf007648 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 7d33f0ea84..bd0394adf2 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 7e93a2111b..ffe72145f2 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 9b25f62970..1ed8bc2567 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 680c5c3974..abdde601ff 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 8f631159bf..f95e1cb91b 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 c0da09cf8d..8165fac1ff 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 e3d4d6f228..b48a3e619b 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 05eb48aba7..8d88920c69 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 27c214330f..337184f2e2 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 6983e85fd1..1d32fd72b9 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 b6fc0d1cfe..a946e1b3f9 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 59b768b5e6..b9ee6233c8 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 e6135c28d9..998ed0f08f 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} |