Commit 17f89fd1 authored by Ian Lynagh's avatar Ian Lynagh
Browse files

Add prelude rules for encode{Float,Double}Integer and integerTo{Int,Word}64

parent 56a7c604
......@@ -26,6 +26,7 @@ module CoreSyn (
mkIntLit, mkIntLitInt,
mkWordLit, mkWordLitWord,
mkWord64LitWord64, mkInt64LitInt64,
mkCharLit, mkStringLit,
mkFloatLit, mkFloatLitFloat,
mkDoubleLit, mkDoubleLitDouble,
......@@ -104,6 +105,7 @@ import Outputable
import Util
import Data.Data hiding (TyCon)
import Data.Int
import Data.Word
infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`, `mkCoApps`
......@@ -1044,6 +1046,12 @@ mkWordLitWord :: Word -> Expr b
mkWordLit w = Lit (mkMachWord w)
mkWordLitWord w = Lit (mkMachWord (toInteger w))
mkWord64LitWord64 :: Word64 -> Expr b
mkWord64LitWord64 w = Lit (mkMachWord64 (toInteger w))
mkInt64LitInt64 :: Int64 -> Expr b
mkInt64LitInt64 w = Lit (mkMachInt64 (toInteger w))
-- | Create a machine character literal expression of type @Char#@.
-- If you want an expression of type @Char@ use 'MkCore.mkCharExpr'
mkCharLit :: Char -> Expr b
......
......@@ -253,6 +253,7 @@ basicKnownKeyNames
-- Integer
integerTyConName, mkIntegerName,
integerToWord64Name, integerToInt64Name,
plusIntegerName, timesIntegerName, smallIntegerName,
integerToWordName, integerToIntName, minusIntegerName,
negateIntegerName, eqIntegerName, neqIntegerName,
......@@ -261,6 +262,7 @@ basicKnownKeyNames
compareIntegerName, quotRemIntegerName, divModIntegerName,
quotIntegerName, remIntegerName,
floatFromIntegerName, doubleFromIntegerName,
encodeFloatIntegerName, encodeDoubleIntegerName,
gcdIntegerName, lcmIntegerName,
andIntegerName, orIntegerName, xorIntegerName, complementIntegerName,
shiftLIntegerName, shiftRIntegerName,
......@@ -822,6 +824,7 @@ minusName = methName gHC_NUM (fsLit "-") minusClassOpKey
negateName = methName gHC_NUM (fsLit "negate") negateClassOpKey
integerTyConName, mkIntegerName,
integerToWord64Name, integerToInt64Name,
plusIntegerName, timesIntegerName, smallIntegerName,
integerToWordName, integerToIntName, minusIntegerName,
negateIntegerName, eqIntegerName, neqIntegerName,
......@@ -830,11 +833,14 @@ integerTyConName, mkIntegerName,
compareIntegerName, quotRemIntegerName, divModIntegerName,
quotIntegerName, remIntegerName,
floatFromIntegerName, doubleFromIntegerName,
encodeFloatIntegerName, encodeDoubleIntegerName,
gcdIntegerName, lcmIntegerName,
andIntegerName, orIntegerName, xorIntegerName, complementIntegerName,
shiftLIntegerName, shiftRIntegerName :: Name
integerTyConName = tcQual gHC_INTEGER_TYPE (fsLit "Integer") integerTyConKey
mkIntegerName = varQual gHC_INTEGER_TYPE (fsLit "mkInteger") mkIntegerIdKey
integerToWord64Name = varQual gHC_INTEGER_TYPE (fsLit "integerToWord64") integerToWord64IdKey
integerToInt64Name = varQual gHC_INTEGER_TYPE (fsLit "integerToInt64") integerToInt64IdKey
plusIntegerName = varQual gHC_INTEGER_TYPE (fsLit "plusInteger") plusIntegerIdKey
timesIntegerName = varQual gHC_INTEGER_TYPE (fsLit "timesInteger") timesIntegerIdKey
smallIntegerName = varQual gHC_INTEGER_TYPE (fsLit "smallInteger") smallIntegerIdKey
......@@ -857,6 +863,8 @@ quotIntegerName = varQual gHC_INTEGER_TYPE (fsLit "quotInteger") quo
remIntegerName = varQual gHC_INTEGER_TYPE (fsLit "remInteger") remIntegerIdKey
floatFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "floatFromIntegerName") floatFromIntegerIdKey
doubleFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "doubleFromIntegerName") doubleFromIntegerIdKey
encodeFloatIntegerName = varQual gHC_INTEGER_TYPE (fsLit "encodeFloatIntegerName") encodeFloatIntegerIdKey
encodeDoubleIntegerName = varQual gHC_INTEGER_TYPE (fsLit "encodeDoubleIntegerName") encodeDoubleIntegerIdKey
gcdIntegerName = varQual gHC_INTEGER_TYPE (fsLit "gcdInteger") gcdIntegerIdKey
lcmIntegerName = varQual gHC_INTEGER_TYPE (fsLit "lcmInteger") lcmIntegerIdKey
andIntegerName = varQual gHC_INTEGER_TYPE (fsLit "andInteger") andIntegerIdKey
......@@ -1445,6 +1453,7 @@ assertIdKey = mkPreludeMiscIdUnique 44
runSTRepIdKey = mkPreludeMiscIdUnique 45
mkIntegerIdKey, smallIntegerIdKey, integerToWordIdKey, integerToIntIdKey,
integerToWord64IdKey, integerToInt64IdKey,
plusIntegerIdKey, timesIntegerIdKey, minusIntegerIdKey,
negateIntegerIdKey,
eqIntegerIdKey, neqIntegerIdKey, absIntegerIdKey, signumIntegerIdKey,
......@@ -1452,6 +1461,7 @@ mkIntegerIdKey, smallIntegerIdKey, integerToWordIdKey, integerToIntIdKey,
compareIntegerIdKey, quotRemIntegerIdKey, divModIntegerIdKey,
quotIntegerIdKey, remIntegerIdKey,
floatFromIntegerIdKey, doubleFromIntegerIdKey,
encodeFloatIntegerIdKey, encodeDoubleIntegerIdKey,
gcdIntegerIdKey, lcmIntegerIdKey,
andIntegerIdKey, orIntegerIdKey, xorIntegerIdKey, complementIntegerIdKey,
shiftLIntegerIdKey, shiftRIntegerIdKey :: Unique
......@@ -1459,33 +1469,37 @@ mkIntegerIdKey = mkPreludeMiscIdUnique 60
smallIntegerIdKey = mkPreludeMiscIdUnique 61
integerToWordIdKey = mkPreludeMiscIdUnique 62
integerToIntIdKey = mkPreludeMiscIdUnique 63
plusIntegerIdKey = mkPreludeMiscIdUnique 64
timesIntegerIdKey = mkPreludeMiscIdUnique 65
minusIntegerIdKey = mkPreludeMiscIdUnique 66
negateIntegerIdKey = mkPreludeMiscIdUnique 67
eqIntegerIdKey = mkPreludeMiscIdUnique 68
neqIntegerIdKey = mkPreludeMiscIdUnique 69
absIntegerIdKey = mkPreludeMiscIdUnique 70
signumIntegerIdKey = mkPreludeMiscIdUnique 71
leIntegerIdKey = mkPreludeMiscIdUnique 72
gtIntegerIdKey = mkPreludeMiscIdUnique 73
ltIntegerIdKey = mkPreludeMiscIdUnique 74
geIntegerIdKey = mkPreludeMiscIdUnique 75
compareIntegerIdKey = mkPreludeMiscIdUnique 76
quotRemIntegerIdKey = mkPreludeMiscIdUnique 77
divModIntegerIdKey = mkPreludeMiscIdUnique 78
quotIntegerIdKey = mkPreludeMiscIdUnique 79
remIntegerIdKey = mkPreludeMiscIdUnique 80
floatFromIntegerIdKey = mkPreludeMiscIdUnique 81
doubleFromIntegerIdKey = mkPreludeMiscIdUnique 82
gcdIntegerIdKey = mkPreludeMiscIdUnique 83
lcmIntegerIdKey = mkPreludeMiscIdUnique 84
andIntegerIdKey = mkPreludeMiscIdUnique 85
orIntegerIdKey = mkPreludeMiscIdUnique 86
xorIntegerIdKey = mkPreludeMiscIdUnique 87
complementIntegerIdKey = mkPreludeMiscIdUnique 88
shiftLIntegerIdKey = mkPreludeMiscIdUnique 89
shiftRIntegerIdKey = mkPreludeMiscIdUnique 90
integerToWord64IdKey = mkPreludeMiscIdUnique 64
integerToInt64IdKey = mkPreludeMiscIdUnique 65
plusIntegerIdKey = mkPreludeMiscIdUnique 66
timesIntegerIdKey = mkPreludeMiscIdUnique 67
minusIntegerIdKey = mkPreludeMiscIdUnique 68
negateIntegerIdKey = mkPreludeMiscIdUnique 69
eqIntegerIdKey = mkPreludeMiscIdUnique 70
neqIntegerIdKey = mkPreludeMiscIdUnique 71
absIntegerIdKey = mkPreludeMiscIdUnique 72
signumIntegerIdKey = mkPreludeMiscIdUnique 73
leIntegerIdKey = mkPreludeMiscIdUnique 74
gtIntegerIdKey = mkPreludeMiscIdUnique 75
ltIntegerIdKey = mkPreludeMiscIdUnique 76
geIntegerIdKey = mkPreludeMiscIdUnique 77
compareIntegerIdKey = mkPreludeMiscIdUnique 78
quotRemIntegerIdKey = mkPreludeMiscIdUnique 79
divModIntegerIdKey = mkPreludeMiscIdUnique 80
quotIntegerIdKey = mkPreludeMiscIdUnique 81
remIntegerIdKey = mkPreludeMiscIdUnique 82
floatFromIntegerIdKey = mkPreludeMiscIdUnique 83
doubleFromIntegerIdKey = mkPreludeMiscIdUnique 84
encodeFloatIntegerIdKey = mkPreludeMiscIdUnique 85
encodeDoubleIntegerIdKey = mkPreludeMiscIdUnique 86
gcdIntegerIdKey = mkPreludeMiscIdUnique 87
lcmIntegerIdKey = mkPreludeMiscIdUnique 88
andIntegerIdKey = mkPreludeMiscIdUnique 89
orIntegerIdKey = mkPreludeMiscIdUnique 90
xorIntegerIdKey = mkPreludeMiscIdUnique 91
complementIntegerIdKey = mkPreludeMiscIdUnique 92
shiftLIntegerIdKey = mkPreludeMiscIdUnique 93
shiftRIntegerIdKey = mkPreludeMiscIdUnique 94
rootMainKey, runMainKey :: Unique
rootMainKey = mkPreludeMiscIdUnique 100
......
......@@ -625,9 +625,9 @@ builtinIntegerRules =
-- TODO: wordToInteger rule
rule_convert "integerToWord" integerToWordName mkWordLitWord,
rule_convert "integerToInt" integerToIntName mkIntLitInt,
-- TODO: integerToWord64 rule
rule_convert "integerToWord64" integerToWord64Name mkWord64LitWord64,
-- TODO: word64ToInteger rule
-- TODO: integerToInt64 rule
rule_convert "integerToInt64" integerToInt64Name mkInt64LitInt64,
-- TODO: int64ToInteger rule
rule_binop "plusInteger" plusIntegerName (+),
rule_binop "minusInteger" minusIntegerName (-),
......@@ -646,9 +646,9 @@ builtinIntegerRules =
rule_divop_both "quotRemInteger" quotRemIntegerName quotRem,
rule_divop_one "quotInteger" quotIntegerName quot,
rule_divop_one "remInteger" remIntegerName rem,
-- TODO: encodeFloatInteger rule
rule_encodeFloat "encodeFloatInteger" encodeFloatIntegerName mkFloatLitFloat,
rule_convert "floatFromInteger" floatFromIntegerName mkFloatLitFloat,
-- TODO: encodeDoubleInteger rule
rule_encodeFloat "encodeDoubleInteger" encodeDoubleIntegerName mkDoubleLitDouble,
-- TODO: decodeDoubleInteger rule
rule_convert "doubleFromInteger" doubleFromIntegerName mkDoubleLitDouble,
rule_binop "gcdInteger" gcdIntegerName gcd,
......@@ -683,6 +683,9 @@ builtinIntegerRules =
rule_binop_Ordering str name op
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
ru_try = match_Integer_binop_Ordering op }
rule_encodeFloat str name op
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
ru_try = match_Integer_Int_encodeFloat op }
---------------------------------------------------
-- The rule is this:
......@@ -839,4 +842,15 @@ match_Integer_binop_Ordering binop id_unf [xl, yl]
EQ -> eqVal
GT -> gtVal
match_Integer_binop_Ordering _ _ _ = Nothing
match_Integer_Int_encodeFloat :: RealFloat a
=> (a -> Expr CoreBndr)
-> IdUnfoldingFun
-> [Expr CoreBndr]
-> Maybe (Expr CoreBndr)
match_Integer_Int_encodeFloat mkLit id_unf [xl,yl]
| Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
, Just (MachInt y) <- exprIsLiteral_maybe id_unf yl
= Just (mkLit $ encodeFloat x (fromInteger y))
match_Integer_Int_encodeFloat _ _ _ = Nothing
\end{code}
Markdown is supported
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