Commit dff06f8e authored by Ian Lynagh's avatar Ian Lynagh
Browse files

Add some more Integer rules

parent 19cc3573
......@@ -254,6 +254,7 @@ basicKnownKeyNames
-- Integer
integerTyConName, mkIntegerName,
integerToWord64Name, integerToInt64Name,
word64ToIntegerName, int64ToIntegerName,
plusIntegerName, timesIntegerName, smallIntegerName,
wordToIntegerName,
integerToWordName, integerToIntName, minusIntegerName,
......@@ -264,6 +265,7 @@ basicKnownKeyNames
quotIntegerName, remIntegerName,
floatFromIntegerName, doubleFromIntegerName,
encodeFloatIntegerName, encodeDoubleIntegerName,
decodeDoubleIntegerName,
gcdIntegerName, lcmIntegerName,
andIntegerName, orIntegerName, xorIntegerName, complementIntegerName,
shiftLIntegerName, shiftRIntegerName,
......@@ -840,6 +842,7 @@ negateName = methName gHC_NUM (fsLit "negate") negateClassOpKey
integerTyConName, mkIntegerName,
integerToWord64Name, integerToInt64Name,
word64ToIntegerName, int64ToIntegerName,
plusIntegerName, timesIntegerName, smallIntegerName,
wordToIntegerName,
integerToWordName, integerToIntName, minusIntegerName,
......@@ -850,6 +853,7 @@ integerTyConName, mkIntegerName,
quotIntegerName, remIntegerName,
floatFromIntegerName, doubleFromIntegerName,
encodeFloatIntegerName, encodeDoubleIntegerName,
decodeDoubleIntegerName,
gcdIntegerName, lcmIntegerName,
andIntegerName, orIntegerName, xorIntegerName, complementIntegerName,
shiftLIntegerName, shiftRIntegerName :: Name
......@@ -857,6 +861,8 @@ integerTyConName = tcQual gHC_INTEGER_TYPE (fsLit "Integer") int
mkIntegerName = varQual gHC_INTEGER_TYPE (fsLit "mkInteger") mkIntegerIdKey
integerToWord64Name = varQual gHC_INTEGER_TYPE (fsLit "integerToWord64") integerToWord64IdKey
integerToInt64Name = varQual gHC_INTEGER_TYPE (fsLit "integerToInt64") integerToInt64IdKey
word64ToIntegerName = varQual gHC_INTEGER_TYPE (fsLit "word64ToInteger") word64ToIntegerIdKey
int64ToIntegerName = varQual gHC_INTEGER_TYPE (fsLit "int64ToInteger") int64ToIntegerIdKey
plusIntegerName = varQual gHC_INTEGER_TYPE (fsLit "plusInteger") plusIntegerIdKey
timesIntegerName = varQual gHC_INTEGER_TYPE (fsLit "timesInteger") timesIntegerIdKey
smallIntegerName = varQual gHC_INTEGER_TYPE (fsLit "smallInteger") smallIntegerIdKey
......@@ -882,6 +888,7 @@ floatFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "floatFromInteger")
doubleFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "doubleFromInteger") doubleFromIntegerIdKey
encodeFloatIntegerName = varQual gHC_INTEGER_TYPE (fsLit "encodeFloatInteger") encodeFloatIntegerIdKey
encodeDoubleIntegerName = varQual gHC_INTEGER_TYPE (fsLit "encodeDoubleInteger") encodeDoubleIntegerIdKey
decodeDoubleIntegerName = varQual gHC_INTEGER_TYPE (fsLit "decodeDoubleInteger") decodeDoubleIntegerIdKey
gcdIntegerName = varQual gHC_INTEGER_TYPE (fsLit "gcdInteger") gcdIntegerIdKey
lcmIntegerName = varQual gHC_INTEGER_TYPE (fsLit "lcmInteger") lcmIntegerIdKey
andIntegerName = varQual gHC_INTEGER_TYPE (fsLit "andInteger") andIntegerIdKey
......@@ -1504,6 +1511,7 @@ runSTRepIdKey = mkPreludeMiscIdUnique 45
mkIntegerIdKey, smallIntegerIdKey, wordToIntegerIdKey,
integerToWordIdKey, integerToIntIdKey,
integerToWord64IdKey, integerToInt64IdKey,
word64ToIntegerIdKey, int64ToIntegerIdKey,
plusIntegerIdKey, timesIntegerIdKey, minusIntegerIdKey,
negateIntegerIdKey,
eqIntegerIdKey, neqIntegerIdKey, absIntegerIdKey, signumIntegerIdKey,
......@@ -1512,6 +1520,7 @@ mkIntegerIdKey, smallIntegerIdKey, wordToIntegerIdKey,
quotIntegerIdKey, remIntegerIdKey,
floatFromIntegerIdKey, doubleFromIntegerIdKey,
encodeFloatIntegerIdKey, encodeDoubleIntegerIdKey,
decodeDoubleIntegerIdKey,
gcdIntegerIdKey, lcmIntegerIdKey,
andIntegerIdKey, orIntegerIdKey, xorIntegerIdKey, complementIntegerIdKey,
shiftLIntegerIdKey, shiftRIntegerIdKey :: Unique
......@@ -1551,6 +1560,9 @@ complementIntegerIdKey = mkPreludeMiscIdUnique 92
shiftLIntegerIdKey = mkPreludeMiscIdUnique 93
shiftRIntegerIdKey = mkPreludeMiscIdUnique 94
wordToIntegerIdKey = mkPreludeMiscIdUnique 95
word64ToIntegerIdKey = mkPreludeMiscIdUnique 96
int64ToIntegerIdKey = mkPreludeMiscIdUnique 97
decodeDoubleIntegerIdKey = mkPreludeMiscIdUnique 98
rootMainKey, runMainKey :: Unique
rootMainKey = mkPreludeMiscIdUnique 100
......
......@@ -624,12 +624,12 @@ builtinIntegerRules :: [CoreRule]
builtinIntegerRules =
[rule_IntToInteger "smallInteger" smallIntegerName,
rule_WordToInteger "wordToInteger" wordToIntegerName,
rule_Int64ToInteger "int64ToInteger" int64ToIntegerName,
rule_Word64ToInteger "word64ToInteger" word64ToIntegerName,
rule_convert "integerToWord" integerToWordName mkWordLitWord,
rule_convert "integerToInt" integerToIntName mkIntLitInt,
rule_convert "integerToWord64" integerToWord64Name mkWord64LitWord64,
-- TODO: word64ToInteger rule
rule_convert "integerToInt64" integerToInt64Name mkInt64LitInt64,
-- TODO: int64ToInteger rule
rule_binop "plusInteger" plusIntegerName (+),
rule_binop "minusInteger" minusIntegerName (-),
rule_binop "timesInteger" timesIntegerName (*),
......@@ -650,7 +650,7 @@ builtinIntegerRules =
rule_encodeFloat "encodeFloatInteger" encodeFloatIntegerName mkFloatLitFloat,
rule_convert "floatFromInteger" floatFromIntegerName mkFloatLitFloat,
rule_encodeFloat "encodeDoubleInteger" encodeDoubleIntegerName mkDoubleLitDouble,
-- TODO: decodeDoubleInteger rule
rule_decodeDouble "decodeDoubleInteger" decodeDoubleIntegerName,
rule_convert "doubleFromInteger" doubleFromIntegerName mkDoubleLitDouble,
rule_binop "gcdInteger" gcdIntegerName gcd,
rule_binop "lcmInteger" lcmIntegerName lcm,
......@@ -669,6 +669,12 @@ builtinIntegerRules =
rule_WordToInteger str name
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
ru_try = match_WordToInteger }
rule_Int64ToInteger str name
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
ru_try = match_Int64ToInteger }
rule_Word64ToInteger str name
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
ru_try = match_Word64ToInteger }
rule_unop str name op
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
ru_try = match_Integer_unop op }
......@@ -693,6 +699,9 @@ builtinIntegerRules =
rule_encodeFloat str name op
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
ru_try = match_Integer_Int_encodeFloat op }
rule_decodeDouble str name
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
ru_try = match_decodeDouble }
---------------------------------------------------
-- The rule is this:
......@@ -782,6 +791,32 @@ match_WordToInteger id id_unf [xl]
panic "match_WordToInteger: Id has the wrong type"
match_WordToInteger _ _ _ = Nothing
match_Int64ToInteger :: Id
-> IdUnfoldingFun
-> [Expr CoreBndr]
-> Maybe (Expr CoreBndr)
match_Int64ToInteger id id_unf [xl]
| Just (MachInt64 x) <- exprIsLiteral_maybe id_unf xl
= case idType id of
FunTy _ integerTy ->
Just (Lit (LitInteger x integerTy))
_ ->
panic "match_Int64ToInteger: Id has the wrong type"
match_Int64ToInteger _ _ _ = Nothing
match_Word64ToInteger :: Id
-> IdUnfoldingFun
-> [Expr CoreBndr]
-> Maybe (Expr CoreBndr)
match_Word64ToInteger id id_unf [xl]
| Just (MachWord x) <- exprIsLiteral_maybe id_unf xl
= case idType id of
FunTy _ integerTy ->
Just (Lit (LitInteger x integerTy))
_ ->
panic "match_Word64ToInteger: Id has the wrong type"
match_Word64ToInteger _ _ _ = Nothing
match_Integer_convert :: Num a
=> (a -> Expr CoreBndr)
-> Id
......@@ -892,4 +927,23 @@ match_Integer_Int_encodeFloat mkLit _ id_unf [xl,yl]
, Just (MachInt y) <- exprIsLiteral_maybe id_unf yl
= Just (mkLit $ encodeFloat x (fromInteger y))
match_Integer_Int_encodeFloat _ _ _ _ = Nothing
match_decodeDouble :: Id
-> IdUnfoldingFun
-> [Expr CoreBndr]
-> Maybe (Expr CoreBndr)
match_decodeDouble fn id_unf [xl]
| Just (MachDouble x) <- exprIsLiteral_maybe id_unf xl
= case idType fn of
FunTy _ (TyConApp _ [integerTy, intHashTy]) ->
case decodeFloat (fromRational x :: Double) of
(y, z) ->
Just $ mkConApp (tupleCon UnboxedTuple 2)
[Type integerTy,
Type intHashTy,
Lit (LitInteger y integerTy),
Lit (MachInt (toInteger z))]
_ ->
panic "match_decodeDouble: Id has the wrong type"
match_decodeDouble _ _ _ = Nothing
\end{code}
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment