StrictnessMark(..), isMarkedUnboxed, isMarkedStrict,
- CompilerPhase, pprPhase,
+ CompilerPhase,
Activation(..), isActive, isNeverActive, isAlwaysActive
) where
-- 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
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 )
= 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 "#-}"]
{-
-----------------------------------------------------------------------------
-$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.
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 }
mapName,
appendName,
unpackCStringName,
- unpackCStringListName,
unpackCStringAppendName,
unpackCStringFoldrName,
unpackCStringUtf8Name,
-- 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
timesIntegerIdKey = mkPreludeMiscIdUnique 42
printIdKey = mkPreludeMiscIdUnique 43
failIOIdKey = mkPreludeMiscIdUnique 44
-unpackCStringListIdKey = mkPreludeMiscIdUnique 45
nullAddrIdKey = mkPreludeMiscIdUnique 46
voidArgIdKey = mkPreludeMiscIdUnique 47
splitIdKey = mkPreludeMiscIdUnique 48
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
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
'<-' { ITlarrow }
'->' { ITrarrow }
'@' { ITat }
+ '~' { ITtilde }
'=>' { ITdarrow }
'-' { ITminus }
'!' { ITbang }
activation :: { Activation }
activation : {- empty -} { AlwaysActive }
| '[' INTEGER ']' { ActiveAfter (fromInteger $2) }
+ | '[' '~' INTEGER ']' { ActiveBefore (fromInteger $3) }
rule_forall :: { [UfBinder RdrName] }
rule_forall : '__forall' '{' core_bndrs '}' { $3 }
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
pprTrace "shortMeOut:" (ppr exported_id)
#endif
False
+-}
else
False
\end{code}
% -----------------------------------------------------------------------------
-% $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
%
"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
\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}
----------------------------------------------
\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}
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
% -----------------------------------------------------------------------------
-% $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
%
{-# 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
#-}
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
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
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
{-# 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
#-}
-- 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#)
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
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
% ------------------------------------------------------------------------------
-% $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
%
-- 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.
-- 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
-- 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
{-# 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}
\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}
\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}
% ------------------------------------------------------------------------------
-% $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
%
{-# 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
projects / ghc-hetmet.git / commitdiff