diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/coreSyn/CoreSyn.lhs | 8 | ||||
| -rw-r--r-- | compiler/main/SysTools.lhs | 4 | ||||
| -rw-r--r-- | compiler/prelude/PrelNames.lhs | 71 | ||||
| -rw-r--r-- | compiler/prelude/PrelRules.lhs | 112 |
4 files changed, 126 insertions, 69 deletions
diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index a41302d5d3..c18af8e189 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -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 diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index 75b4d542a5..b46ca17f49 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -251,8 +251,8 @@ initSysTools mbMinusB ld_args = gcc_args -- We just assume on command line - ; let lc_prog = "llc" - lo_prog = "opt" + ; lc_prog <- getSetting "LLVM llc command" + ; lo_prog <- getSetting "LLVM opt command" ; return $ Settings { sTargetPlatform = Platform { diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index a88e536eb2..705782c272 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -253,13 +253,16 @@ basicKnownKeyNames -- Integer integerTyConName, mkIntegerName, + integerToWord64Name, integerToInt64Name, plusIntegerName, timesIntegerName, smallIntegerName, integerToWordName, integerToIntName, minusIntegerName, negateIntegerName, eqIntegerName, neqIntegerName, absIntegerName, signumIntegerName, leIntegerName, gtIntegerName, ltIntegerName, geIntegerName, compareIntegerName, quotRemIntegerName, divModIntegerName, + quotIntegerName, remIntegerName, floatFromIntegerName, doubleFromIntegerName, + encodeFloatIntegerName, encodeDoubleIntegerName, gcdIntegerName, lcmIntegerName, andIntegerName, orIntegerName, xorIntegerName, complementIntegerName, shiftLIntegerName, shiftRIntegerName, @@ -821,18 +824,23 @@ 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, absIntegerName, signumIntegerName, leIntegerName, gtIntegerName, ltIntegerName, geIntegerName, 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 @@ -851,8 +859,12 @@ geIntegerName = varQual gHC_INTEGER_TYPE (fsLit "geInteger") geI compareIntegerName = varQual gHC_INTEGER_TYPE (fsLit "compareInteger") compareIntegerIdKey quotRemIntegerName = varQual gHC_INTEGER_TYPE (fsLit "quotRemInteger") quotRemIntegerIdKey divModIntegerName = varQual gHC_INTEGER_TYPE (fsLit "divModInteger") divModIntegerIdKey +quotIntegerName = varQual gHC_INTEGER_TYPE (fsLit "quotInteger") quotIntegerIdKey +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 @@ -1441,12 +1453,15 @@ assertIdKey = mkPreludeMiscIdUnique 44 runSTRepIdKey = mkPreludeMiscIdUnique 45 mkIntegerIdKey, smallIntegerIdKey, integerToWordIdKey, integerToIntIdKey, + integerToWord64IdKey, integerToInt64IdKey, plusIntegerIdKey, timesIntegerIdKey, minusIntegerIdKey, negateIntegerIdKey, eqIntegerIdKey, neqIntegerIdKey, absIntegerIdKey, signumIntegerIdKey, leIntegerIdKey, gtIntegerIdKey, ltIntegerIdKey, geIntegerIdKey, compareIntegerIdKey, quotRemIntegerIdKey, divModIntegerIdKey, + quotIntegerIdKey, remIntegerIdKey, floatFromIntegerIdKey, doubleFromIntegerIdKey, + encodeFloatIntegerIdKey, encodeDoubleIntegerIdKey, gcdIntegerIdKey, lcmIntegerIdKey, andIntegerIdKey, orIntegerIdKey, xorIntegerIdKey, complementIntegerIdKey, shiftLIntegerIdKey, shiftRIntegerIdKey :: Unique @@ -1454,31 +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 -floatFromIntegerIdKey = mkPreludeMiscIdUnique 79 -doubleFromIntegerIdKey = mkPreludeMiscIdUnique 80 -gcdIntegerIdKey = mkPreludeMiscIdUnique 81 -lcmIntegerIdKey = mkPreludeMiscIdUnique 82 -andIntegerIdKey = mkPreludeMiscIdUnique 83 -orIntegerIdKey = mkPreludeMiscIdUnique 84 -xorIntegerIdKey = mkPreludeMiscIdUnique 85 -complementIntegerIdKey = mkPreludeMiscIdUnique 86 -shiftLIntegerIdKey = mkPreludeMiscIdUnique 87 -shiftRIntegerIdKey = mkPreludeMiscIdUnique 88 +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 diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs index 59142da106..fc0c20ad48 100644 --- a/compiler/prelude/PrelRules.lhs +++ b/compiler/prelude/PrelRules.lhs @@ -623,42 +623,42 @@ builtinIntegerRules :: [CoreRule] builtinIntegerRules = [-- TODO: smallInteger rule -- TODO: wordToInteger rule - rule_convert "integerToWord" integerToWordName mkWordLitWord, - rule_convert "integerToInt" integerToIntName mkIntLitInt, - -- TODO: integerToWord64 rule + rule_convert "integerToWord" integerToWordName mkWordLitWord, + rule_convert "integerToInt" integerToIntName mkIntLitInt, + 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 (-), - rule_binop "timesInteger" timesIntegerName (*), - rule_unop "negateInteger" negateIntegerName negate, - rule_binop_Bool "eqInteger" eqIntegerName (==), - rule_binop_Bool "neqInteger" neqIntegerName (/=), - rule_unop "absInteger" absIntegerName abs, - rule_unop "signumInteger" signumIntegerName signum, - rule_binop_Bool "leInteger" leIntegerName (<=), - rule_binop_Bool "gtInteger" gtIntegerName (>), - rule_binop_Bool "ltInteger" ltIntegerName (<), - rule_binop_Bool "geInteger" geIntegerName (>=), - rule_binop_Ordering "compareInteger" compareIntegerName compare, - rule_divop "divModInteger" divModIntegerName divMod, - rule_divop "quotRemInteger" quotRemIntegerName quotRem, - -- TODO: quotInteger rule - -- TODO: remInteger rule - -- TODO: encodeFloatInteger rule - rule_convert "floatFromInteger" floatFromIntegerName mkFloatLitFloat, - -- TODO: encodeDoubleInteger rule + rule_binop "plusInteger" plusIntegerName (+), + rule_binop "minusInteger" minusIntegerName (-), + rule_binop "timesInteger" timesIntegerName (*), + rule_unop "negateInteger" negateIntegerName negate, + rule_binop_Bool "eqInteger" eqIntegerName (==), + rule_binop_Bool "neqInteger" neqIntegerName (/=), + rule_unop "absInteger" absIntegerName abs, + rule_unop "signumInteger" signumIntegerName signum, + rule_binop_Bool "leInteger" leIntegerName (<=), + rule_binop_Bool "gtInteger" gtIntegerName (>), + rule_binop_Bool "ltInteger" ltIntegerName (<), + rule_binop_Bool "geInteger" geIntegerName (>=), + rule_binop_Ordering "compareInteger" compareIntegerName compare, + rule_divop_both "divModInteger" divModIntegerName divMod, + rule_divop_both "quotRemInteger" quotRemIntegerName quotRem, + rule_divop_one "quotInteger" quotIntegerName quot, + rule_divop_one "remInteger" remIntegerName rem, + rule_encodeFloat "encodeFloatInteger" encodeFloatIntegerName mkFloatLitFloat, + rule_convert "floatFromInteger" floatFromIntegerName mkFloatLitFloat, + rule_encodeFloat "encodeDoubleInteger" encodeDoubleIntegerName mkDoubleLitDouble, -- TODO: decodeDoubleInteger rule - rule_convert "doubleFromInteger" doubleFromIntegerName mkDoubleLitDouble, - rule_binop "gcdInteger" gcdIntegerName gcd, - rule_binop "lcmInteger" lcmIntegerName lcm, - rule_binop "andInteger" andIntegerName (.&.), - rule_binop "orInteger" orIntegerName (.|.), - rule_binop "xorInteger" xorIntegerName xor, - rule_unop "complementInteger" complementIntegerName complement, - rule_Int_binop "shiftLInteger" shiftLIntegerName shiftL, - rule_Int_binop "shiftRInteger" shiftRIntegerName shiftR] + rule_convert "doubleFromInteger" doubleFromIntegerName mkDoubleLitDouble, + rule_binop "gcdInteger" gcdIntegerName gcd, + rule_binop "lcmInteger" lcmIntegerName lcm, + rule_binop "andInteger" andIntegerName (.&.), + rule_binop "orInteger" orIntegerName (.|.), + rule_binop "xorInteger" xorIntegerName xor, + rule_unop "complementInteger" complementIntegerName complement, + rule_Int_binop "shiftLInteger" shiftLIntegerName shiftL, + rule_Int_binop "shiftRInteger" shiftRIntegerName shiftR] where rule_convert str name convert = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, ru_try = match_Integer_convert convert } @@ -668,9 +668,12 @@ builtinIntegerRules = rule_binop str name op = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, ru_try = match_Integer_binop op } - rule_divop str name op + rule_divop_both str name op = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, - ru_try = match_Integer_divop op } + ru_try = match_Integer_divop_both op } + rule_divop_one str name op + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, + ru_try = match_Integer_divop_one op } rule_Int_binop str name op = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, ru_try = match_Integer_Int_binop op } @@ -680,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: @@ -773,11 +779,11 @@ match_Integer_binop binop id_unf [xl,yl] match_Integer_binop _ _ _ = Nothing -- This helper is used for the quotRem and divMod functions -match_Integer_divop :: (Integer -> Integer -> (Integer, Integer)) - -> IdUnfoldingFun - -> [Expr CoreBndr] - -> Maybe (Expr CoreBndr) -match_Integer_divop divop id_unf [xl,yl] +match_Integer_divop_both :: (Integer -> Integer -> (Integer, Integer)) + -> IdUnfoldingFun + -> [Expr CoreBndr] + -> Maybe (Expr CoreBndr) +match_Integer_divop_both divop id_unf [xl,yl] | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl , y /= 0 @@ -789,9 +795,20 @@ match_Integer_divop divop id_unf [xl,yl] Type integerTy, Lit (LitInteger r i), Lit (LitInteger s i)] - _ -> panic "match_Integer_divop: mkIntegerId has the wrong type" + _ -> panic "match_Integer_divop_both: mkIntegerId has the wrong type" +match_Integer_divop_both _ _ _ = Nothing -match_Integer_divop _ _ _ = Nothing +-- This helper is used for the quotRem and divMod functions +match_Integer_divop_one :: (Integer -> Integer -> Integer) + -> IdUnfoldingFun + -> [Expr CoreBndr] + -> Maybe (Expr CoreBndr) +match_Integer_divop_one divop id_unf [xl,yl] + | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl + , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl + , y /= 0 + = Just (Lit (LitInteger (x `divop` y) i)) +match_Integer_divop_one _ _ _ = Nothing match_Integer_Int_binop :: (Integer -> Int -> Integer) -> IdUnfoldingFun @@ -825,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} |