import Literal ( Literal(..), mkMachInt, mkMachWord
, literalType
, word2IntLit, int2WordLit
import Literal ( Literal(..), mkMachInt, mkMachWord
, literalType
, word2IntLit, int2WordLit
, narrow8WordLit, narrow16WordLit, narrow32WordLit
, char2IntLit, int2CharLit
, float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit
, narrow8WordLit, narrow16WordLit, narrow32WordLit
, char2IntLit, int2CharLit
, float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit
)
import PrimOp ( PrimOp(..), tagToEnumKey )
import TysWiredIn ( boolTy, trueDataConId, falseDataConId )
import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon )
import DataCon ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG )
)
import PrimOp ( PrimOp(..), tagToEnumKey )
import TysWiredIn ( boolTy, trueDataConId, falseDataConId )
import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon )
import DataCon ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG )
import Type ( tyConAppTyCon, coreEqType )
import OccName ( occNameFS )
import PrelNames ( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey,
import Type ( tyConAppTyCon, coreEqType )
import OccName ( occNameFS )
import PrelNames ( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey,
primop_rule Narrow16WordOp = one_lit (litCoerce narrow16WordLit)
primop_rule Narrow32WordOp = one_lit (litCoerce narrow32WordLit)
primop_rule OrdOp = one_lit (litCoerce char2IntLit)
primop_rule Narrow16WordOp = one_lit (litCoerce narrow16WordLit)
primop_rule Narrow32WordOp = one_lit (litCoerce narrow32WordLit)
primop_rule OrdOp = one_lit (litCoerce char2IntLit)
primop_rule Float2IntOp = one_lit (litCoerce float2IntLit)
primop_rule Int2FloatOp = one_lit (litCoerce int2FloatLit)
primop_rule Double2IntOp = one_lit (litCoerce double2IntLit)
primop_rule Float2IntOp = one_lit (litCoerce float2IntLit)
primop_rule Int2FloatOp = one_lit (litCoerce int2FloatLit)
primop_rule Double2IntOp = one_lit (litCoerce double2IntLit)
litCoerce :: (Literal -> Literal) -> Literal -> Maybe CoreExpr
litCoerce fn lit = Just (Lit (fn lit))
litCoerce :: (Literal -> Literal) -> Literal -> Maybe CoreExpr
litCoerce fn lit = Just (Lit (fn lit))
go (MachWord64 i1) (MachWord64 i2) = done (i1 `compare` i2)
go (MachFloat i1) (MachFloat i2) = done (i1 `compare` i2)
go (MachDouble i1) (MachDouble i2) = done (i1 `compare` i2)
go (MachWord64 i1) (MachWord64 i2) = done (i1 `compare` i2)
go (MachFloat i1) (MachFloat i2) = done (i1 `compare` i2)
go (MachDouble i1) (MachDouble i2) = done (i1 `compare` i2)
negOp (MachDouble 0.0) = Nothing
negOp (MachDouble d) = Just (mkDoubleVal (-d))
negOp (MachInt i) = intResult (-i)
negOp (MachDouble 0.0) = Nothing
negOp (MachDouble d) = Just (mkDoubleVal (-d))
negOp (MachInt i) = intResult (-i)
--------------------------
intOp2 :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
intOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` i2)
--------------------------
intOp2 :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
intOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` i2)
intOp2Z :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
-- Like intOp2, but Nothing if i2=0
intOp2Z op (MachInt i1) (MachInt i2)
| i2 /= 0 = intResult (i1 `op` i2)
intOp2Z :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
-- Like intOp2, but Nothing if i2=0
intOp2Z op (MachInt i1) (MachInt i2)
| i2 /= 0 = intResult (i1 `op` i2)
intShiftOp2 :: (Integer->Int->Integer) -> Literal -> Literal -> Maybe CoreExpr
-- Shifts take an Int; hence second arg of op is Int
intShiftOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` fromInteger i2)
intShiftOp2 :: (Integer->Int->Integer) -> Literal -> Literal -> Maybe CoreExpr
-- Shifts take an Int; hence second arg of op is Int
intShiftOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` fromInteger i2)
shiftRightLogical :: Integer -> Int -> Integer
-- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do
shiftRightLogical :: Integer -> Int -> Integer
-- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do
wordOp2 :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
wordOp2 op (MachWord w1) (MachWord w2)
= wordResult (w1 `op` w2)
wordOp2 :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
wordOp2 op (MachWord w1) (MachWord w2)
= wordResult (w1 `op` w2)
wordOp2Z :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
wordOp2Z op (MachWord w1) (MachWord w2)
| w2 /= 0 = wordResult (w1 `op` w2)
wordOp2Z :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
wordOp2Z op (MachWord w1) (MachWord w2)
| w2 /= 0 = wordResult (w1 `op` w2)
wordShiftOp2 :: (Integer->Int->Integer) -> Literal -> Literal -> Maybe CoreExpr
-- Shifts take an Int; hence second arg of op is Int
wordShiftOp2 op (MachWord x) (MachInt n)
= wordResult (x `op` fromInteger n)
-- Do the shift at type Integer
wordShiftOp2 :: (Integer->Int->Integer) -> Literal -> Literal -> Maybe CoreExpr
-- Shifts take an Int; hence second arg of op is Int
wordShiftOp2 op (MachWord x) (MachInt n)
= wordResult (x `op` fromInteger n)
-- Do the shift at type Integer
- rule_fn [Lit lit, expr] = do_lit_eq lit expr
- rule_fn [expr, Lit lit] = do_lit_eq lit expr
- rule_fn other = Nothing
+ rule_fn _ [Lit lit, expr] = do_lit_eq lit expr
+ rule_fn _ [expr, Lit lit] = do_lit_eq lit expr
+ rule_fn _ _ = Nothing
[(DEFAULT, [], val_if_neq),
(LitAlt lit, [], val_if_eq)])
val_if_eq | is_eq = trueVal
[(DEFAULT, [], val_if_neq),
(LitAlt lit, [], val_if_eq)])
val_if_eq | is_eq = trueVal
-- runtime either, and compilation of completely harmless things like
-- ((124076834 :: Word32) + (2147483647 :: Word32))
-- would yield a warning. Instead we simply squash the value into the
-- runtime either, and compilation of completely harmless things like
-- ((124076834 :: Word32) + (2147483647 :: Word32))
-- would yield a warning. Instead we simply squash the value into the
-- Gives the Rule the same name as the primop itself
mkBasicRule op_name n_args rule_fn
= [BuiltinRule { ru_name = occNameFS (nameOccName op_name),
-- Gives the Rule the same name as the primop itself
mkBasicRule op_name n_args rule_fn
= [BuiltinRule { ru_name = occNameFS (nameOccName op_name),
-- When excess precision is not requested, cut down the precision of the
-- Rational value to that of Float/Double. We confuse host architecture
-- When excess precision is not requested, cut down the precision of the
-- Rational value to that of Float/Double. We confuse host architecture
= ASSERT( isEnumerationTyCon tycon )
case filter correct_tag (tyConDataCons_maybe tycon `orElse` []) of
= ASSERT( isEnumerationTyCon tycon )
case filter correct_tag (tyConDataCons_maybe tycon `orElse` []) of
-dataToTagRule [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag]
+dataToTagRule :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Arg CoreBndr)
+dataToTagRule _ [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag]
-dataToTagRule [_, val_arg]
- | Just (dc,_) <- exprIsConApp_maybe val_arg
+dataToTagRule id_unf [_, val_arg]
+ | Just (dc,_,_) <- exprIsConApp_maybe id_unf val_arg
= ASSERT( not (isNewTyCon (dataConTyCon dc)) )
Just (mkIntVal (toInteger (dataConTag dc - fIRST_TAG)))
= ASSERT( not (isNewTyCon (dataConTyCon dc)) )
Just (mkIntVal (toInteger (dataConTag dc - fIRST_TAG)))
-match_append_lit [Type ty1,
- Lit (MachStr s1),
- c1,
- Var unpk `App` Type ty2
- `App` Lit (MachStr s2)
- `App` c2
- `App` n
- ]
+match_append_lit :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
+match_append_lit _ [Type ty1,
+ Lit (MachStr s1),
+ c1,
+ Var unpk `App` Type ty2
+ `App` Lit (MachStr s2)
+ `App` c2
+ `App` n
+ ]
---------------------------------------------------
-- The rule is this:
-- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2
---------------------------------------------------
-- The rule is this:
-- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2
-match_eq_string [Var unpk1 `App` Lit (MachStr s1),
- Var unpk2 `App` Lit (MachStr s2)]
+match_eq_string :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
+match_eq_string _ [Var unpk1 `App` Lit (MachStr s1),
+ Var unpk2 `App` Lit (MachStr s2)]
| unpk1 `hasKey` unpackCStringIdKey,
unpk2 `hasKey` unpackCStringIdKey
= Just (if s1 == s2 then trueVal else falseVal)
| unpk1 `hasKey` unpackCStringIdKey,
unpk2 `hasKey` unpackCStringIdKey
= Just (if s1 == s2 then trueVal else falseVal)
--
-- It's important to allow the argument to 'inline' to have args itself
-- (a) because its more forgiving to allow the programmer to write
--
-- It's important to allow the argument to 'inline' to have args itself
-- (a) because its more forgiving to allow the programmer to write
-- programmer can't avoid
--
-- Also, don't forget about 'inline's type argument!
-- programmer can't avoid
--
-- Also, don't forget about 'inline's type argument!