2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[ConFold]{Constant Folder}
6 Conceptually, constant folding should be parameterized with the kind
7 of target machine to get identical behaviour during compilation time
8 and runtime. We cheat a little bit here...
11 check boundaries before folding, e.g. we can fold the Float addition
12 (i1 + i2) only if it results in a valid Float.
15 {-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
17 module PrelRules ( primOpRules, builtinRules ) where
19 #include "HsVersions.h"
25 import PrimOp ( PrimOp(..), tagToEnumKey )
27 import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon )
28 import DataCon ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG )
29 import CoreUtils ( cheapEqExpr )
30 import CoreUnfold ( exprIsConApp_maybe )
32 import OccName ( occNameFS )
34 import Maybes ( orElse )
35 import Name ( Name, nameOccName )
38 import StaticFlags ( opt_SimplExcessPrecision )
41 import Data.Bits as Bits
42 import Data.Int ( Int64 )
43 import Data.Word ( Word, Word64 )
47 Note [Constant folding]
48 ~~~~~~~~~~~~~~~~~~~~~~~
49 primOpRules generates the rewrite rules for each primop
50 These rules do what is often called "constant folding"
51 E.g. the rules for +# might say
53 Well, of course you'd need a lot of rules if you did it
54 like that, so we use a BuiltinRule instead, so that we
55 can match in any two literal values. So the rule is really
57 (Lit 4) +# (Lit y) = Lit (x+#y)
58 where the (+#) on the rhs is done at compile time
60 That is why these rules are built in here. Other rules
61 which don't need to be built in are in GHC.Base. For
67 primOpRules :: PrimOp -> Name -> [CoreRule]
68 primOpRules op op_name = primop_rule op
71 one_lit = oneLit op_name
72 two_lits = twoLits op_name
73 relop cmp = two_lits (cmpOp (\ord -> ord `cmp` EQ))
74 -- Cunning. cmpOp compares the values to give an Ordering.
75 -- It applies its argument to that ordering value to turn
76 -- the ordering into a boolean value. (`cmp` EQ) is just the job.
78 -- ToDo: something for integer-shift ops?
81 primop_rule TagToEnumOp = mkBasicRule op_name 2 tagToEnumRule
82 primop_rule DataToTagOp = mkBasicRule op_name 2 dataToTagRule
85 primop_rule IntAddOp = two_lits (intOp2 (+))
86 primop_rule IntSubOp = two_lits (intOp2 (-))
87 primop_rule IntMulOp = two_lits (intOp2 (*))
88 primop_rule IntQuotOp = two_lits (intOp2Z quot)
89 primop_rule IntRemOp = two_lits (intOp2Z rem)
90 primop_rule IntNegOp = one_lit negOp
91 primop_rule ISllOp = two_lits (intShiftOp2 Bits.shiftL)
92 primop_rule ISraOp = two_lits (intShiftOp2 Bits.shiftR)
93 primop_rule ISrlOp = two_lits (intShiftOp2 shiftRightLogical)
96 primop_rule WordAddOp = two_lits (wordOp2 (+))
97 primop_rule WordSubOp = two_lits (wordOp2 (-))
98 primop_rule WordMulOp = two_lits (wordOp2 (*))
99 primop_rule WordQuotOp = two_lits (wordOp2Z quot)
100 primop_rule WordRemOp = two_lits (wordOp2Z rem)
101 primop_rule AndOp = two_lits (wordBitOp2 (.&.))
102 primop_rule OrOp = two_lits (wordBitOp2 (.|.))
103 primop_rule XorOp = two_lits (wordBitOp2 xor)
104 primop_rule SllOp = two_lits (wordShiftOp2 Bits.shiftL)
105 primop_rule SrlOp = two_lits (wordShiftOp2 shiftRightLogical)
108 primop_rule Word2IntOp = one_lit (litCoerce word2IntLit)
109 primop_rule Int2WordOp = one_lit (litCoerce int2WordLit)
110 primop_rule Narrow8IntOp = one_lit (litCoerce narrow8IntLit)
111 primop_rule Narrow16IntOp = one_lit (litCoerce narrow16IntLit)
112 primop_rule Narrow32IntOp = one_lit (litCoerce narrow32IntLit)
113 primop_rule Narrow8WordOp = one_lit (litCoerce narrow8WordLit)
114 primop_rule Narrow16WordOp = one_lit (litCoerce narrow16WordLit)
115 primop_rule Narrow32WordOp = one_lit (litCoerce narrow32WordLit)
116 primop_rule OrdOp = one_lit (litCoerce char2IntLit)
117 primop_rule ChrOp = one_lit (predLitCoerce litFitsInChar int2CharLit)
118 primop_rule Float2IntOp = one_lit (litCoerce float2IntLit)
119 primop_rule Int2FloatOp = one_lit (litCoerce int2FloatLit)
120 primop_rule Double2IntOp = one_lit (litCoerce double2IntLit)
121 primop_rule Int2DoubleOp = one_lit (litCoerce int2DoubleLit)
122 -- SUP: Not sure what the standard says about precision in the following 2 cases
123 primop_rule Float2DoubleOp = one_lit (litCoerce float2DoubleLit)
124 primop_rule Double2FloatOp = one_lit (litCoerce double2FloatLit)
127 primop_rule FloatAddOp = two_lits (floatOp2 (+))
128 primop_rule FloatSubOp = two_lits (floatOp2 (-))
129 primop_rule FloatMulOp = two_lits (floatOp2 (*))
130 primop_rule FloatDivOp = two_lits (floatOp2Z (/))
131 primop_rule FloatNegOp = one_lit negOp
134 primop_rule DoubleAddOp = two_lits (doubleOp2 (+))
135 primop_rule DoubleSubOp = two_lits (doubleOp2 (-))
136 primop_rule DoubleMulOp = two_lits (doubleOp2 (*))
137 primop_rule DoubleDivOp = two_lits (doubleOp2Z (/))
138 primop_rule DoubleNegOp = one_lit negOp
140 -- Relational operators
141 primop_rule IntEqOp = relop (==) ++ litEq op_name True
142 primop_rule IntNeOp = relop (/=) ++ litEq op_name False
143 primop_rule CharEqOp = relop (==) ++ litEq op_name True
144 primop_rule CharNeOp = relop (/=) ++ litEq op_name False
146 primop_rule IntGtOp = relop (>) ++ boundsCmp op_name Gt
147 primop_rule IntGeOp = relop (>=) ++ boundsCmp op_name Ge
148 primop_rule IntLeOp = relop (<=) ++ boundsCmp op_name Le
149 primop_rule IntLtOp = relop (<) ++ boundsCmp op_name Lt
151 primop_rule CharGtOp = relop (>) ++ boundsCmp op_name Gt
152 primop_rule CharGeOp = relop (>=) ++ boundsCmp op_name Ge
153 primop_rule CharLeOp = relop (<=) ++ boundsCmp op_name Le
154 primop_rule CharLtOp = relop (<) ++ boundsCmp op_name Lt
156 primop_rule FloatGtOp = relop (>)
157 primop_rule FloatGeOp = relop (>=)
158 primop_rule FloatLeOp = relop (<=)
159 primop_rule FloatLtOp = relop (<)
160 primop_rule FloatEqOp = relop (==)
161 primop_rule FloatNeOp = relop (/=)
163 primop_rule DoubleGtOp = relop (>)
164 primop_rule DoubleGeOp = relop (>=)
165 primop_rule DoubleLeOp = relop (<=)
166 primop_rule DoubleLtOp = relop (<)
167 primop_rule DoubleEqOp = relop (==)
168 primop_rule DoubleNeOp = relop (/=)
170 primop_rule WordGtOp = relop (>) ++ boundsCmp op_name Gt
171 primop_rule WordGeOp = relop (>=) ++ boundsCmp op_name Ge
172 primop_rule WordLeOp = relop (<=) ++ boundsCmp op_name Le
173 primop_rule WordLtOp = relop (<) ++ boundsCmp op_name Lt
174 primop_rule WordEqOp = relop (==)
175 primop_rule WordNeOp = relop (/=)
182 %************************************************************************
184 \subsection{Doing the business}
186 %************************************************************************
188 ToDo: the reason these all return Nothing is because there used to be
189 the possibility of an argument being a litlit. Litlits are now gone,
190 so this could be cleaned up.
193 --------------------------
194 litCoerce :: (Literal -> Literal) -> Literal -> Maybe CoreExpr
195 litCoerce fn lit = Just (Lit (fn lit))
197 predLitCoerce :: (Literal -> Bool) -> (Literal -> Literal) -> Literal -> Maybe CoreExpr
198 predLitCoerce p fn lit
199 | p lit = Just (Lit (fn lit))
200 | otherwise = Nothing
202 --------------------------
203 cmpOp :: (Ordering -> Bool) -> Literal -> Literal -> Maybe CoreExpr
207 done res | cmp res = Just trueVal
208 | otherwise = Just falseVal
210 -- These compares are at different types
211 go (MachChar i1) (MachChar i2) = done (i1 `compare` i2)
212 go (MachInt i1) (MachInt i2) = done (i1 `compare` i2)
213 go (MachInt64 i1) (MachInt64 i2) = done (i1 `compare` i2)
214 go (MachWord i1) (MachWord i2) = done (i1 `compare` i2)
215 go (MachWord64 i1) (MachWord64 i2) = done (i1 `compare` i2)
216 go (MachFloat i1) (MachFloat i2) = done (i1 `compare` i2)
217 go (MachDouble i1) (MachDouble i2) = done (i1 `compare` i2)
220 --------------------------
222 negOp :: Literal -> Maybe CoreExpr -- Negate
223 negOp (MachFloat 0.0) = Nothing -- can't represent -0.0 as a Rational
224 negOp (MachFloat f) = Just (mkFloatVal (-f))
225 negOp (MachDouble 0.0) = Nothing
226 negOp (MachDouble d) = Just (mkDoubleVal (-d))
227 negOp (MachInt i) = intResult (-i)
230 --------------------------
231 intOp2 :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
232 intOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` i2)
233 intOp2 _ _ _ = Nothing -- Could find LitLit
235 intOp2Z :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
236 -- Like intOp2, but Nothing if i2=0
237 intOp2Z op (MachInt i1) (MachInt i2)
238 | i2 /= 0 = intResult (i1 `op` i2)
239 intOp2Z _ _ _ = Nothing -- LitLit or zero dividend
241 intShiftOp2 :: (Integer->Int->Integer) -> Literal -> Literal -> Maybe CoreExpr
242 -- Shifts take an Int; hence second arg of op is Int
243 intShiftOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` fromInteger i2)
244 intShiftOp2 _ _ _ = Nothing
246 shiftRightLogical :: Integer -> Int -> Integer
247 -- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do
248 -- Do this by converting to Word and back. Obviously this won't work for big
249 -- values, but its ok as we use it here
250 shiftRightLogical x n = fromIntegral (fromInteger x `shiftR` n :: Word)
253 --------------------------
254 wordOp2 :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
255 wordOp2 op (MachWord w1) (MachWord w2)
256 = wordResult (w1 `op` w2)
257 wordOp2 _ _ _ = Nothing -- Could find LitLit
259 wordOp2Z :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
260 wordOp2Z op (MachWord w1) (MachWord w2)
261 | w2 /= 0 = wordResult (w1 `op` w2)
262 wordOp2Z _ _ _ = Nothing -- LitLit or zero dividend
264 wordBitOp2 :: (Integer->Integer->Integer) -> Literal -> Literal
266 wordBitOp2 op (MachWord w1) (MachWord w2)
267 = wordResult (w1 `op` w2)
268 wordBitOp2 _ _ _ = Nothing -- Could find LitLit
270 wordShiftOp2 :: (Integer->Int->Integer) -> Literal -> Literal -> Maybe CoreExpr
271 -- Shifts take an Int; hence second arg of op is Int
272 wordShiftOp2 op (MachWord x) (MachInt n)
273 = wordResult (x `op` fromInteger n)
274 -- Do the shift at type Integer
275 wordShiftOp2 _ _ _ = Nothing
277 --------------------------
278 floatOp2 :: (Rational -> Rational -> Rational) -> Literal -> Literal
279 -> Maybe (Expr CoreBndr)
280 floatOp2 op (MachFloat f1) (MachFloat f2)
281 = Just (mkFloatVal (f1 `op` f2))
282 floatOp2 _ _ _ = Nothing
284 floatOp2Z :: (Rational -> Rational -> Rational) -> Literal -> Literal
285 -> Maybe (Expr CoreBndr)
286 floatOp2Z op (MachFloat f1) (MachFloat f2)
287 | (f1 /= 0 || f2 > 0) -- see Note [negative zero]
288 && f2 /= 0 -- avoid NaN and Infinity/-Infinity
289 = Just (mkFloatVal (f1 `op` f2))
290 floatOp2Z _ _ _ = Nothing
292 --------------------------
293 doubleOp2 :: (Rational -> Rational -> Rational) -> Literal -> Literal
294 -> Maybe (Expr CoreBndr)
295 doubleOp2 op (MachDouble f1) (MachDouble f2)
296 = Just (mkDoubleVal (f1 `op` f2))
297 doubleOp2 _ _ _ = Nothing
299 doubleOp2Z :: (Rational -> Rational -> Rational) -> Literal -> Literal
300 -> Maybe (Expr CoreBndr)
301 doubleOp2Z op (MachDouble f1) (MachDouble f2)
302 | (f1 /= 0 || f2 > 0) -- see Note [negative zero]
303 && f2 /= 0 -- avoid NaN and Infinity/-Infinity
304 = Just (mkDoubleVal (f1 `op` f2))
305 -- Note [negative zero] Avoid (0 / -d), otherwise 0/(-1) reduces to
306 -- zero, but we might want to preserve the negative zero here which
307 -- is representable in Float/Double but not in (normalised)
308 -- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead?
309 doubleOp2Z _ _ _ = Nothing
312 --------------------------
320 -- This is a Good Thing, because it allows case-of case things
321 -- to happen, and case-default absorption to happen. For
324 -- if (n ==# 3#) || (n ==# 4#) then e1 else e2
330 -- (modulo the usual precautions to avoid duplicating e1)
333 -> Bool -- True <=> equality, False <=> inequality
336 = [BuiltinRule { ru_name = occNameFS (nameOccName op_name)
337 `appendFS` (fsLit "->case"),
339 ru_nargs = 2, ru_try = rule_fn }]
341 rule_fn _ [Lit lit, expr] = do_lit_eq lit expr
342 rule_fn _ [expr, Lit lit] = do_lit_eq lit expr
343 rule_fn _ _ = Nothing
346 = Just (mkWildCase expr (literalType lit) boolTy
347 [(DEFAULT, [], val_if_neq),
348 (LitAlt lit, [], val_if_eq)])
349 val_if_eq | is_eq = trueVal
350 | otherwise = falseVal
351 val_if_neq | is_eq = falseVal
352 | otherwise = trueVal
355 -- | Check if there is comparison with minBound or maxBound, that is
356 -- always true or false. For instance, an Int cannot be smaller than its
357 -- minBound, so we can replace such comparison with False.
358 boundsCmp :: Name -> Comparison -> [CoreRule]
359 boundsCmp op_name op = [ rule ]
362 { ru_name = occNameFS (nameOccName op_name)
363 `appendFS` (fsLit "min/maxBound")
368 rule_fn _ [a, b] = mkRuleFn op a b
369 rule_fn _ _ = Nothing
371 data Comparison = Gt | Ge | Lt | Le
373 mkRuleFn :: Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr
374 mkRuleFn Gt (Lit lit) _ | isMinBound lit = Just falseVal
375 mkRuleFn Le (Lit lit) _ | isMinBound lit = Just trueVal
376 mkRuleFn Ge _ (Lit lit) | isMinBound lit = Just trueVal
377 mkRuleFn Lt _ (Lit lit) | isMinBound lit = Just falseVal
378 mkRuleFn Ge (Lit lit) _ | isMaxBound lit = Just trueVal
379 mkRuleFn Lt (Lit lit) _ | isMaxBound lit = Just falseVal
380 mkRuleFn Gt _ (Lit lit) | isMaxBound lit = Just falseVal
381 mkRuleFn Le _ (Lit lit) | isMaxBound lit = Just trueVal
382 mkRuleFn _ _ _ = Nothing
384 isMinBound :: Literal -> Bool
385 isMinBound (MachChar c) = c == minBound
386 isMinBound (MachInt i) = i == toInteger (minBound :: Int)
387 isMinBound (MachInt64 i) = i == toInteger (minBound :: Int64)
388 isMinBound (MachWord i) = i == toInteger (minBound :: Word)
389 isMinBound (MachWord64 i) = i == toInteger (minBound :: Word64)
392 isMaxBound :: Literal -> Bool
393 isMaxBound (MachChar c) = c == maxBound
394 isMaxBound (MachInt i) = i == toInteger (maxBound :: Int)
395 isMaxBound (MachInt64 i) = i == toInteger (maxBound :: Int64)
396 isMaxBound (MachWord i) = i == toInteger (maxBound :: Word)
397 isMaxBound (MachWord64 i) = i == toInteger (maxBound :: Word64)
401 -- Note that we *don't* warn the user about overflow. It's not done at
402 -- runtime either, and compilation of completely harmless things like
403 -- ((124076834 :: Word32) + (2147483647 :: Word32))
404 -- would yield a warning. Instead we simply squash the value into the
405 -- *target* Int/Word range.
406 intResult :: Integer -> Maybe CoreExpr
408 = Just (mkIntVal (toInteger (fromInteger result :: TargetInt)))
410 wordResult :: Integer -> Maybe CoreExpr
412 = Just (mkWordVal (toInteger (fromInteger result :: TargetWord)))
416 %************************************************************************
418 \subsection{Vaguely generic functions}
420 %************************************************************************
423 mkBasicRule :: Name -> Int
424 -> (IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr)
426 -- Gives the Rule the same name as the primop itself
427 mkBasicRule op_name n_args rule_fn
428 = [BuiltinRule { ru_name = occNameFS (nameOccName op_name),
430 ru_nargs = n_args, ru_try = rule_fn }]
432 oneLit :: Name -> (Literal -> Maybe CoreExpr)
435 = mkBasicRule op_name 1 rule_fn
437 rule_fn _ [Lit l1] = test (convFloating l1)
438 rule_fn _ _ = Nothing
440 twoLits :: Name -> (Literal -> Literal -> Maybe CoreExpr)
443 = mkBasicRule op_name 2 rule_fn
445 rule_fn _ [Lit l1, Lit l2] = test (convFloating l1) (convFloating l2)
446 rule_fn _ _ = Nothing
448 -- When excess precision is not requested, cut down the precision of the
449 -- Rational value to that of Float/Double. We confuse host architecture
450 -- and target architecture here, but it's convenient (and wrong :-).
451 convFloating :: Literal -> Literal
452 convFloating (MachFloat f) | not opt_SimplExcessPrecision =
453 MachFloat (toRational ((fromRational f) :: Float ))
454 convFloating (MachDouble d) | not opt_SimplExcessPrecision =
455 MachDouble (toRational ((fromRational d) :: Double))
458 trueVal, falseVal :: Expr CoreBndr
459 trueVal = Var trueDataConId
460 falseVal = Var falseDataConId
461 mkIntVal :: Integer -> Expr CoreBndr
462 mkIntVal i = Lit (mkMachInt i)
463 mkWordVal :: Integer -> Expr CoreBndr
464 mkWordVal w = Lit (mkMachWord w)
465 mkFloatVal :: Rational -> Expr CoreBndr
466 mkFloatVal f = Lit (convFloating (MachFloat f))
467 mkDoubleVal :: Rational -> Expr CoreBndr
468 mkDoubleVal d = Lit (convFloating (MachDouble d))
472 %************************************************************************
474 \subsection{Special rules for seq, tagToEnum, dataToTag}
476 %************************************************************************
480 Nasty check to ensure that tagToEnum# is applied to a type that is an
481 enumeration TyCon. Unification may refine the type later, but this
482 check won't see that, alas. It's crude but it works.
484 Here's are two cases that should fail
486 f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable
489 g = tagToEnum# 0 -- Int is not an enumeration
491 We used to make this check in the type inference engine, but it's quite
492 ugly to do so, because the delayed constraint solving means that we don't
493 really know what's going on until the end. It's very much a corner case
494 because we don't expect the user to call tagToEnum# at all; we merely
495 generate calls in derived instances of Enum. So we compromise: a
496 rewrite rule rewrites a bad instance of tagToEnum# to an error call,
500 tagToEnumRule :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
501 -- If data T a = A | B | C
502 -- then tag2Enum# (T ty) 2# --> B ty
503 tagToEnumRule _ [Type ty, Lit (MachInt i)]
504 | Just (tycon, tc_args) <- splitTyConApp_maybe ty
505 , isEnumerationTyCon tycon
506 = case filter correct_tag (tyConDataCons_maybe tycon `orElse` []) of
507 [] -> Nothing -- Abstract type
508 (dc:rest) -> ASSERT( null rest )
509 Just (mkTyApps (Var (dataConWorkId dc)) tc_args)
510 | otherwise -- See Note [tagToEnum#]
511 = WARN( True, ptext (sLit "tagToEnum# on non-enumeration type") <+> ppr ty )
512 Just (mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type")
514 correct_tag dc = (dataConTag dc - fIRST_TAG) == tag
517 tagToEnumRule _ _ = Nothing
521 For dataToTag#, we can reduce if either
523 (a) the argument is a constructor
524 (b) the argument is a variable whose unfolding is a known constructor
527 dataToTagRule :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Arg CoreBndr)
528 dataToTagRule _ [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag]
529 | tag_to_enum `hasKey` tagToEnumKey
530 , ty1 `coreEqType` ty2
531 = Just tag -- dataToTag (tagToEnum x) ==> x
533 dataToTagRule id_unf [_, val_arg]
534 | Just (dc,_,_) <- exprIsConApp_maybe id_unf val_arg
535 = ASSERT( not (isNewTyCon (dataConTyCon dc)) )
536 Just (mkIntVal (toInteger (dataConTag dc - fIRST_TAG)))
538 dataToTagRule _ _ = Nothing
541 %************************************************************************
543 \subsection{Built in rules}
545 %************************************************************************
547 Note [Scoping for Builtin rules]
548 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
549 When compiling a (base-package) module that defines one of the
550 functions mentioned in the RHS of a built-in rule, there's a danger
553 f = ...(eq String x)....
555 ....and lower down...
559 Then a rewrite would give
561 f = ...(eqString x)...
562 ....and lower down...
565 and lo, eqString is not in scope. This only really matters when we get to code
566 generation. With -O we do a GlomBinds step that does a new SCC analysis on the whole
567 set of bindings, which sorts out the dependency. Without -O we don't do any rule
568 rewriting so again we are fine.
570 (This whole thing doesn't show up for non-built-in rules because their dependencies
575 builtinRules :: [CoreRule]
576 -- Rules for non-primops that can't be expressed using a RULE pragma
578 = [ BuiltinRule { ru_name = fsLit "AppendLitString", ru_fn = unpackCStringFoldrName,
579 ru_nargs = 4, ru_try = match_append_lit },
580 BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,
581 ru_nargs = 2, ru_try = match_eq_string },
582 BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,
583 ru_nargs = 2, ru_try = match_inline }
587 ---------------------------------------------------
589 -- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)
590 -- = unpackFoldrCString# "foobaz" c n
592 match_append_lit :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
593 match_append_lit _ [Type ty1,
596 Var unpk `App` Type ty2
597 `App` Lit (MachStr s2)
601 | unpk `hasKey` unpackCStringFoldrIdKey &&
603 = ASSERT( ty1 `coreEqType` ty2 )
604 Just (Var unpk `App` Type ty1
605 `App` Lit (MachStr (s1 `appendFS` s2))
609 match_append_lit _ _ = Nothing
611 ---------------------------------------------------
613 -- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2
615 match_eq_string :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
616 match_eq_string _ [Var unpk1 `App` Lit (MachStr s1),
617 Var unpk2 `App` Lit (MachStr s2)]
618 | unpk1 `hasKey` unpackCStringIdKey,
619 unpk2 `hasKey` unpackCStringIdKey
620 = Just (if s1 == s2 then trueVal else falseVal)
622 match_eq_string _ _ = Nothing
625 ---------------------------------------------------
627 -- inline f_ty (f a b c) = <f's unfolding> a b c
628 -- (if f has an unfolding, EVEN if it's a loop breaker)
630 -- It's important to allow the argument to 'inline' to have args itself
631 -- (a) because its more forgiving to allow the programmer to write
633 -- or inline (f a b c)
634 -- (b) because a polymorphic f wll get a type argument that the
635 -- programmer can't avoid
637 -- Also, don't forget about 'inline's type argument!
638 match_inline :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
639 match_inline _ (Type _ : e : _)
640 | (Var f, args1) <- collectArgs e,
641 Just unf <- maybeUnfoldingTemplate (realIdUnfolding f)
642 -- Ignore the IdUnfoldingFun here!
643 = Just (mkApps unf args1)
645 match_inline _ _ = Nothing