77 | | -- A useful shorthand |
78 | | one_lit = oneLit op_name |
79 | | two_lits = twoLits op_name |
80 | | relop cmp = two_lits (cmpOp (\ord -> ord `cmp` EQ)) |
81 | | -- Cunning. cmpOp compares the values to give an Ordering. |
82 | | -- It applies its argument to that ordering value to turn |
83 | | -- the ordering into a boolean value. (`cmp` EQ) is just the job. |
| 79 | -- useful shorthands |
| 80 | rules arity = mkBasicRule op_name arity . msum |
| 81 | |
| 82 | relop :: (forall a . Ord a => a -> a -> Bool) -> [CoreRule] |
| 83 | relop cmp = rules 2 [ binaryLit (cmpOp cmp) |
| 84 | , equalArgs >> |
| 85 | -- x `cmp` x does not depend on x, so |
| 86 | -- compute it for the arbitrary value 'True' |
| 87 | -- and use that result |
| 88 | return (if cmp True True |
| 89 | then trueVal |
| 90 | else falseVal) ] |
92 | | primop_rule IntAddOp = two_lits (intOp2 (+)) |
93 | | primop_rule IntSubOp = two_lits (intOp2 (-)) |
94 | | primop_rule IntMulOp = two_lits (intOp2 (*)) |
95 | | primop_rule IntQuotOp = two_lits (intOp2Z quot) |
96 | | primop_rule IntRemOp = two_lits (intOp2Z rem) |
97 | | primop_rule IntNegOp = one_lit negOp |
98 | | primop_rule ISllOp = two_lits (intShiftOp2 Bits.shiftL) |
99 | | primop_rule ISraOp = two_lits (intShiftOp2 Bits.shiftR) |
100 | | primop_rule ISrlOp = two_lits (intShiftOp2 shiftRightLogical) |
| 112 | primop_rule IntAddOp = rules 2 [ binaryLit (intOp2 (+)) |
| 113 | , identity zeroi ] |
| 114 | primop_rule IntSubOp = rules 2 [ binaryLit (intOp2 (-)) |
| 115 | , rightIdentity zeroi |
| 116 | , equalArgs >> return (Lit zeroi) ] |
| 117 | primop_rule IntMulOp = rules 2 [ binaryLit (intOp2 (*)) |
| 118 | , zeroElem zeroi |
| 119 | , identity onei ] |
| 120 | primop_rule IntQuotOp = rules 2 [ nonZeroLit 1 >> binaryLit (intOp2 quot) |
| 121 | , leftZero zeroi |
| 122 | , rightIdentity onei |
| 123 | , equalArgs >> return (Lit onei) ] |
| 124 | primop_rule IntRemOp = rules 2 [ nonZeroLit 1 >> binaryLit (intOp2 rem) |
| 125 | , leftZero zeroi |
| 126 | , do l <- getLiteral 1 |
| 127 | guard (l == onei) |
| 128 | return (Lit zeroi) |
| 129 | , equalArgs >> return (Lit zeroi) |
| 130 | , equalArgs >> return (Lit zeroi) ] |
| 131 | primop_rule IntNegOp = rules 1 [ unaryLit negOp ] |
| 132 | primop_rule ISllOp = rules 2 [ binaryLit (intOp2 Bits.shiftL) |
| 133 | , rightIdentity zeroi ] |
| 134 | primop_rule ISraOp = rules 2 [ binaryLit (intOp2 Bits.shiftR) |
| 135 | , rightIdentity zeroi ] |
| 136 | primop_rule ISrlOp = rules 2 [ binaryLit (intOp2 shiftRightLogical) |
| 137 | , rightIdentity zeroi ] |
103 | | primop_rule WordAddOp = two_lits (wordOp2 (+)) |
104 | | primop_rule WordSubOp = two_lits (wordOp2 (-)) |
105 | | primop_rule WordMulOp = two_lits (wordOp2 (*)) |
106 | | primop_rule WordQuotOp = two_lits (wordOp2Z quot) |
107 | | primop_rule WordRemOp = two_lits (wordOp2Z rem) |
108 | | primop_rule AndOp = two_lits (wordBitOp2 (.&.)) |
109 | | primop_rule OrOp = two_lits (wordBitOp2 (.|.)) |
110 | | primop_rule XorOp = two_lits (wordBitOp2 xor) |
111 | | primop_rule SllOp = two_lits (wordShiftOp2 Bits.shiftL) |
112 | | primop_rule SrlOp = two_lits (wordShiftOp2 shiftRightLogical) |
| 140 | primop_rule WordAddOp = rules 2 [ binaryLit (wordOp2 (+)) |
| 141 | , identity zerow ] |
| 142 | primop_rule WordSubOp = rules 2 [ binaryLit (wordOp2 (-)) |
| 143 | , rightIdentity zerow |
| 144 | , equalArgs >> return (Lit zerow) ] |
| 145 | primop_rule WordMulOp = rules 2 [ binaryLit (wordOp2 (*)) |
| 146 | , identity onew ] |
| 147 | primop_rule WordQuotOp = rules 2 [ nonZeroLit 1 >> binaryLit (wordOp2 quot) |
| 148 | , rightIdentity onew ] |
| 149 | primop_rule WordRemOp = rules 2 [ nonZeroLit 1 >> binaryLit (wordOp2 rem) |
| 150 | , rightIdentity onew ] |
| 151 | primop_rule AndOp = rules 2 [ binaryLit (wordOp2 (.&.)) |
| 152 | , zeroElem zerow ] |
| 153 | primop_rule OrOp = rules 2 [ binaryLit (wordOp2 (.|.)) |
| 154 | , identity zerow ] |
| 155 | primop_rule XorOp = rules 2 [ binaryLit (wordOp2 xor) |
| 156 | , identity zerow |
| 157 | , equalArgs >> return (Lit zerow) ] |
| 158 | primop_rule SllOp = rules 2 [ binaryLit (wordShiftOp2 Bits.shiftL) |
| 159 | , rightIdentity zeroi ] |
| 160 | primop_rule SrlOp = rules 2 [ binaryLit (wordShiftOp2 shiftRightLogical) |
| 161 | , rightIdentity zeroi ] |
115 | | primop_rule Word2IntOp = one_lit (litCoerce word2IntLit) |
116 | | primop_rule Int2WordOp = one_lit (litCoerce int2WordLit) |
117 | | primop_rule Narrow8IntOp = one_lit (litCoerce narrow8IntLit) |
118 | | primop_rule Narrow16IntOp = one_lit (litCoerce narrow16IntLit) |
119 | | primop_rule Narrow32IntOp = one_lit (litCoerce narrow32IntLit) |
120 | | primop_rule Narrow8WordOp = one_lit (litCoerce narrow8WordLit) |
121 | | primop_rule Narrow16WordOp = one_lit (litCoerce narrow16WordLit) |
122 | | primop_rule Narrow32WordOp = one_lit (litCoerce narrow32WordLit) |
123 | | primop_rule OrdOp = one_lit (litCoerce char2IntLit) |
124 | | primop_rule ChrOp = one_lit (predLitCoerce litFitsInChar int2CharLit) |
125 | | primop_rule Float2IntOp = one_lit (litCoerce float2IntLit) |
126 | | primop_rule Int2FloatOp = one_lit (litCoerce int2FloatLit) |
127 | | primop_rule Double2IntOp = one_lit (litCoerce double2IntLit) |
128 | | primop_rule Int2DoubleOp = one_lit (litCoerce int2DoubleLit) |
| 164 | primop_rule Word2IntOp = rules 1 [ liftLit word2IntLit ] |
| 165 | primop_rule Int2WordOp = rules 1 [ liftLit int2WordLit ] |
| 166 | primop_rule Narrow8IntOp = rules 1 [ liftLit narrow8IntLit ] |
| 167 | primop_rule Narrow16IntOp = rules 1 [ liftLit narrow16IntLit ] |
| 168 | primop_rule Narrow32IntOp = rules 1 [ liftLit narrow32IntLit ] |
| 169 | primop_rule Narrow8WordOp = rules 1 [ liftLit narrow8WordLit ] |
| 170 | primop_rule Narrow16WordOp = rules 1 [ liftLit narrow16WordLit ] |
| 171 | primop_rule Narrow32WordOp = rules 1 [ liftLit narrow32WordLit ] |
| 172 | primop_rule OrdOp = rules 1 [ liftLit char2IntLit ] |
| 173 | primop_rule ChrOp = rules 1 [ do { [Lit lit] <- getArgs |
| 174 | ; guard (litFitsInChar lit) |
| 175 | ; liftLit int2CharLit } ] |
| 176 | primop_rule Float2IntOp = rules 1 [ liftLit float2IntLit ] |
| 177 | primop_rule Int2FloatOp = rules 1 [ liftLit int2FloatLit ] |
| 178 | primop_rule Double2IntOp = rules 1 [ liftLit double2IntLit ] |
| 179 | primop_rule Int2DoubleOp = rules 1 [ liftLit int2DoubleLit ] |
134 | | primop_rule FloatAddOp = two_lits (floatOp2 (+)) |
135 | | primop_rule FloatSubOp = two_lits (floatOp2 (-)) |
136 | | primop_rule FloatMulOp = two_lits (floatOp2 (*)) |
137 | | primop_rule FloatDivOp = two_lits (floatOp2Z (/)) |
138 | | primop_rule FloatNegOp = one_lit negOp |
| 185 | primop_rule FloatAddOp = rules 2 [ binaryLit (floatOp2 (+)) |
| 186 | , identity zerof ] |
| 187 | primop_rule FloatSubOp = rules 2 [ binaryLit (floatOp2 (-)) |
| 188 | , rightIdentity zerof ] |
| 189 | primop_rule FloatMulOp = rules 2 [ binaryLit (floatOp2 (*)) |
| 190 | , identity onef ] |
| 191 | -- zeroElem zerof doesn't hold because of NaN |
| 192 | primop_rule FloatDivOp = rules 2 [ guardFloatDiv >> binaryLit (floatOp2 (/)) |
| 193 | , rightIdentity onef ] |
| 194 | primop_rule FloatNegOp = rules 1 [ unaryLit negOp ] |
141 | | primop_rule DoubleAddOp = two_lits (doubleOp2 (+)) |
142 | | primop_rule DoubleSubOp = two_lits (doubleOp2 (-)) |
143 | | primop_rule DoubleMulOp = two_lits (doubleOp2 (*)) |
144 | | primop_rule DoubleDivOp = two_lits (doubleOp2Z (/)) |
145 | | primop_rule DoubleNegOp = one_lit negOp |
| 197 | primop_rule DoubleAddOp = rules 2 [ binaryLit (doubleOp2 (+)) |
| 198 | , identity zerod ] |
| 199 | primop_rule DoubleSubOp = rules 2 [ binaryLit (doubleOp2 (-)) |
| 200 | , rightIdentity zerod ] |
| 201 | primop_rule DoubleMulOp = rules 2 [ binaryLit (doubleOp2 (*)) |
| 202 | , identity oned ] |
| 203 | -- zeroElem zerod doesn't hold because of NaN |
| 204 | primop_rule DoubleDivOp = rules 2 [ guardDoubleDiv >> binaryLit (doubleOp2 (/)) |
| 205 | , rightIdentity oned ] |
| 206 | primop_rule DoubleNegOp = rules 1 [ unaryLit negOp ] |
201 | | -------------------------- |
202 | | litCoerce :: (Literal -> Literal) -> Literal -> Maybe CoreExpr |
203 | | litCoerce fn lit = Just (Lit (fn lit)) |
204 | | |
205 | | predLitCoerce :: (Literal -> Bool) -> (Literal -> Literal) -> Literal -> Maybe CoreExpr |
206 | | predLitCoerce p fn lit |
207 | | | p lit = Just (Lit (fn lit)) |
208 | | | otherwise = Nothing |
209 | | |
210 | | -------------------------- |
211 | | cmpOp :: (Ordering -> Bool) -> Literal -> Literal -> Maybe CoreExpr |
212 | | cmpOp cmp l1 l2 |
213 | | = go l1 l2 |
| 258 | cmpOp :: (forall a . Ord a => a -> a -> Bool) |
| 259 | -> Literal -> Literal -> Maybe CoreExpr |
| 260 | cmpOp cmp = go |
219 | | go (MachChar i1) (MachChar i2) = done (i1 `compare` i2) |
220 | | go (MachInt i1) (MachInt i2) = done (i1 `compare` i2) |
221 | | go (MachInt64 i1) (MachInt64 i2) = done (i1 `compare` i2) |
222 | | go (MachWord i1) (MachWord i2) = done (i1 `compare` i2) |
223 | | go (MachWord64 i1) (MachWord64 i2) = done (i1 `compare` i2) |
224 | | go (MachFloat i1) (MachFloat i2) = done (i1 `compare` i2) |
225 | | go (MachDouble i1) (MachDouble i2) = done (i1 `compare` i2) |
| 266 | go (MachChar i1) (MachChar i2) = done (i1 `cmp` i2) |
| 267 | go (MachInt i1) (MachInt i2) = done (i1 `cmp` i2) |
| 268 | go (MachInt64 i1) (MachInt64 i2) = done (i1 `cmp` i2) |
| 269 | go (MachWord i1) (MachWord i2) = done (i1 `cmp` i2) |
| 270 | go (MachWord64 i1) (MachWord64 i2) = done (i1 `cmp` i2) |
| 271 | go (MachFloat i1) (MachFloat i2) = done (i1 `cmp` i2) |
| 272 | go (MachDouble i1) (MachDouble i2) = done (i1 `cmp` i2) |
243 | | intOp2Z :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr |
244 | | -- Like intOp2, but Nothing if i2=0 |
245 | | intOp2Z op (MachInt i1) (MachInt i2) |
246 | | | i2 /= 0 = intResult (i1 `op` i2) |
247 | | intOp2Z _ _ _ = Nothing -- LitLit or zero dividend |
248 | | |
249 | | intShiftOp2 :: (Integer->Int->Integer) -> Literal -> Literal -> Maybe CoreExpr |
250 | | -- Shifts take an Int; hence second arg of op is Int |
251 | | intShiftOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` fromInteger i2) |
252 | | intShiftOp2 _ _ _ = Nothing |
253 | | |
307 | | doubleOp2Z :: (Rational -> Rational -> Rational) -> Literal -> Literal |
308 | | -> Maybe (Expr CoreBndr) |
309 | | doubleOp2Z op (MachDouble f1) (MachDouble f2) |
310 | | | (f1 /= 0 || f2 > 0) -- see Note [negative zero] |
311 | | && f2 /= 0 -- avoid NaN and Infinity/-Infinity |
312 | | = Just (mkDoubleVal (f1 `op` f2)) |
313 | | -- Note [negative zero] Avoid (0 / -d), otherwise 0/(-1) reduces to |
314 | | -- zero, but we might want to preserve the negative zero here which |
315 | | -- is representable in Float/Double but not in (normalised) |
316 | | -- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead? |
317 | | doubleOp2Z _ _ _ = Nothing |
318 | | |
319 | | |
441 | | ru_nargs = n_args, ru_try = \_ -> rule_fn }] |
442 | | |
443 | | oneLit :: Name -> (Literal -> Maybe CoreExpr) |
444 | | -> [CoreRule] |
445 | | oneLit op_name test |
446 | | = mkBasicRule op_name 1 rule_fn |
447 | | where |
448 | | rule_fn _ [Lit l1] = test (convFloating l1) |
449 | | rule_fn _ _ = Nothing |
450 | | |
451 | | twoLits :: Name -> (Literal -> Literal -> Maybe CoreExpr) |
452 | | -> [CoreRule] |
453 | | twoLits op_name test |
454 | | = mkBasicRule op_name 2 rule_fn |
455 | | where |
456 | | rule_fn _ [Lit l1, Lit l2] = test (convFloating l1) (convFloating l2) |
457 | | rule_fn _ _ = Nothing |
| 446 | ru_nargs = n_args, |
| 447 | ru_try = \_ -> runRuleM rm }] |
| 448 | |
| 449 | newtype RuleM r = RuleM |
| 450 | { runRuleM :: IdUnfoldingFun -> [CoreExpr] -> Maybe r } |
| 451 | |
| 452 | instance Monad RuleM where |
| 453 | return x = RuleM $ \_ _ -> Just x |
| 454 | RuleM f >>= g = RuleM $ \iu e -> case f iu e of |
| 455 | Nothing -> Nothing |
| 456 | Just r -> runRuleM (g r) iu e |
| 457 | fail _ = mzero |
| 458 | |
| 459 | instance MonadPlus RuleM where |
| 460 | mzero = RuleM $ \_ _ -> Nothing |
| 461 | mplus (RuleM f1) (RuleM f2) = RuleM $ \iu args -> |
| 462 | f1 iu args `mplus` f2 iu args |
| 463 | |
| 464 | liftMaybe :: Maybe a -> RuleM a |
| 465 | liftMaybe Nothing = mzero |
| 466 | liftMaybe (Just x) = return x |
| 467 | |
| 468 | liftLit :: (Literal -> Literal) -> RuleM CoreExpr |
| 469 | liftLit f = do |
| 470 | [Lit lit] <- getArgs |
| 471 | return $ Lit (f lit) |
| 472 | |
| 473 | getArgs :: RuleM [CoreExpr] |
| 474 | getArgs = RuleM $ \_ args -> Just args |
| 475 | |
| 476 | getIdUnfoldingFun :: RuleM IdUnfoldingFun |
| 477 | getIdUnfoldingFun = RuleM $ \iu _ -> Just iu |
| 478 | |
| 479 | getLiteral :: Int -> RuleM Literal |
| 480 | getLiteral n = RuleM $ \_ exprs -> case drop n exprs of |
| 481 | (Lit l:_) -> Just l |
| 482 | _ -> Nothing |
| 483 | |
| 484 | unaryLit :: (Literal -> Maybe CoreExpr) -> RuleM CoreExpr |
| 485 | unaryLit op = do |
| 486 | [Lit l] <- getArgs |
| 487 | liftMaybe $ op (convFloating l) |
| 488 | |
| 489 | binaryLit :: (Literal -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr |
| 490 | binaryLit op = do |
| 491 | [Lit l1, Lit l2] <- getArgs |
| 492 | liftMaybe $ convFloating l1 `op` convFloating l2 |
| 493 | |
| 494 | leftIdentity :: Literal -> RuleM CoreExpr |
| 495 | leftIdentity id_lit = do |
| 496 | [Lit l1, e2] <- getArgs |
| 497 | guard $ l1 == id_lit |
| 498 | return e2 |
| 499 | |
| 500 | rightIdentity :: Literal -> RuleM CoreExpr |
| 501 | rightIdentity id_lit = do |
| 502 | [e1, Lit l2] <- getArgs |
| 503 | guard $ l2 == id_lit |
| 504 | return e1 |
| 505 | |
| 506 | leftZero :: Literal -> RuleM CoreExpr |
| 507 | leftZero zero = do |
| 508 | [Lit l1, _] <- getArgs |
| 509 | guard $ l1 == zero |
| 510 | return $ Lit zero |
| 511 | |
| 512 | rightZero :: Literal -> RuleM CoreExpr |
| 513 | rightZero zero = do |
| 514 | [_, Lit l2] <- getArgs |
| 515 | guard $ l2 == zero |
| 516 | return $ Lit zero |
| 517 | |
| 518 | equalArgs :: RuleM () |
| 519 | equalArgs = do |
| 520 | [e1, e2] <- getArgs |
| 521 | guard $ e1 `cheapEqExpr` e2 |
| 522 | |
| 523 | nonZeroLit :: Int -> RuleM () |
| 524 | nonZeroLit n = getLiteral n >>= guard . not . isZeroLit |
| 536 | guardFloatDiv :: RuleM () |
| 537 | guardFloatDiv = do |
| 538 | [Lit (MachFloat f1), Lit (MachFloat f2)] <- getArgs |
| 539 | guard $ (f1 /=0 || f2 > 0) -- see Note [negative zero] |
| 540 | && f2 /= 0 -- avoid NaN and Infinity/-Infinity |
| 541 | |
| 542 | guardDoubleDiv :: RuleM () |
| 543 | guardDoubleDiv = do |
| 544 | [Lit (MachDouble d1), Lit (MachDouble d2)] <- getArgs |
| 545 | guard $ (d1 /=0 || d2 > 0) -- see Note [negative zero] |
| 546 | && d2 /= 0 -- avoid NaN and Infinity/-Infinity |
| 547 | -- Note [negative zero] Avoid (0 / -d), otherwise 0/(-1) reduces to |
| 548 | -- zero, but we might want to preserve the negative zero here which |
| 549 | -- is representable in Float/Double but not in (normalised) |
| 550 | -- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead? |
| 551 | |
520 | | tagToEnumRule _ [Type ty, Lit (MachInt i)] |
521 | | | Just (tycon, tc_args) <- splitTyConApp_maybe ty |
522 | | , isEnumerationTyCon tycon |
523 | | = case filter correct_tag (tyConDataCons_maybe tycon `orElse` []) of |
524 | | [] -> Nothing -- Abstract type |
525 | | (dc:rest) -> ASSERT( null rest ) |
526 | | Just (mkTyApps (Var (dataConWorkId dc)) tc_args) |
527 | | | otherwise -- See Note [tagToEnum#] |
528 | | = WARN( True, ptext (sLit "tagToEnum# on non-enumeration type") <+> ppr ty ) |
529 | | Just (mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type") |
530 | | where |
531 | | correct_tag dc = (dataConTag dc - fIRST_TAG) == tag |
532 | | tag = fromInteger i |
533 | | |
534 | | tagToEnumRule _ _ = Nothing |
| 603 | tagToEnumRule = do |
| 604 | [Type ty, Lit (MachInt i)] <- getArgs |
| 605 | case splitTyConApp_maybe ty of |
| 606 | Just (tycon, tc_args) | isEnumerationTyCon tycon -> do |
| 607 | let tag = fromInteger i |
| 608 | correct_tag dc = (dataConTag dc - fIRST_TAG) == tag |
| 609 | (dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` []) |
| 610 | ASSERT (null rest) return () |
| 611 | return $ mkTyApps (Var (dataConWorkId dc)) tc_args |
| 612 | |
| 613 | -- See Note [tagToEnum#] |
| 614 | _ -> WARN( True, ptext (sLit "tagToEnum# on non-enumeration type") <+> ppr ty ) |
| 615 | return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type" |
544 | | dataToTagRule :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Arg CoreBndr) |
545 | | dataToTagRule _ [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] |
546 | | | tag_to_enum `hasKey` tagToEnumKey |
547 | | , ty1 `eqType` ty2 |
548 | | = Just tag -- dataToTag (tagToEnum x) ==> x |
549 | | |
550 | | dataToTagRule id_unf [_, val_arg] |
551 | | | Just (dc,_,_) <- exprIsConApp_maybe id_unf val_arg |
552 | | = ASSERT( not (isNewTyCon (dataConTyCon dc)) ) |
553 | | Just (mkIntVal (toInteger (dataConTag dc - fIRST_TAG))) |
554 | | |
555 | | dataToTagRule _ _ = Nothing |
| 625 | dataToTagRule :: RuleM CoreExpr |
| 626 | dataToTagRule = a `mplus` b |
| 627 | where |
| 628 | a = do |
| 629 | [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] <- getArgs |
| 630 | guard $ tag_to_enum `hasKey` tagToEnumKey |
| 631 | guard $ ty1 `eqType` ty2 |
| 632 | return tag -- dataToTag (tagToEnum x) ==> x |
| 633 | b = do |
| 634 | [_, val_arg] <- getArgs |
| 635 | id_unf <- getIdUnfoldingFun |
| 636 | (dc,_,_) <- liftMaybe $ exprIsConApp_maybe id_unf val_arg |
| 637 | ASSERT( not (isNewTyCon (dataConTyCon dc)) ) return () |
| 638 | return $ mkIntVal (toInteger (dataConTag dc - fIRST_TAG)) |
566 | | seqRule :: IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr |
567 | | seqRule _ [ty_a, Type ty_s, a, s] | exprIsHNF a |
568 | | = Just (mkConApp (tupleCon UnboxedTuple 2) |
569 | | [Type (mkStatePrimTy ty_s), ty_a, s, a]) |
570 | | seqRule _ _ = Nothing |
| 649 | seqRule :: RuleM CoreExpr |
| 650 | seqRule = do |
| 651 | [ty_a, Type ty_s, a, s] <- getArgs |
| 652 | guard $ exprIsHNF a |
| 653 | return $ mkConApp (tupleCon UnboxedTuple 2) |
| 654 | [Type (mkStatePrimTy ty_s), ty_a, s, a] |