From f2054812b868d752c75dd0b148cc884b00f5e5d6 Mon Sep 17 00:00:00 2001 From: simonpj Date: Tue, 29 Jan 2002 09:58:21 +0000 Subject: [PATCH] [project @ 2002-01-29 09:58:14 by simonpj] ------------ Rule phasing ------------ This commit adds a little more control to when rules are enabled. {-# RULES "foo" [2] forall ... "baz" [~2] forall ... #-} Rule "foo" is active in phase 2 and later. The new thing is that the "~2" means that Rule "baz" is active in phase 3 and earlier. (Remember tha phases decrease towards zero.) All the machinery was there to implement this, it just needed the syntax. Why do this? Peter Gammie (at UNSW) found that rules weren't firing because of bindings of the form M.f = f f = .... where the rules where on the M.f binding. It turned out that an old hack (which have for some time elicited the harmless "shortMeOut" debug warnings) prevented this trivial construction from being correctly simplified. The hack in turn derived from a trick in the way the foldr/build rule was implemented....and that hack is no longer necessary now we can switch rules *off* as well as *on*. There are consequential changes in the Prelude foldr/build RULE stuff. It's a clean-up.... Instead of strange definitions like map = mapList which we had before, we have an ordinary recursive defn of map, together with rules to convert first to foldr/build form, and then (if nothing happens) back again. There's a fairly long comment about the general plan of attack in PrelBase, near the defn of map. --- ghc/compiler/basicTypes/BasicTypes.lhs | 20 +++++----- ghc/compiler/hsSyn/HsBinds.lhs | 8 +--- ghc/compiler/parser/Parser.y | 10 +++-- ghc/compiler/prelude/PrelNames.lhs | 3 -- ghc/compiler/prelude/PrelRules.lhs | 8 ++-- ghc/compiler/rename/ParseIface.y | 2 + ghc/compiler/simplCore/OccurAnal.lhs | 4 ++ ghc/lib/std/PrelBase.lhs | 52 +++++++++++++++--------- ghc/lib/std/PrelEnum.lhs | 54 ++++++++++--------------- ghc/lib/std/PrelList.lhs | 68 +++++++++++++------------------- ghc/lib/std/PrelNum.lhs | 28 ++++++------- 11 files changed, 122 insertions(+), 135 deletions(-) diff --git a/ghc/compiler/basicTypes/BasicTypes.lhs b/ghc/compiler/basicTypes/BasicTypes.lhs index 76185e7..42e5e9f 100644 --- a/ghc/compiler/basicTypes/BasicTypes.lhs +++ b/ghc/compiler/basicTypes/BasicTypes.lhs @@ -43,7 +43,7 @@ module BasicTypes( StrictnessMark(..), isMarkedUnboxed, isMarkedStrict, - CompilerPhase, pprPhase, + CompilerPhase, Activation(..), isActive, isNeverActive, isAlwaysActive ) where @@ -387,23 +387,23 @@ type CompilerPhase = Int -- Compilation phase -- Phases decrease towards zero -- Zero is the last phase -pprPhase :: CompilerPhase -> SDoc -pprPhase n = brackets (int n) - data Activation = NeverActive | AlwaysActive + | ActiveBefore CompilerPhase -- Active only *before* this phase | ActiveAfter CompilerPhase -- Active in this phase and later deriving( Eq ) -- Eq used in comparing rules in HsDecls instance Outputable Activation where - ppr AlwaysActive = empty -- The default - ppr (ActiveAfter n) = pprPhase n - ppr NeverActive = ptext SLIT("NEVER") + ppr AlwaysActive = empty -- The default + ppr (ActiveBefore n) = brackets (char '~' <> int n) + ppr (ActiveAfter n) = brackets (int n) + ppr NeverActive = ptext SLIT("NEVER") isActive :: CompilerPhase -> Activation -> Bool -isActive p NeverActive = False -isActive p AlwaysActive = True -isActive p (ActiveAfter n) = p <= n +isActive p NeverActive = False +isActive p AlwaysActive = True +isActive p (ActiveAfter n) = p <= n +isActive p (ActiveBefore n) = p > n isNeverActive, isAlwaysActive :: Activation -> Bool isNeverActive NeverActive = True diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index 4f66055..773a946 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -24,7 +24,7 @@ import PprCore ( {- instance Outputable (Expr a) -} ) import Name ( Name ) import PrelNames ( isUnboundName ) import NameSet ( NameSet, elemNameSet, nameSetToList ) -import BasicTypes ( RecFlag(..), Fixity, Activation(..), pprPhase ) +import BasicTypes ( RecFlag(..), Fixity, Activation(..) ) import Outputable import SrcLoc ( SrcLoc ) import Var ( TyVar ) @@ -360,11 +360,7 @@ ppr_sig (InlineSig True var phase _) = hsep [text "{-# INLINE", ppr phase, ppr var, text "#-}"] ppr_sig (InlineSig False var phase _) - = hsep [text "{-# NOINLINE", pp_phase phase, ppr var, text "#-}"] - where - pp_phase NeverActive = empty -- NOINLINE f - pp_phase (ActiveAfter n) = pprPhase n -- NOINLINE [2] f - pp_phase AlwaysActive = text "ALWAYS?" -- Unexpected + = hsep [text "{-# NOINLINE", ppr phase, ppr var, text "#-}"] ppr_sig (SpecInstSig ty _) = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"] diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index 447f261..55e0de0 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.81 2001/12/21 10:24:24 simonmar Exp $ +$Id: Parser.y,v 1.82 2002/01/29 09:58:18 simonpj Exp $ Haskell grammar. @@ -459,11 +459,15 @@ rule :: { RdrBinding } activation :: { Activation } -- Omitted means AlwaysActive : {- empty -} { AlwaysActive } - | '[' INTEGER ']' { ActiveAfter (fromInteger $2) } + | explicit_activation { $1 } inverse_activation :: { Activation } -- Omitted means NeverActive : {- empty -} { NeverActive } - | '[' INTEGER ']' { ActiveAfter (fromInteger $2) } + | explicit_activation { $1 } + +explicit_activation :: { Activation } -- In brackets + : '[' INTEGER ']' { ActiveAfter (fromInteger $2) } + | '[' '~' INTEGER ']' { ActiveBefore (fromInteger $3) } rule_forall :: { [RdrNameRuleBndr] } : 'forall' rule_var_list '.' { $2 } diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index 17920c9..72cd65c 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -159,7 +159,6 @@ knownKeyNames mapName, appendName, unpackCStringName, - unpackCStringListName, unpackCStringAppendName, unpackCStringFoldrName, unpackCStringUtf8Name, @@ -388,7 +387,6 @@ eqStringName = varQual pREL_BASE_Name SLIT("eqString") eqStringIdKey -- Strings unpackCStringName = varQual pREL_BASE_Name SLIT("unpackCString#") unpackCStringIdKey -unpackCStringListName = varQual pREL_BASE_Name SLIT("unpackCStringList#") unpackCStringListIdKey unpackCStringAppendName = varQual pREL_BASE_Name SLIT("unpackAppendCString#") unpackCStringAppendIdKey unpackCStringFoldrName = varQual pREL_BASE_Name SLIT("unpackFoldrCString#") unpackCStringFoldrIdKey unpackCStringUtf8Name = varQual pREL_BASE_Name SLIT("unpackCStringUtf8#") unpackCStringUtf8IdKey @@ -857,7 +855,6 @@ plusIntegerIdKey = mkPreludeMiscIdUnique 41 timesIntegerIdKey = mkPreludeMiscIdUnique 42 printIdKey = mkPreludeMiscIdUnique 43 failIOIdKey = mkPreludeMiscIdUnique 44 -unpackCStringListIdKey = mkPreludeMiscIdUnique 45 nullAddrIdKey = mkPreludeMiscIdUnique 46 voidArgIdKey = mkPreludeMiscIdUnique 47 splitIdKey = mkPreludeMiscIdUnique 48 diff --git a/ghc/compiler/prelude/PrelRules.lhs b/ghc/compiler/prelude/PrelRules.lhs index c916e63..0ebec4f 100644 --- a/ghc/compiler/prelude/PrelRules.lhs +++ b/ghc/compiler/prelude/PrelRules.lhs @@ -38,7 +38,7 @@ import CoreUtils ( exprIsValue, cheapEqExpr, exprIsConApp_maybe ) import Type ( tyConAppTyCon, eqType ) import OccName ( occNameUserString) import PrelNames ( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey, - eqStringName, unpackCStringListIdKey ) + eqStringName, unpackCStringIdKey ) import Name ( Name ) import Bits ( Bits(..) ) #if __GLASGOW_HASKELL__ >= 500 @@ -485,12 +485,12 @@ match_append_lit [Type ty1, match_append_lit other = Nothing -- The rule is this: --- eqString (unpackCStringList# (Lit s1)) (unpackCStringList# (Lit s2) = s1==s2 +-- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2 match_eq_string [Var unpk1 `App` Lit (MachStr s1), Var unpk2 `App` Lit (MachStr s2)] - | unpk1 `hasKey` unpackCStringListIdKey, - unpk2 `hasKey` unpackCStringListIdKey + | unpk1 `hasKey` unpackCStringIdKey, + unpk2 `hasKey` unpackCStringIdKey = Just (if s1 == s2 then trueVal else falseVal) match_eq_string other = Nothing diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index 1967e49..81771f9 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -155,6 +155,7 @@ import FastString ( tailFS ) '<-' { ITlarrow } '->' { ITrarrow } '@' { ITat } + '~' { ITtilde } '=>' { ITdarrow } '-' { ITminus } '!' { ITbang } @@ -428,6 +429,7 @@ rule : src_loc STRING activation rule_forall qvar_name activation :: { Activation } activation : {- empty -} { AlwaysActive } | '[' INTEGER ']' { ActiveAfter (fromInteger $2) } + | '[' '~' INTEGER ']' { ActiveBefore (fromInteger $3) } rule_forall :: { [UfBinder RdrName] } rule_forall : '__forall' '{' core_bndrs '}' { $3 } diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs index e76d267..021ee87 100644 --- a/ghc/compiler/simplCore/OccurAnal.lhs +++ b/ghc/compiler/simplCore/OccurAnal.lhs @@ -195,6 +195,9 @@ shortMeOut ind_env exported_id local_id not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for then + True + +{- No longer needed if shortableIdInfo (idInfo exported_id) -- Only if its IdInfo is 'shortable' -- (see the defn of IdInfo.shortableIdInfo) then True @@ -203,6 +206,7 @@ shortMeOut ind_env exported_id local_id pprTrace "shortMeOut:" (ppr exported_id) #endif False +-} else False \end{code} diff --git a/ghc/lib/std/PrelBase.lhs b/ghc/lib/std/PrelBase.lhs index dbff5aa..21ecfe0 100644 --- a/ghc/lib/std/PrelBase.lhs +++ b/ghc/lib/std/PrelBase.lhs @@ -1,5 +1,5 @@ % ----------------------------------------------------------------------------- -% $Id: PrelBase.lhs,v 1.59 2001/12/14 17:24:19 simonpj Exp $ +% $Id: PrelBase.lhs,v 1.60 2002/01/29 09:58:19 simonpj Exp $ % % (c) The University of Glasgow, 1992-2000 % @@ -272,8 +272,10 @@ augment g xs = g (:) xs "foldr/augment" forall k z xs (g::forall b. (a->b->b) -> b -> b) . foldr k z (augment g xs) = g k (foldr k z xs) -"foldr/id" foldr (:) [] = \x->x -"foldr/app" forall xs ys. foldr (:) ys xs = append xs ys +"foldr/id" foldr (:) [] = \x->x +"foldr/app" [1] forall xs ys. foldr (:) ys xs = xs ++ ys + -- Only activate this from phase 1, because that's + -- when we disable the rule that expands (++) into foldr -- The foldr/cons rule looks nice, but it can give disastrously -- bloated code when commpiling @@ -304,21 +306,36 @@ augment g xs = g (:) xs \begin{code} map :: (a -> b) -> [a] -> [b] -{-# NOINLINE [1] map #-} -map = mapList +map _ [] = [] +map f (x:xs) = f x : map f xs -- Note eta expanded mapFB :: (elt -> lst -> lst) -> (a -> elt) -> a -> lst -> lst +{-# INLINE [0] mapFB #-} mapFB c f x ys = c (f x) ys -mapList :: (a -> b) -> [a] -> [b] -mapList _ [] = [] -mapList f (x:xs) = f x : mapList f xs +-- The rules for map work like this. +-- +-- Up to (but not including) phase 1, we use the "map" rule to +-- rewrite all saturated applications of map with its build/fold +-- form, hoping for fusion to happen. +-- In phase 1 and 0, we switch off that rule, inline build, and +-- switch on the "mapList" rule, which rewrites the foldr/mapFB +-- thing back into plain map. +-- +-- It's important that these two rules aren't both active at once +-- (along with build's unfolding) else we'd get an infinite loop +-- in the rules. Hence the activation control below. +-- +-- The "mapFB" rule optimises compositions of map. +-- +-- This same pattern is followed by many other functions: +-- e.g. append, filter, iterate, repeat, etc. {-# RULES -"map" forall f xs. map f xs = build (\c n -> foldr (mapFB c f) n xs) +"map" [~1] forall f xs. map f xs = build (\c n -> foldr (mapFB c f) n xs) +"mapList" [1] forall f. foldr (mapFB (:) f) [] = map f "mapFB" forall c f g. mapFB (mapFB c f) g = mapFB c (f.g) -"mapList" forall f. foldr (mapFB (:) f) [] = mapList f #-} \end{code} @@ -328,16 +345,13 @@ mapList f (x:xs) = f x : mapList f xs ---------------------------------------------- \begin{code} (++) :: [a] -> [a] -> [a] -{-# NOINLINE [1] (++) #-} -(++) = append +(++) [] ys = ys +(++) (x:xs) ys = x : xs ++ ys {-# RULES -"++" forall xs ys. xs ++ ys = augment (\c n -> foldr c n xs) ys +"++" [~1] forall xs ys. xs ++ ys = augment (\c n -> foldr c n xs) ys #-} -append :: [a] -> [a] -> [a] -append [] ys = ys -append (x:xs) ys = x : append xs ys \end{code} @@ -802,9 +816,9 @@ unpackNBytes# addr len# = unpack [] (len# -# 1#) ch -> unpack (C# ch : acc) (i# -# 1#) {-# RULES -"unpack" forall a . unpackCString# a = build (unpackFoldrCString# a) -"unpack-list" forall a . unpackFoldrCString# a (:) [] = unpackCStringList# a -"unpack-append" forall a n . unpackFoldrCString# a (:) n = unpackAppendCString# a n +"unpack" [~1] forall a . unpackCString# a = build (unpackFoldrCString# a) +"unpack-list" [1] forall a . unpackFoldrCString# a (:) [] = unpackCStringList# a +"unpack-append" forall a n . unpackFoldrCString# a (:) n = unpackAppendCString# a n -- There's a built-in rule (in PrelRules.lhs) for -- unpackFoldr "foo" c (unpackFoldr "baz" c n) = unpackFoldr "foobaz" c n diff --git a/ghc/lib/std/PrelEnum.lhs b/ghc/lib/std/PrelEnum.lhs index 5ede58a..5bcf0ac 100644 --- a/ghc/lib/std/PrelEnum.lhs +++ b/ghc/lib/std/PrelEnum.lhs @@ -1,5 +1,5 @@ % ----------------------------------------------------------------------------- -% $Id: PrelEnum.lhs,v 1.17 2001/09/26 15:12:37 simonpj Exp $ +% $Id: PrelEnum.lhs,v 1.18 2002/01/29 09:58:19 simonpj Exp $ % % (c) The University of Glasgow, 1992-2001 % @@ -204,20 +204,13 @@ instance Enum Char where {-# INLINE enumFromThenTo #-} enumFromThenTo (C# x1) (C# x2) (C# y) = efdtChar (ord# x1) (ord# x2) (ord# y) -{-# NOINLINE [1] eftChar #-} -{-# NOINLINE [1] efdChar #-} -{-# NOINLINE [1] efdtChar #-} -eftChar = eftCharList -efdChar = efdCharList -efdtChar = efdtCharList - {-# RULES -"eftChar" forall x y. eftChar x y = build (\c n -> eftCharFB c n x y) -"efdChar" forall x1 x2. efdChar x1 x2 = build (\ c n -> efdCharFB c n x1 x2) -"efdtChar" forall x1 x2 l. efdtChar x1 x2 l = build (\ c n -> efdtCharFB c n x1 x2 l) -"eftCharList" eftCharFB (:) [] = eftCharList -"efdCharList" efdCharFB (:) [] = efdCharList -"efdtCharList" efdtCharFB (:) [] = efdtCharList +"eftChar" [~1] forall x y. eftChar x y = build (\c n -> eftCharFB c n x y) +"efdChar" [~1] forall x1 x2. efdChar x1 x2 = build (\ c n -> efdCharFB c n x1 x2) +"efdtChar" [~1] forall x1 x2 l. efdtChar x1 x2 l = build (\ c n -> efdtCharFB c n x1 x2 l) +"eftCharList" [1] eftCharFB (:) [] = eftChar +"efdCharList" [1] efdCharFB (:) [] = efdChar +"efdtCharList" [1] efdtCharFB (:) [] = efdtChar #-} @@ -229,8 +222,8 @@ eftCharFB c n x y = go x go x | x ># y = n | otherwise = C# (chr# x) `c` go (x +# 1#) -eftCharList x y | x ># y = [] - | otherwise = C# (chr# x) : eftCharList (x +# 1#) y +eftChar x y | x ># y = [] + | otherwise = C# (chr# x) : eftChar (x +# 1#) y -- For enumFromThenTo we give up on inlining @@ -241,7 +234,7 @@ efdCharFB c n x1 x2 where delta = x2 -# x1 -efdCharList x1 x2 +efdChar x1 x2 | delta >=# 0# = go_up_char_list x1 delta 0x10FFFF# | otherwise = go_dn_char_list x1 delta 0# where @@ -254,7 +247,7 @@ efdtCharFB c n x1 x2 lim where delta = x2 -# x1 -efdtCharList x1 x2 lim +efdtChar x1 x2 lim | delta >=# 0# = go_up_char_list x1 delta lim | otherwise = go_dn_char_list x1 delta lim where @@ -329,21 +322,14 @@ instance Enum Int where {-# INLINE enumFromThenTo #-} enumFromThenTo (I# x1) (I# x2) (I# y) = efdtInt x1 x2 y -{-# NOINLINE [1] eftInt #-} -{-# NOINLINE [1] efdInt #-} -{-# NOINLINE [1] efdtInt #-} -eftInt = eftIntList -efdInt = efdIntList -efdtInt = efdtIntList - {-# RULES -"eftInt" forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y) -"efdInt" forall x1 x2. efdInt x1 x2 = build (\ c n -> efdIntFB c n x1 x2) -"efdtInt" forall x1 x2 l. efdtInt x1 x2 l = build (\ c n -> efdtIntFB c n x1 x2 l) +"eftInt" [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y) +"efdInt" [~1] forall x1 x2. efdInt x1 x2 = build (\ c n -> efdIntFB c n x1 x2) +"efdtInt" [~1] forall x1 x2 l. efdtInt x1 x2 l = build (\ c n -> efdtIntFB c n x1 x2 l) -"eftIntList" eftIntFB (:) [] = eftIntList -"efdIntList" efdIntFB (:) [] = efdIntList -"efdtIntList" efdtIntFB (:) [] = efdtIntList +"eftIntList" [1] eftIntFB (:) [] = eftInt +"efdIntList" [1] efdIntFB (:) [] = efdInt +"efdtIntList" [1] efdtIntFB (:) [] = efdtInt #-} @@ -357,7 +343,7 @@ eftIntFB c n x y | x ># y = n -- so that when eftInfFB is inlined we can inline -- whatver is bound to "c" -eftIntList x y | x ># y = [] +eftInt x y | x ># y = [] | otherwise = go x where go x = I# x : if x ==# y then [] else go (x +# 1#) @@ -373,7 +359,7 @@ efdtIntFB c n x1 x2 y delta = x2 -# x1 lim = y -# delta -efdtIntList x1 x2 y +efdtInt x1 x2 y | delta >=# 0# = if x1 ># y then [] else go_up_int_list x1 delta lim | otherwise = if x1 <# y then [] else go_dn_int_list x1 delta lim where @@ -387,7 +373,7 @@ efdIntFB c n x1 x2 where delta = x2 -# x1 -efdIntList x1 x2 +efdInt x1 x2 | delta >=# 0# = case maxInt of I# y -> go_up_int_list x1 delta (y -# delta) | otherwise = case minInt of I# y -> go_dn_int_list x1 delta (y -# delta) where diff --git a/ghc/lib/std/PrelList.lhs b/ghc/lib/std/PrelList.lhs index c4b5336..02e0cf0 100644 --- a/ghc/lib/std/PrelList.lhs +++ b/ghc/lib/std/PrelList.lhs @@ -1,5 +1,5 @@ % ------------------------------------------------------------------------------ -% $Id: PrelList.lhs,v 1.28 2001/09/26 15:12:37 simonpj Exp $ +% $Id: PrelList.lhs,v 1.29 2002/01/29 09:58:21 simonpj Exp $ % % (c) The University of Glasgow, 1994-2000 % @@ -118,18 +118,20 @@ length l = len l 0# -- filter, applied to a predicate and a list, returns the list of those -- elements that satisfy the predicate; i.e., -- filter p xs = [ x | x <- xs, p x] -{-# NOINLINE [1] filter #-} filter :: (a -> Bool) -> [a] -> [a] -filter = filterList +filter _pred [] = [] +filter pred (x:xs) + | pred x = x : filter pred xs + | otherwise = filter pred xs -{-# INLINE [0] filter #-} +{-# NOINLINE [0] filterFB #-} filterFB c p x r | p x = x `c` r | otherwise = r {-# RULES -"filter" forall p xs. filter p xs = build (\c n -> foldr (filterFB c p) n xs) -"filterFB" forall c p q. filterFB (filterFB c p) q = filterFB c (\x -> q x && p x) -"filterList" forall p. foldr (filterFB (:) p) [] = filterList p +"filter" [~1] forall p xs. filter p xs = build (\c n -> foldr (filterFB c p) n xs) +"filterList" [1] forall p. foldr (filterFB (:) p) [] = filter p +"filterFB" forall c p q. filterFB (filterFB c p) q = filterFB c (\x -> q x && p x) #-} -- Note the filterFB rule, which has p and q the "wrong way round" in the RHS. @@ -141,11 +143,6 @@ filterFB c p x r | p x = x `c` r -- I originally wrote (\x -> p x && q x), which is wrong, and actually -- gave rise to a live bug report. SLPJ. -filterList :: (a -> Bool) -> [a] -> [a] -filterList _pred [] = [] -filterList pred (x:xs) - | pred x = x : filterList pred xs - | otherwise = filterList pred xs -- foldl, applied to a binary operator, a starting value (typically the -- left-identity of the operator), and a list, reduces the list using @@ -204,32 +201,30 @@ scanr1 f (x:xs) = f x q : qs -- iterate f x returns an infinite list of repeated applications of f to x: -- iterate f x == [x, f x, f (f x), ...] iterate :: (a -> a) -> a -> [a] -{-# NOINLINE [1] iterate #-} -iterate = iterateList +iterate f x = x : iterate f (f x) iterateFB c f x = x `c` iterateFB c f (f x) -iterateList f x = x : iterateList f (f x) {-# RULES -"iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x) -"iterateFB" iterateFB (:) = iterateList +"iterate" [~1] forall f x. iterate f x = build (\c _n -> iterateFB c f x) +"iterateFB" [1] iterateFB (:) = iterate #-} -- repeat x is an infinite list, with x the value of every element. repeat :: a -> [a] -{-# NOINLINE [1] repeat #-} -repeat = repeatList +{-# INLINE [0] repeat #-} +-- The pragma just gives the rules more chance to fire +repeat x = xs where xs = x : xs -{-# INLINE [0] repeatFB #-} +{-# INLINE [0] repeatFB #-} -- ditto repeatFB c x = xs where xs = x `c` xs -repeatList x = xs where xs = x : xs {-# RULES -"repeat" forall x. repeat x = build (\c _n -> repeatFB c x) -"repeatFB" repeatFB (:) = repeatList +"repeat" [~1] forall x. repeat x = build (\c _n -> repeatFB c x) +"repeatFB" [1] repeatFB (:) = repeat #-} -- replicate n x is a list of length n with x the value of every element @@ -445,7 +440,9 @@ concat = foldr (++) [] {-# RULES "concat" forall xs. concat xs = build (\c n -> foldr (\x y -> foldr c y x) n xs) +-- We don't bother to turn non-fusible applications of concat back into concat #-} + \end{code} @@ -520,20 +517,15 @@ tuples are in the List module. \begin{code} ---------------------------------------------- zip :: [a] -> [b] -> [(a,b)] -{-# NOINLINE [1] zip #-} -zip = zipList +zip (a:as) (b:bs) = (a,b) : zip as bs +zip _ _ = [] {-# INLINE [0] zipFB #-} zipFB c x y r = (x,y) `c` r - -zipList :: [a] -> [b] -> [(a,b)] -zipList (a:as) (b:bs) = (a,b) : zipList as bs -zipList _ _ = [] - {-# RULES -"zip" forall xs ys. zip xs ys = build (\c n -> foldr2 (zipFB c) n xs ys) -"zipList" foldr2 (zipFB (:)) [] = zipList +"zip" [~1] forall xs ys. zip xs ys = build (\c n -> foldr2 (zipFB c) n xs ys) +"zipList" [1] foldr2 (zipFB (:)) [] = zip #-} \end{code} @@ -556,19 +548,15 @@ zip3 _ _ _ = [] \begin{code} ---------------------------------------------- zipWith :: (a->b->c) -> [a]->[b]->[c] -{-# NOINLINE [1] zipWith #-} -zipWith = zipWithList +zipWith f (a:as) (b:bs) = f a b : zipWith f as bs +zipWith _ _ _ = [] {-# INLINE [0] zipWithFB #-} 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 _ _ _ = [] - {-# RULES -"zipWith" forall f xs ys. zipWith f xs ys = build (\c n -> foldr2 (zipWithFB c f) n xs ys) -"zipWithList" forall f. foldr2 (zipWithFB (:) f) [] = zipWithList f +"zipWith" [~1] forall f xs ys. zipWith f xs ys = build (\c n -> foldr2 (zipWithFB c f) n xs ys) +"zipWithList" [1] forall f. foldr2 (zipWithFB (:) f) [] = zipWith f #-} \end{code} diff --git a/ghc/lib/std/PrelNum.lhs b/ghc/lib/std/PrelNum.lhs index 157a423..49bf878 100644 --- a/ghc/lib/std/PrelNum.lhs +++ b/ghc/lib/std/PrelNum.lhs @@ -1,5 +1,5 @@ % ------------------------------------------------------------------------------ -% $Id: PrelNum.lhs,v 1.45 2001/12/18 15:23:16 sewardj Exp $ +% $Id: PrelNum.lhs,v 1.46 2002/01/29 09:58:21 simonpj Exp $ % % (c) The University of Glasgow, 1994-2000 % @@ -382,33 +382,29 @@ instance Enum Integer where {-# INLINE enumFromThen #-} {-# INLINE enumFromTo #-} {-# INLINE enumFromThenTo #-} - enumFrom x = efdInteger x 1 - enumFromThen x y = efdInteger x (y-x) - enumFromTo x lim = efdtInteger x 1 lim - enumFromThenTo x y lim = efdtInteger x (y-x) lim - - -efdInteger = enumDeltaIntegerList -efdtInteger = enumDeltaToIntegerList + enumFrom x = enumDeltaInteger x 1 + enumFromThen x y = enumDeltaInteger x (y-x) + enumFromTo x lim = enumDeltaToInteger x 1 lim + enumFromThenTo x y lim = enumDeltaToInteger x (y-x) lim {-# RULES -"efdInteger" forall x y. efdInteger x y = build (\c _ -> enumDeltaIntegerFB c x y) -"efdtInteger" forall x y l.efdtInteger x y l = build (\c n -> enumDeltaToIntegerFB c n x y l) -"enumDeltaInteger" enumDeltaIntegerFB (:) = enumDeltaIntegerList -"enumDeltaToInteger" enumDeltaToIntegerFB (:) [] = enumDeltaToIntegerList +"enumDeltaInteger" [~1] forall x y. enumDeltaInteger x y = build (\c _ -> enumDeltaIntegerFB c x y) +"efdtInteger" [~1] forall x y l.enumDeltaToInteger x y l = build (\c n -> enumDeltaToIntegerFB c n x y l) +"enumDeltaInteger" [1] enumDeltaIntegerFB (:) = enumDeltaInteger +"enumDeltaToInteger" [1] enumDeltaToIntegerFB (:) [] = enumDeltaToInteger #-} enumDeltaIntegerFB :: (Integer -> b -> b) -> Integer -> Integer -> b enumDeltaIntegerFB c x d = x `c` enumDeltaIntegerFB c (x+d) d -enumDeltaIntegerList :: Integer -> Integer -> [Integer] -enumDeltaIntegerList x d = x : enumDeltaIntegerList (x+d) d +enumDeltaInteger :: Integer -> Integer -> [Integer] +enumDeltaInteger x d = x : enumDeltaInteger (x+d) d enumDeltaToIntegerFB c n x delta lim | delta >= 0 = up_fb c n x delta lim | otherwise = dn_fb c n x delta lim -enumDeltaToIntegerList x delta lim +enumDeltaToInteger x delta lim | delta >= 0 = up_list x delta lim | otherwise = dn_list x delta lim -- 1.7.10.4