Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/eecd53bcdc307726fb4bb058f3da013b72386137 >--------------------------------------------------------------- commit eecd53bcdc307726fb4bb058f3da013b72386137 Author: Simon Peyton Jones <[email protected]> Date: Wed Sep 14 12:03:17 2011 +0100 Fix integer stuff (fixes Trac #5485) In particular, use mkConApp when building the (S# i) constructors in CorePrep >--------------------------------------------------------------- compiler/basicTypes/MkId.lhs | 8 +--- compiler/coreSyn/CorePrep.lhs | 84 +++++++++++++++++++++------------------ compiler/prelude/TysWiredIn.lhs | 4 +- 3 files changed, 49 insertions(+), 47 deletions(-) diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 2352518..4c3a84f 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -28,14 +28,13 @@ module MkId ( voidArgId, nullAddrId, seqId, lazyId, lazyIdKey, coercionTokenId, - -- integer-gmp only Id: - integerGmpSId, -- integer-simple only Id's: integerSimpleNaughtId, integerSimplePositiveId, integerSimpleNegativeId, digitsNoneId, digitsSomeId, + -- Common Integer Id's: shiftLIntegerId, negateIntegerId, @@ -1059,11 +1058,6 @@ coercionTokenId -- Used to replace Coercion terms when we go to STG (mkTyConApp eqPrimTyCon [unitTy, unitTy]) noCafIdInfo --- integer-gmp only Id: -integerGmpSId :: Id -integerGmpSId = mkVanillaGlobal integerGmpSDataConName - (mkFunTy intPrimTy integerTy) - -- integer-simple only Id's: integerSimpleNaughtId, integerSimplePositiveId, integerSimpleNegativeId, digitsNoneId, digitsSomeId :: Id diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index b480c6b..3b21e5f 100644 --- a/compiler/coreSyn/CorePrep.lhs +++ b/compiler/coreSyn/CorePrep.lhs @@ -30,6 +30,7 @@ import VarEnv import Id import IdInfo import MkId +import TysWiredIn import DataCon import PrimOp import BasicTypes @@ -449,11 +450,11 @@ cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) -- For example -- f (g x) ===> ([v = g x], f v) -cpeRhsE _env expr@(Type {}) = return (emptyFloats, expr) -cpeRhsE _env expr@(Coercion {}) = return (emptyFloats, expr) -cpeRhsE env (Lit (LitInteger i)) = cpeInteger env i -cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr) -cpeRhsE env expr@(Var {}) = cpeApp env expr +cpeRhsE _env expr@(Type {}) = return (emptyFloats, expr) +cpeRhsE _env expr@(Coercion {}) = return (emptyFloats, expr) +cpeRhsE env (Lit (LitInteger i)) = cpeRhsE env (cvtLitInteger i) +cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr) +cpeRhsE env expr@(Var {}) = cpeApp env expr cpeRhsE env (Var f `App` _ `App` arg) | f `hasKey` lazyIdKey -- Replace (lazy a) by a @@ -501,40 +502,45 @@ cpeRhsE env (Case scrut bndr ty alts) ; rhs' <- cpeBodyNF env2 rhs ; return (con, bs', rhs') } -cpeInteger :: CorePrepEnv -> Integer -> UniqSM (Floats, CpeRhs) -cpeInteger env i - = let expr = case cIntegerLibraryType of - IntegerGMP -> - let mkSmallInteger x = App (Var integerGmpSId) - (Lit (mkMachInt x)) - negateInteger x = App (Var negateIntegerId) x - f x = let low = x .&. mask - high = x `shiftR` bits - highExpr = mkApps (Var shiftLIntegerId) - [f high, - Lit (mkMachInt (fromIntegral bits))] - in if high == 0 then mkSmallInteger x - else if low == 0 then highExpr - else mkApps (Var orIntegerId) - [mkSmallInteger low, highExpr] - bits = bitSize (undefined :: Int) - 2 - mask = 2 ^ bits - 1 - in if inIntRange i then mkSmallInteger i - else if i < 0 then negateInteger (f (negate i)) - else f i - IntegerSimple -> - let bits = bitSize (undefined :: Word) - mask = 2 ^ bits - 1 - f 0 = Var digitsNoneId - f x = let low = x .&. mask - high = x `shiftR` bits - in mkApps (Var digitsSomeId) - [Lit (mkMachWord low), f high] - in case i `compare` 0 of - EQ -> Var integerSimpleNaughtId - GT -> App (Var integerSimplePositiveId) (f i) - LT -> App (Var integerSimpleNegativeId) (f (negate i)) - in cpeRhsE env expr +cvtLitInteger :: Integer -> CoreExpr +-- Here we convert a literal Integer to the low-level +-- represenation. Exactly how we do this depends on the +-- library that implements Integer. If it's GMP we +-- use the S# data constructor for small literals. +cvtLitInteger i + = case cIntegerLibraryType of + IntegerGMP + | inIntRange i -> mkSmallInteger i + | i < 0 -> negateInteger (f (negate i)) + | otherwise -> f i + where + mkSmallInteger x = mkConApp integerGmpSDataCon [Lit (mkMachInt x)] + negateInteger x = App (Var negateIntegerId) x + f x = let low = x .&. mask + high = x `shiftR` bits + highExpr = mkApps (Var shiftLIntegerId) + [f high, + Lit (mkMachInt (fromIntegral bits))] + in if high == 0 then mkSmallInteger x + else if low == 0 then highExpr + else mkApps (Var orIntegerId) + [mkSmallInteger low, highExpr] + bits = bitSize (undefined :: Int) - 2 + mask = 2 ^ bits - 1 + + IntegerSimple + -> case i `compare` 0 of + EQ -> Var integerSimpleNaughtId + GT -> App (Var integerSimplePositiveId) (f i) + LT -> App (Var integerSimpleNegativeId) (f (negate i)) + where + bits = bitSize (undefined :: Word) + mask = 2 ^ bits - 1 + f 0 = Var digitsNoneId + f x = let low = x .&. mask + high = x `shiftR` bits + in mkApps (Var digitsSomeId) + [Lit (mkMachWord low), f high] -- --------------------------------------------------------------------------- -- CpeBody: produces a result satisfying CpeBody diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index 8ab7ba4..0fdc668 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -26,8 +26,10 @@ module TysWiredIn ( -- * Integer integerTy, integerTyConName, + -- integer-gmp only: - integerGmpSDataConName, + integerGmpSDataCon, + -- integer-simple only: integerSimpleNaughtDataConName, integerSimplePositiveDataConName, integerSimpleNegativeDataConName, _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
