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.
16 {-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
19 primOpRules, builtinRules,
21 -- Error Ids defined here because may be called here
22 mkRuntimeErrorApp, mkImpossibleExpr,
23 rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID,
24 nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID,
25 pAT_ERROR_ID, eRROR_ID, rEC_SEL_ERROR_ID,
28 #include "HsVersions.h"
31 import MkCore ( mkWildCase )
36 import PrimOp ( PrimOp(..), tagToEnumKey )
39 import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon )
40 import DataCon ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG )
41 import CoreUtils ( cheapEqExpr )
42 import CoreUnfold ( exprIsConApp_maybe )
43 import TcType ( mkSigmaTy )
45 import OccName ( occNameFS )
47 import Maybes ( orElse )
48 import Name ( Name, nameOccName )
51 import StaticFlags ( opt_SimplExcessPrecision )
54 import Data.Bits as Bits
55 import Data.Word ( Word )
59 Note [Constant folding]
60 ~~~~~~~~~~~~~~~~~~~~~~~
61 primOpRules generates the rewrite rules for each primop
62 These rules do what is often called "constant folding"
63 E.g. the rules for +# might say
65 Well, of course you'd need a lot of rules if you did it
66 like that, so we use a BuiltinRule instead, so that we
67 can match in any two literal values. So the rule is really
69 (Lit 4) +# (Lit y) = Lit (x+#y)
70 where the (+#) on the rhs is done at compile time
72 That is why these rules are built in here. Other rules
73 which don't need to be built in are in GHC.Base. For
79 primOpRules :: PrimOp -> Name -> [CoreRule]
80 primOpRules op op_name = primop_rule op
83 one_lit = oneLit op_name
84 two_lits = twoLits op_name
85 relop cmp = two_lits (cmpOp (\ord -> ord `cmp` EQ))
86 -- Cunning. cmpOp compares the values to give an Ordering.
87 -- It applies its argument to that ordering value to turn
88 -- the ordering into a boolean value. (`cmp` EQ) is just the job.
90 -- ToDo: something for integer-shift ops?
93 primop_rule TagToEnumOp = mkBasicRule op_name 2 tagToEnumRule
94 primop_rule DataToTagOp = mkBasicRule op_name 2 dataToTagRule
97 primop_rule IntAddOp = two_lits (intOp2 (+))
98 primop_rule IntSubOp = two_lits (intOp2 (-))
99 primop_rule IntMulOp = two_lits (intOp2 (*))
100 primop_rule IntQuotOp = two_lits (intOp2Z quot)
101 primop_rule IntRemOp = two_lits (intOp2Z rem)
102 primop_rule IntNegOp = one_lit negOp
103 primop_rule ISllOp = two_lits (intShiftOp2 Bits.shiftL)
104 primop_rule ISraOp = two_lits (intShiftOp2 Bits.shiftR)
105 primop_rule ISrlOp = two_lits (intShiftOp2 shiftRightLogical)
108 primop_rule WordAddOp = two_lits (wordOp2 (+))
109 primop_rule WordSubOp = two_lits (wordOp2 (-))
110 primop_rule WordMulOp = two_lits (wordOp2 (*))
111 primop_rule WordQuotOp = two_lits (wordOp2Z quot)
112 primop_rule WordRemOp = two_lits (wordOp2Z rem)
113 primop_rule AndOp = two_lits (wordBitOp2 (.&.))
114 primop_rule OrOp = two_lits (wordBitOp2 (.|.))
115 primop_rule XorOp = two_lits (wordBitOp2 xor)
116 primop_rule SllOp = two_lits (wordShiftOp2 Bits.shiftL)
117 primop_rule SrlOp = two_lits (wordShiftOp2 shiftRightLogical)
120 primop_rule Word2IntOp = one_lit (litCoerce word2IntLit)
121 primop_rule Int2WordOp = one_lit (litCoerce int2WordLit)
122 primop_rule Narrow8IntOp = one_lit (litCoerce narrow8IntLit)
123 primop_rule Narrow16IntOp = one_lit (litCoerce narrow16IntLit)
124 primop_rule Narrow32IntOp = one_lit (litCoerce narrow32IntLit)
125 primop_rule Narrow8WordOp = one_lit (litCoerce narrow8WordLit)
126 primop_rule Narrow16WordOp = one_lit (litCoerce narrow16WordLit)
127 primop_rule Narrow32WordOp = one_lit (litCoerce narrow32WordLit)
128 primop_rule OrdOp = one_lit (litCoerce char2IntLit)
129 primop_rule ChrOp = one_lit (predLitCoerce litFitsInChar int2CharLit)
130 primop_rule Float2IntOp = one_lit (litCoerce float2IntLit)
131 primop_rule Int2FloatOp = one_lit (litCoerce int2FloatLit)
132 primop_rule Double2IntOp = one_lit (litCoerce double2IntLit)
133 primop_rule Int2DoubleOp = one_lit (litCoerce int2DoubleLit)
134 -- SUP: Not sure what the standard says about precision in the following 2 cases
135 primop_rule Float2DoubleOp = one_lit (litCoerce float2DoubleLit)
136 primop_rule Double2FloatOp = one_lit (litCoerce double2FloatLit)
139 primop_rule FloatAddOp = two_lits (floatOp2 (+))
140 primop_rule FloatSubOp = two_lits (floatOp2 (-))
141 primop_rule FloatMulOp = two_lits (floatOp2 (*))
142 primop_rule FloatDivOp = two_lits (floatOp2Z (/))
143 primop_rule FloatNegOp = one_lit negOp
146 primop_rule DoubleAddOp = two_lits (doubleOp2 (+))
147 primop_rule DoubleSubOp = two_lits (doubleOp2 (-))
148 primop_rule DoubleMulOp = two_lits (doubleOp2 (*))
149 primop_rule DoubleDivOp = two_lits (doubleOp2Z (/))
150 primop_rule DoubleNegOp = one_lit negOp
152 -- Relational operators
153 primop_rule IntEqOp = relop (==) ++ litEq op_name True
154 primop_rule IntNeOp = relop (/=) ++ litEq op_name False
155 primop_rule CharEqOp = relop (==) ++ litEq op_name True
156 primop_rule CharNeOp = relop (/=) ++ litEq op_name False
158 primop_rule IntGtOp = relop (>)
159 primop_rule IntGeOp = relop (>=)
160 primop_rule IntLeOp = relop (<=)
161 primop_rule IntLtOp = relop (<)
163 primop_rule CharGtOp = relop (>)
164 primop_rule CharGeOp = relop (>=)
165 primop_rule CharLeOp = relop (<=)
166 primop_rule CharLtOp = relop (<)
168 primop_rule FloatGtOp = relop (>)
169 primop_rule FloatGeOp = relop (>=)
170 primop_rule FloatLeOp = relop (<=)
171 primop_rule FloatLtOp = relop (<)
172 primop_rule FloatEqOp = relop (==)
173 primop_rule FloatNeOp = relop (/=)
175 primop_rule DoubleGtOp = relop (>)
176 primop_rule DoubleGeOp = relop (>=)
177 primop_rule DoubleLeOp = relop (<=)
178 primop_rule DoubleLtOp = relop (<)
179 primop_rule DoubleEqOp = relop (==)
180 primop_rule DoubleNeOp = relop (/=)
182 primop_rule WordGtOp = relop (>)
183 primop_rule WordGeOp = relop (>=)
184 primop_rule WordLeOp = relop (<=)
185 primop_rule WordLtOp = relop (<)
186 primop_rule WordEqOp = relop (==)
187 primop_rule WordNeOp = relop (/=)
194 %************************************************************************
196 \subsection{Doing the business}
198 %************************************************************************
200 ToDo: the reason these all return Nothing is because there used to be
201 the possibility of an argument being a litlit. Litlits are now gone,
202 so this could be cleaned up.
205 --------------------------
206 litCoerce :: (Literal -> Literal) -> Literal -> Maybe CoreExpr
207 litCoerce fn lit = Just (Lit (fn lit))
209 predLitCoerce :: (Literal -> Bool) -> (Literal -> Literal) -> Literal -> Maybe CoreExpr
210 predLitCoerce p fn lit
211 | p lit = Just (Lit (fn lit))
212 | otherwise = Nothing
214 --------------------------
215 cmpOp :: (Ordering -> Bool) -> Literal -> Literal -> Maybe CoreExpr
219 done res | cmp res = Just trueVal
220 | otherwise = Just falseVal
222 -- These compares are at different types
223 go (MachChar i1) (MachChar i2) = done (i1 `compare` i2)
224 go (MachInt i1) (MachInt i2) = done (i1 `compare` i2)
225 go (MachInt64 i1) (MachInt64 i2) = done (i1 `compare` i2)
226 go (MachWord i1) (MachWord i2) = done (i1 `compare` i2)
227 go (MachWord64 i1) (MachWord64 i2) = done (i1 `compare` i2)
228 go (MachFloat i1) (MachFloat i2) = done (i1 `compare` i2)
229 go (MachDouble i1) (MachDouble i2) = done (i1 `compare` i2)
232 --------------------------
234 negOp :: Literal -> Maybe CoreExpr -- Negate
235 negOp (MachFloat 0.0) = Nothing -- can't represent -0.0 as a Rational
236 negOp (MachFloat f) = Just (mkFloatVal (-f))
237 negOp (MachDouble 0.0) = Nothing
238 negOp (MachDouble d) = Just (mkDoubleVal (-d))
239 negOp (MachInt i) = intResult (-i)
242 --------------------------
243 intOp2 :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
244 intOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` i2)
245 intOp2 _ _ _ = Nothing -- Could find LitLit
247 intOp2Z :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
248 -- Like intOp2, but Nothing if i2=0
249 intOp2Z op (MachInt i1) (MachInt i2)
250 | i2 /= 0 = intResult (i1 `op` i2)
251 intOp2Z _ _ _ = Nothing -- LitLit or zero dividend
253 intShiftOp2 :: (Integer->Int->Integer) -> Literal -> Literal -> Maybe CoreExpr
254 -- Shifts take an Int; hence second arg of op is Int
255 intShiftOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` fromInteger i2)
256 intShiftOp2 _ _ _ = Nothing
258 shiftRightLogical :: Integer -> Int -> Integer
259 -- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do
260 -- Do this by converting to Word and back. Obviously this won't work for big
261 -- values, but its ok as we use it here
262 shiftRightLogical x n = fromIntegral (fromInteger x `shiftR` n :: Word)
265 --------------------------
266 wordOp2 :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
267 wordOp2 op (MachWord w1) (MachWord w2)
268 = wordResult (w1 `op` w2)
269 wordOp2 _ _ _ = Nothing -- Could find LitLit
271 wordOp2Z :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
272 wordOp2Z op (MachWord w1) (MachWord w2)
273 | w2 /= 0 = wordResult (w1 `op` w2)
274 wordOp2Z _ _ _ = Nothing -- LitLit or zero dividend
276 wordBitOp2 :: (Integer->Integer->Integer) -> Literal -> Literal
278 wordBitOp2 op (MachWord w1) (MachWord w2)
279 = wordResult (w1 `op` w2)
280 wordBitOp2 _ _ _ = Nothing -- Could find LitLit
282 wordShiftOp2 :: (Integer->Int->Integer) -> Literal -> Literal -> Maybe CoreExpr
283 -- Shifts take an Int; hence second arg of op is Int
284 wordShiftOp2 op (MachWord x) (MachInt n)
285 = wordResult (x `op` fromInteger n)
286 -- Do the shift at type Integer
287 wordShiftOp2 _ _ _ = Nothing
289 --------------------------
290 floatOp2 :: (Rational -> Rational -> Rational) -> Literal -> Literal
291 -> Maybe (Expr CoreBndr)
292 floatOp2 op (MachFloat f1) (MachFloat f2)
293 = Just (mkFloatVal (f1 `op` f2))
294 floatOp2 _ _ _ = Nothing
296 floatOp2Z :: (Rational -> Rational -> Rational) -> Literal -> Literal
297 -> Maybe (Expr CoreBndr)
298 floatOp2Z op (MachFloat f1) (MachFloat f2)
299 | (f1 /= 0 || f2 > 0) -- see Note [negative zero]
300 && f2 /= 0 -- avoid NaN and Infinity/-Infinity
301 = Just (mkFloatVal (f1 `op` f2))
302 floatOp2Z _ _ _ = Nothing
304 --------------------------
305 doubleOp2 :: (Rational -> Rational -> Rational) -> Literal -> Literal
306 -> Maybe (Expr CoreBndr)
307 doubleOp2 op (MachDouble f1) (MachDouble f2)
308 = Just (mkDoubleVal (f1 `op` f2))
309 doubleOp2 _ _ _ = Nothing
311 doubleOp2Z :: (Rational -> Rational -> Rational) -> Literal -> Literal
312 -> Maybe (Expr CoreBndr)
313 doubleOp2Z op (MachDouble f1) (MachDouble f2)
314 | (f1 /= 0 || f2 > 0) -- see Note [negative zero]
315 && f2 /= 0 -- avoid NaN and Infinity/-Infinity
316 = Just (mkDoubleVal (f1 `op` f2))
317 -- Note [negative zero] Avoid (0 / -d), otherwise 0/(-1) reduces to
318 -- zero, but we might want to preserve the negative zero here which
319 -- is representable in Float/Double but not in (normalised)
320 -- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead?
321 doubleOp2Z _ _ _ = Nothing
324 --------------------------
332 -- This is a Good Thing, because it allows case-of case things
333 -- to happen, and case-default absorption to happen. For
336 -- if (n ==# 3#) || (n ==# 4#) then e1 else e2
342 -- (modulo the usual precautions to avoid duplicating e1)
345 -> Bool -- True <=> equality, False <=> inequality
348 = [BuiltinRule { ru_name = occNameFS (nameOccName op_name)
349 `appendFS` (fsLit "->case"),
351 ru_nargs = 2, ru_try = rule_fn }]
353 rule_fn _ [Lit lit, expr] = do_lit_eq lit expr
354 rule_fn _ [expr, Lit lit] = do_lit_eq lit expr
355 rule_fn _ _ = Nothing
358 = Just (mkWildCase expr (literalType lit) boolTy
359 [(DEFAULT, [], val_if_neq),
360 (LitAlt lit, [], val_if_eq)])
361 val_if_eq | is_eq = trueVal
362 | otherwise = falseVal
363 val_if_neq | is_eq = falseVal
364 | otherwise = trueVal
366 -- Note that we *don't* warn the user about overflow. It's not done at
367 -- runtime either, and compilation of completely harmless things like
368 -- ((124076834 :: Word32) + (2147483647 :: Word32))
369 -- would yield a warning. Instead we simply squash the value into the
370 -- *target* Int/Word range.
371 intResult :: Integer -> Maybe CoreExpr
373 = Just (mkIntVal (toInteger (fromInteger result :: TargetInt)))
375 wordResult :: Integer -> Maybe CoreExpr
377 = Just (mkWordVal (toInteger (fromInteger result :: TargetWord)))
381 %************************************************************************
383 \subsection{Vaguely generic functions
385 %************************************************************************
388 mkBasicRule :: Name -> Int
389 -> (IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr)
391 -- Gives the Rule the same name as the primop itself
392 mkBasicRule op_name n_args rule_fn
393 = [BuiltinRule { ru_name = occNameFS (nameOccName op_name),
395 ru_nargs = n_args, ru_try = rule_fn }]
397 oneLit :: Name -> (Literal -> Maybe CoreExpr)
400 = mkBasicRule op_name 1 rule_fn
402 rule_fn _ [Lit l1] = test (convFloating l1)
403 rule_fn _ _ = Nothing
405 twoLits :: Name -> (Literal -> Literal -> Maybe CoreExpr)
408 = mkBasicRule op_name 2 rule_fn
410 rule_fn _ [Lit l1, Lit l2] = test (convFloating l1) (convFloating l2)
411 rule_fn _ _ = Nothing
413 -- When excess precision is not requested, cut down the precision of the
414 -- Rational value to that of Float/Double. We confuse host architecture
415 -- and target architecture here, but it's convenient (and wrong :-).
416 convFloating :: Literal -> Literal
417 convFloating (MachFloat f) | not opt_SimplExcessPrecision =
418 MachFloat (toRational ((fromRational f) :: Float ))
419 convFloating (MachDouble d) | not opt_SimplExcessPrecision =
420 MachDouble (toRational ((fromRational d) :: Double))
423 trueVal, falseVal :: Expr CoreBndr
424 trueVal = Var trueDataConId
425 falseVal = Var falseDataConId
426 mkIntVal :: Integer -> Expr CoreBndr
427 mkIntVal i = Lit (mkMachInt i)
428 mkWordVal :: Integer -> Expr CoreBndr
429 mkWordVal w = Lit (mkMachWord w)
430 mkFloatVal :: Rational -> Expr CoreBndr
431 mkFloatVal f = Lit (convFloating (MachFloat f))
432 mkDoubleVal :: Rational -> Expr CoreBndr
433 mkDoubleVal d = Lit (convFloating (MachDouble d))
437 %************************************************************************
439 \subsection{Special rules for seq, tagToEnum, dataToTag}
441 %************************************************************************
445 Nasty check to ensure that tagToEnum# is applied to a type that is an
446 enumeration TyCon. Unification may refine the type later, but this
447 check won't see that, alas. It's crude but it works.
449 Here's are two cases that should fail
451 f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable
454 g = tagToEnum# 0 -- Int is not an enumeration
456 We used to make this check in the type inference engine, but it's quite
457 ugly to do so, because the delayed constraint solving means that we don't
458 really know what's going on until the end. It's very much a corner case
459 because we don't expect the user to call tagToEnum# at all; we merely
460 generate calls in derived instances of Enum. So we compromise: a
461 rewrite rule rewrites a bad instance of tagToEnum# to an error call,
465 tagToEnumRule :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
466 tagToEnumRule _ [Type ty, _]
467 | not (is_enum_ty ty) -- See Note [tagToEnum#]
468 = WARN( True, ptext (sLit "tagToEnum# on non-enumeration type") <+> ppr ty )
469 Just (mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type")
471 is_enum_ty ty = case splitTyConApp_maybe ty of
472 Just (tc, _) -> isEnumerationTyCon tc
475 tagToEnumRule _ [Type ty, Lit (MachInt i)]
476 = ASSERT( isEnumerationTyCon tycon )
477 case filter correct_tag (tyConDataCons_maybe tycon `orElse` []) of
478 [] -> Nothing -- Abstract type
479 (dc:rest) -> ASSERT( null rest )
480 Just (Var (dataConWorkId dc))
482 correct_tag dc = (dataConTag dc - fIRST_TAG) == tag
484 tycon = tyConAppTyCon ty
486 tagToEnumRule _ _ = Nothing
490 For dataToTag#, we can reduce if either
492 (a) the argument is a constructor
493 (b) the argument is a variable whose unfolding is a known constructor
496 dataToTagRule :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Arg CoreBndr)
497 dataToTagRule _ [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag]
498 | tag_to_enum `hasKey` tagToEnumKey
499 , ty1 `coreEqType` ty2
500 = Just tag -- dataToTag (tagToEnum x) ==> x
502 dataToTagRule id_unf [_, val_arg]
503 | Just (dc,_,_) <- exprIsConApp_maybe id_unf val_arg
504 = ASSERT( not (isNewTyCon (dataConTyCon dc)) )
505 Just (mkIntVal (toInteger (dataConTag dc - fIRST_TAG)))
507 dataToTagRule _ _ = Nothing
510 %************************************************************************
512 \subsection{Built in rules}
514 %************************************************************************
516 Note [Scoping for Builtin rules]
517 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
518 When compiling a (base-package) module that defines one of the
519 functions mentioned in the RHS of a built-in rule, there's a danger
522 f = ...(eq String x)....
524 ....and lower down...
528 Then a rewrite would give
530 f = ...(eqString x)...
531 ....and lower down...
534 and lo, eqString is not in scope. This only really matters when we get to code
535 generation. With -O we do a GlomBinds step that does a new SCC analysis on the whole
536 set of bindings, which sorts out the dependency. Without -O we don't do any rule
537 rewriting so again we are fine.
539 (This whole thing doesn't show up for non-built-in rules because their dependencies
544 builtinRules :: [CoreRule]
545 -- Rules for non-primops that can't be expressed using a RULE pragma
547 = [ BuiltinRule { ru_name = fsLit "AppendLitString", ru_fn = unpackCStringFoldrName,
548 ru_nargs = 4, ru_try = match_append_lit },
549 BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,
550 ru_nargs = 2, ru_try = match_eq_string },
551 BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,
552 ru_nargs = 2, ru_try = match_inline }
556 ---------------------------------------------------
558 -- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)
559 -- = unpackFoldrCString# "foobaz" c n
561 match_append_lit :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
562 match_append_lit _ [Type ty1,
565 Var unpk `App` Type ty2
566 `App` Lit (MachStr s2)
570 | unpk `hasKey` unpackCStringFoldrIdKey &&
572 = ASSERT( ty1 `coreEqType` ty2 )
573 Just (Var unpk `App` Type ty1
574 `App` Lit (MachStr (s1 `appendFS` s2))
578 match_append_lit _ _ = Nothing
580 ---------------------------------------------------
582 -- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2
584 match_eq_string :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
585 match_eq_string _ [Var unpk1 `App` Lit (MachStr s1),
586 Var unpk2 `App` Lit (MachStr s2)]
587 | unpk1 `hasKey` unpackCStringIdKey,
588 unpk2 `hasKey` unpackCStringIdKey
589 = Just (if s1 == s2 then trueVal else falseVal)
591 match_eq_string _ _ = Nothing
594 ---------------------------------------------------
596 -- inline f_ty (f a b c) = <f's unfolding> a b c
597 -- (if f has an unfolding, EVEN if it's a loop breaker)
599 -- It's important to allow the argument to 'inline' to have args itself
600 -- (a) because its more forgiving to allow the programmer to write
602 -- or inline (f a b c)
603 -- (b) because a polymorphic f wll get a type argument that the
604 -- programmer can't avoid
606 -- Also, don't forget about 'inline's type argument!
607 match_inline :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
608 match_inline _ (Type _ : e : _)
609 | (Var f, args1) <- collectArgs e,
610 Just unf <- maybeUnfoldingTemplate (realIdUnfolding f)
611 -- Ignore the IdUnfoldingFun here!
612 = Just (mkApps unf args1)
614 match_inline _ _ = Nothing
617 %************************************************************************
619 \subsection[PrelVals-error-related]{@error@ and friends; @trace@}
621 %************************************************************************
623 GHC randomly injects these into the code.
625 @patError@ is just a version of @error@ for pattern-matching
626 failures. It knows various ``codes'' which expand to longer
627 strings---this saves space!
629 @absentErr@ is a thing we put in for ``absent'' arguments. They jolly
630 well shouldn't be yanked on, but if one is, then you will get a
631 friendly message from @absentErr@ (rather than a totally random
634 @parError@ is a special version of @error@ which the compiler does
635 not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@
636 templates, but we don't ever expect to generate code for it.
640 :: Id -- Should be of type (forall a. Addr# -> a)
641 -- where Addr# points to a UTF8 encoded string
642 -> Type -- The type to instantiate 'a'
643 -> String -- The string to print
646 mkRuntimeErrorApp err_id res_ty err_msg
647 = mkApps (Var err_id) [Type res_ty, err_string]
649 err_string = Lit (mkMachString err_msg)
651 mkImpossibleExpr :: Type -> CoreExpr
652 mkImpossibleExpr res_ty
653 = mkRuntimeErrorApp rUNTIME_ERROR_ID res_ty "Impossible case alternative"
655 errorName, recSelErrorName, runtimeErrorName :: Name
656 irrefutPatErrorName, recConErrorName, patErrorName :: Name
657 nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name
658 errorName = mkWiredInIdName gHC_ERR (fsLit "error") errorIdKey eRROR_ID
659 recSelErrorName = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "recSelError") recSelErrorIdKey rEC_SEL_ERROR_ID
660 runtimeErrorName = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "runtimeError") runtimeErrorIdKey rUNTIME_ERROR_ID
661 irrefutPatErrorName = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "irrefutPatError") irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID
662 recConErrorName = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "recConError") recConErrorIdKey rEC_CON_ERROR_ID
663 patErrorName = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "patError") patErrorIdKey pAT_ERROR_ID
664 noMethodBindingErrorName = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "noMethodBindingError")
665 noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID
666 nonExhaustiveGuardsErrorName
667 = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "nonExhaustiveGuardsError")
668 nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID
670 rEC_SEL_ERROR_ID, rUNTIME_ERROR_ID, iRREFUT_PAT_ERROR_ID, rEC_CON_ERROR_ID :: Id
671 pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id
672 rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName
673 rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName
674 iRREFUT_PAT_ERROR_ID = mkRuntimeErrorId irrefutPatErrorName
675 rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorName
676 pAT_ERROR_ID = mkRuntimeErrorId patErrorName
677 nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorName
678 nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName
680 -- The runtime error Ids take a UTF8-encoded string as argument
682 mkRuntimeErrorId :: Name -> Id
683 mkRuntimeErrorId name = pc_bottoming_Id name runtimeErrorTy
685 runtimeErrorTy :: Type
686 runtimeErrorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy)
691 eRROR_ID = pc_bottoming_Id errorName errorTy
694 errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy)
695 -- Notice the openAlphaTyVar. It says that "error" can be applied
696 -- to unboxed as well as boxed types. This is OK because it never
697 -- returns, so the return type is irrelevant.
701 %************************************************************************
703 \subsection{Utilities}
705 %************************************************************************
708 pc_bottoming_Id :: Name -> Type -> Id
709 -- Function of arity 1, which diverges after being given one argument
710 pc_bottoming_Id name ty
711 = mkVanillaGlobalWithInfo name ty bottoming_info
713 bottoming_info = vanillaIdInfo `setStrictnessInfo` Just strict_sig
715 -- Make arity and strictness agree
717 -- Do *not* mark them as NoCafRefs, because they can indeed have
718 -- CAF refs. For example, pAT_ERROR_ID calls GHC.Err.untangle,
719 -- which has some CAFs
720 -- In due course we may arrange that these error-y things are
721 -- regarded by the GC as permanently live, in which case we
722 -- can give them NoCaf info. As it is, any function that calls
723 -- any pc_bottoming_Id will itself have CafRefs, which bloats
726 strict_sig = mkStrictSig (mkTopDmdType [evalDmd] BotRes)
727 -- These "bottom" out, no matter what their arguments