summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/basicTypes/Literal.lhs42
-rw-r--r--compiler/basicTypes/MkId.lhs44
-rw-r--r--compiler/codeGen/CgUtils.hs2
-rw-r--r--compiler/coreSyn/CoreLint.lhs3
-rw-r--r--compiler/coreSyn/CorePrep.lhs56
-rw-r--r--compiler/coreSyn/CoreUtils.lhs2
-rw-r--r--compiler/coreSyn/MkCore.lhs5
-rw-r--r--compiler/ghc.mk1
-rw-r--r--compiler/ghci/ByteCodeGen.lhs2
-rw-r--r--compiler/iface/TcIface.lhs14
-rw-r--r--compiler/prelude/PrelNames.lhs21
-rw-r--r--compiler/prelude/PrelRules.lhs18
-rw-r--r--compiler/prelude/TysWiredIn.lhs75
-rw-r--r--compiler/stgSyn/CoreToStg.lhs2
-rw-r--r--compiler/typecheck/Inst.lhs1
15 files changed, 95 insertions, 193 deletions
diff --git a/compiler/basicTypes/Literal.lhs b/compiler/basicTypes/Literal.lhs
index ba8bc22a0b..00b3770704 100644
--- a/compiler/basicTypes/Literal.lhs
+++ b/compiler/basicTypes/Literal.lhs
@@ -17,6 +17,7 @@ module Literal
, mkMachInt64, mkMachWord64
, mkMachFloat, mkMachDouble
, mkMachChar, mkMachString
+ , mkLitInteger
-- ** Operations on Literals
, literalType
@@ -40,9 +41,10 @@ module Literal
import TysPrim
import PrelNames
-import TysWiredIn
import Type
+import TypeRep
import TyCon
+import Var
import Outputable
import FastTypes
import FastString
@@ -108,10 +110,12 @@ data Literal
-- @stdcall@ labels. @Just x@ => @\<x\>@ will
-- be appended to label name when emitting assembly.
- | LitInteger Integer
+ | LitInteger Integer Id
-- ^ We treat @Integer@s as literals, to make it easier to write
-- RULEs for them. They only get converted into real Core during
-- the CorePrep phase.
+ -- The Id is for mkInteger, which we use when finally creating the
+ -- core.
deriving (Data, Typeable)
\end{code}
@@ -133,7 +137,7 @@ instance Binary Literal where
put_ bh aj
put_ bh mb
put_ bh fod
- put_ bh (LitInteger i) = do putByte bh 10; put_ bh i
+ put_ bh (LitInteger i _) = do putByte bh 10; put_ bh i
get bh = do
h <- getByte bh
case h of
@@ -170,7 +174,7 @@ instance Binary Literal where
return (MachLabel aj mb fod)
_ -> do
i <- get bh
- return (LitInteger i)
+ return $ mkLitInteger i (panic "Evaluated the place holder for mkInteger")
\end{code}
\begin{code}
@@ -235,6 +239,9 @@ mkMachChar = MachChar
mkMachString :: String -> Literal
mkMachString s = MachStr (mkFastString s) -- stored UTF-8 encoded
+mkLitInteger :: Integer -> Id -> Literal
+mkLitInteger = LitInteger
+
inIntRange, inWordRange :: Integer -> Bool
inIntRange x = x >= tARGET_MIN_INT && x <= tARGET_MAX_INT
inWordRange x = x >= 0 && x <= tARGET_MAX_WORD
@@ -318,17 +325,17 @@ nullAddrLit = MachNullAddr
-- False principally of strings
litIsTrivial :: Literal -> Bool
-- c.f. CoreUtils.exprIsTrivial
-litIsTrivial (MachStr _) = False
-litIsTrivial (LitInteger _) = False
-litIsTrivial _ = True
+litIsTrivial (MachStr _) = False
+litIsTrivial (LitInteger {}) = False
+litIsTrivial _ = True
-- | True if code space does not go bad if we duplicate this literal
-- Currently we treat it just like 'litIsTrivial'
litIsDupable :: Literal -> Bool
-- c.f. CoreUtils.exprIsDupable
-litIsDupable (MachStr _) = False
-litIsDupable (LitInteger i) = inIntRange i
-litIsDupable _ = True
+litIsDupable (MachStr _) = False
+litIsDupable (LitInteger i _) = inIntRange i
+litIsDupable _ = True
litFitsInChar :: Literal -> Bool
litFitsInChar (MachInt i)
@@ -352,7 +359,12 @@ literalType (MachWord64 _) = word64PrimTy
literalType (MachFloat _) = floatPrimTy
literalType (MachDouble _) = doublePrimTy
literalType (MachLabel _ _ _) = addrPrimTy
-literalType (LitInteger _) = integerTy
+literalType (LitInteger _ mkIntegerId)
+ -- We really mean idType, rather than varType, but importing Id
+ -- causes a module import loop
+ = case varType mkIntegerId of
+ FunTy _ (FunTy _ integerTy) -> integerTy
+ _ -> panic "literalType: mkIntegerId has the wrong type"
absentLiteralOf :: TyCon -> Maybe Literal
-- Return a literal of the appropriate primtive
@@ -385,7 +397,7 @@ cmpLit (MachWord64 a) (MachWord64 b) = a `compare` b
cmpLit (MachFloat a) (MachFloat b) = a `compare` b
cmpLit (MachDouble a) (MachDouble b) = a `compare` b
cmpLit (MachLabel a _ _) (MachLabel b _ _) = a `compare` b
-cmpLit (LitInteger a) (LitInteger b) = a `compare` b
+cmpLit (LitInteger a _) (LitInteger b _) = a `compare` b
cmpLit lit1 lit2 | litTag lit1 <# litTag lit2 = LT
| otherwise = GT
@@ -400,7 +412,7 @@ litTag (MachWord64 _) = _ILIT(7)
litTag (MachFloat _) = _ILIT(8)
litTag (MachDouble _) = _ILIT(9)
litTag (MachLabel _ _ _) = _ILIT(10)
-litTag (LitInteger _) = _ILIT(11)
+litTag (LitInteger {}) = _ILIT(11)
\end{code}
Printing
@@ -423,7 +435,7 @@ pprLit (MachLabel l mb fod) = ptext (sLit "__label") <+> b <+> ppr fod
where b = case mb of
Nothing -> pprHsString l
Just x -> doubleQuotes (text (unpackFS l ++ '@':show x))
-pprLit (LitInteger i) = ptext (sLit "__integer") <+> integer i
+pprLit (LitInteger i _) = ptext (sLit "__integer") <+> integer i
pprIntVal :: Integer -> SDoc
-- ^ Print negative integers with parens to be sure it's unambiguous
@@ -453,7 +465,7 @@ hashLiteral (MachWord64 i) = hashInteger i
hashLiteral (MachFloat r) = hashRational r
hashLiteral (MachDouble r) = hashRational r
hashLiteral (MachLabel s _ _) = hashFS s
-hashLiteral (LitInteger i) = hashInteger i
+hashLiteral (LitInteger i _) = hashInteger i
hashRational :: Rational -> Int
hashRational r = hashInteger (numerator r)
diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index c8e5ab69e0..a35dbdf8fd 100644
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -28,18 +28,6 @@ module MkId (
voidArgId, nullAddrId, seqId, lazyId, lazyIdKey,
coercionTokenId,
- -- integer-simple only Id's:
- integerSimpleNaughtId,
- integerSimplePositiveId,
- integerSimpleNegativeId,
- digitsNoneId,
- digitsSomeId,
-
- -- Common Integer Id's:
- shiftLIntegerId,
- negateIntegerId,
- orIntegerId,
-
-- Re-export error Ids
module PrelRules
) where
@@ -1057,38 +1045,6 @@ coercionTokenId -- Used to replace Coercion terms when we go to STG
= pcMiscPrelId coercionTokenName
(mkTyConApp eqPrimTyCon [unitTy, unitTy])
noCafIdInfo
-
--- integer-simple only Id's:
-integerSimpleNaughtId, integerSimplePositiveId, integerSimpleNegativeId,
- digitsNoneId, digitsSomeId :: Id
-integerSimpleNaughtId = mkVanillaGlobal integerSimpleNaughtDataConName
- integerTy
-integerSimplePositiveId = mkVanillaGlobal integerSimplePositiveDataConName
- (mkFunTy digitsTy integerTy)
-integerSimpleNegativeId = mkVanillaGlobal integerSimpleNegativeDataConName
- (mkFunTy digitsTy integerTy)
-digitsNoneId = mkVanillaGlobal digitsNoneDataConName
- digitsTy
-digitsSomeId = mkVanillaGlobal digitsSomeDataConName
- (mkFunTy wordPrimTy
- (mkFunTy digitsTy digitsTy))
-
-shiftLIntegerId :: Id
-shiftLIntegerId = mkVanillaGlobalWithInfo shiftLIntegerName
- (mkFunTy integerTy (mkFunTy intPrimTy integerTy))
- noCafIdInfo
--- ToDo: we should not really be relying on noCafInfo here.
--- What if it's wrong?!
-
-negateIntegerId :: Id
-negateIntegerId = mkVanillaGlobalWithInfo negateIntegerName
- (mkFunTy integerTy integerTy)
- noCafIdInfo
-
-orIntegerId :: Id
-orIntegerId = mkVanillaGlobalWithInfo orIntegerName
- (mkFunTy integerTy (mkFunTy integerTy integerTy))
- noCafIdInfo
\end{code}
diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs
index e01457ae99..a71702cb4c 100644
--- a/compiler/codeGen/CgUtils.hs
+++ b/compiler/codeGen/CgUtils.hs
@@ -110,7 +110,7 @@ mkSimpleLit (MachLabel fs ms fod)
mkSimpleLit (MachStr _) = panic "mkSimpleLit: MachStr"
-- No LitInteger's should be left by the time this is called. CorePrep
-- should have converted them all to a real core representation.
-mkSimpleLit (LitInteger _) = panic "mkSimpleLit: LitInteger"
+mkSimpleLit (LitInteger {}) = panic "mkSimpleLit: LitInteger"
mkLtOp :: Literal -> MachOp
-- On signed literals we must do a signed comparison
diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs
index 851b84380f..4478a18ff1 100644
--- a/compiler/coreSyn/CoreLint.lhs
+++ b/compiler/coreSyn/CoreLint.lhs
@@ -34,6 +34,7 @@ import Kind
import Type
import TypeRep
import TyCon
+import TcType
import BasicTypes
import StaticFlags
import ListSetOps
@@ -512,7 +513,7 @@ lintCoreAlt _ alt_ty (DEFAULT, args, rhs) =
; checkAltExpr rhs alt_ty }
lintCoreAlt scrut_ty alt_ty (LitAlt lit, args, rhs)
- | integerTy `eqType` scrut_ty
+ | isIntegerTy scrut_ty
= failWithL integerScrutinisedMsg
| otherwise
= do { checkL (null args) (mkDefaultArgsMsg args)
diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs
index 3b21e5f021..e268cc20f5 100644
--- a/compiler/coreSyn/CorePrep.lhs
+++ b/compiler/coreSyn/CorePrep.lhs
@@ -18,6 +18,7 @@ import CoreFVs
import CoreMonad ( endPass, CoreToDo(..) )
import CoreSyn
import CoreSubst
+import MkCore
import OccurAnal ( occurAnalyseExpr )
import Type
import Literal
@@ -29,7 +30,6 @@ import VarSet
import VarEnv
import Id
import IdInfo
-import MkId
import TysWiredIn
import DataCon
import PrimOp
@@ -47,7 +47,6 @@ import FastString
import Config
import Data.Bits
import Data.List ( mapAccumL )
-import Data.Word
import Control.Monad
\end{code}
@@ -452,7 +451,8 @@ cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
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 (Lit (LitInteger i mkIntegerId))
+ = cpeRhsE env (cvtLitInteger i mkIntegerId)
cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr)
cpeRhsE env expr@(Var {}) = cpeApp env expr
@@ -502,45 +502,25 @@ cpeRhsE env (Case scrut bndr ty alts)
; rhs' <- cpeBodyNF env2 rhs
; return (con, bs', rhs') }
-cvtLitInteger :: Integer -> CoreExpr
+cvtLitInteger :: Integer -> Id -> 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]
+cvtLitInteger i mkIntegerId
+ | cIntegerLibraryType == IntegerGMP && inIntRange i
+ = mkConApp integerGmpSDataCon [Lit (mkMachInt i)]
+ | otherwise
+ = mkApps (Var mkIntegerId) [isNonNegative, ints]
+ where isNonNegative = if i < 0 then mkConApp falseDataCon []
+ else mkConApp trueDataCon []
+ ints = mkListExpr intTy (f (abs i))
+ f 0 = []
+ f x = let low = x .&. mask
+ high = x `shiftR` bits
+ in mkConApp intDataCon [Lit (mkMachInt low)] : f high
+ bits = 31
+ mask = 2 ^ bits - 1
-- ---------------------------------------------------------------------------
-- CpeBody: produces a result satisfying CpeBody
diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index be071191a2..221546d291 100644
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -1539,7 +1539,7 @@ rhsIsStatic _is_dynamic_name rhs = is_static False rhs
is_static in_arg (Note n e) = notSccNote n && is_static in_arg e
is_static in_arg (Cast e _) = is_static in_arg e
is_static _ (Coercion {}) = True -- Behaves just like a literal
- is_static _ (Lit (LitInteger _)) = False
+ is_static _ (Lit (LitInteger {})) = False
is_static _ (Lit (MachLabel {})) = False
is_static _ (Lit _) = True
-- A MachLabel (foreign import "&foo") in an argument
diff --git a/compiler/coreSyn/MkCore.lhs b/compiler/coreSyn/MkCore.lhs
index 53355910d3..4375dd9b97 100644
--- a/compiler/coreSyn/MkCore.lhs
+++ b/compiler/coreSyn/MkCore.lhs
@@ -218,8 +218,9 @@ mkWordExprWord :: Word -> CoreExpr
mkWordExprWord w = mkConApp wordDataCon [mkWordLitWord w]
-- | Create a 'CoreExpr' which will evaluate to the given @Integer@
-mkIntegerExpr :: MonadThings m => Integer -> m CoreExpr -- Result :: Integer
-mkIntegerExpr i = return (Lit (LitInteger i))
+mkIntegerExpr :: MonadThings m => Integer -> m CoreExpr -- Result :: Integer
+mkIntegerExpr i = do mkIntegerId <- lookupId mkIntegerName
+ return (Lit (mkLitInteger i mkIntegerId))
-- | Create a 'CoreExpr' which will evaluate to the given @Float@
mkFloatExpr :: Float -> CoreExpr
diff --git a/compiler/ghc.mk b/compiler/ghc.mk
index 735d0ec183..24d14e7846 100644
--- a/compiler/ghc.mk
+++ b/compiler/ghc.mk
@@ -52,6 +52,7 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/.
@echo '#include "ghc_boot_platform.h"' >> $@
@echo >> $@
@echo 'data IntegerLibrary = IntegerGMP | IntegerSimple' >> $@
+ @echo ' deriving Eq' >> $@
@echo >> $@
@echo 'cBuildPlatformString :: String' >> $@
@echo 'cBuildPlatformString = BuildPlatform_NAME' >> $@
diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs
index 8778933bdb..66ad5a636c 100644
--- a/compiler/ghci/ByteCodeGen.lhs
+++ b/compiler/ghci/ByteCodeGen.lhs
@@ -1244,7 +1244,7 @@ pushAtom _ _ (AnnLit lit)
-- No LitInteger's should be left by the time this is called.
-- CorePrep should have converted them all to a real core
-- representation.
- LitInteger _ -> panic "pushAtom: LitInteger"
+ LitInteger {} -> panic "pushAtom: LitInteger"
where
code rep
= let size_host_words = fromIntegral (cgRepSizeW rep)
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index bdf5838ff5..fc0e2573bb 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -39,9 +39,11 @@ import Class
import IParam
import TyCon
import DataCon
+import PrelNames
import TysWiredIn
import TysPrim ( anyTyConOfKind )
import BasicTypes ( Arity, strongLoopBreaker )
+import Literal
import qualified Var
import VarEnv
import VarSet
@@ -895,6 +897,10 @@ tcIfaceExpr (IfaceExt gbl)
tcIfaceExpr (IfaceTupId boxity arity)
= return $ Var (dataConWorkId (tupleCon boxity arity))
+tcIfaceExpr (IfaceLit (LitInteger i _))
+ = do mkIntegerId <- tcIfaceExtId mkIntegerName
+ return (Lit (mkLitInteger i mkIntegerId))
+
tcIfaceExpr (IfaceLit lit)
= return (Lit lit)
@@ -981,8 +987,14 @@ tcIfaceAlt _ _ (IfaceDefault, names, rhs)
tcIfaceAlt _ _ (IfaceLitAlt lit, names, rhs)
= ASSERT( null names ) do
+ lit' <- case lit of
+ LitInteger i _ ->
+ do mkIntegerId <- tcIfaceExtId mkIntegerName
+ return (mkLitInteger i mkIntegerId)
+ _ ->
+ return lit
rhs' <- tcIfaceExpr rhs
- return (LitAlt lit, [], rhs')
+ return (LitAlt lit', [], rhs')
-- A case alternative is made quite a bit more complicated
-- by the fact that we omit type annotations because we can
diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index 2334d0519a..0606c59673 100644
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -117,6 +117,7 @@ basicKnownKeyNames
stringTyConName,
ratioDataConName,
ratioTyConName,
+ integerTyConName,
-- Classes. *Must* include:
-- classes that are grabbed by key (e.g., eqClassKey)
@@ -205,6 +206,7 @@ basicKnownKeyNames
printName, fstName, sndName,
-- Integer
+ integerTyConName, mkIntegerName,
plusIntegerName, timesIntegerName, smallIntegerName,
integerToWordName, integerToIntName, minusIntegerName,
negateIntegerName, eqIntegerName, neqIntegerName,
@@ -786,7 +788,8 @@ fromIntegerName = methName gHC_NUM (fsLit "fromInteger") fromIntegerClassOpKey
minusName = methName gHC_NUM (fsLit "-") minusClassOpKey
negateName = methName gHC_NUM (fsLit "negate") negateClassOpKey
-plusIntegerName, timesIntegerName, smallIntegerName,
+integerTyConName, mkIntegerName,
+ plusIntegerName, timesIntegerName, smallIntegerName,
integerToWordName, integerToIntName, minusIntegerName,
negateIntegerName, eqIntegerName, neqIntegerName,
absIntegerName, signumIntegerName,
@@ -795,6 +798,8 @@ plusIntegerName, timesIntegerName, smallIntegerName,
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
plusIntegerName = varQual gHC_INTEGER_TYPE (fsLit "plusInteger") plusIntegerIdKey
timesIntegerName = varQual gHC_INTEGER_TYPE (fsLit "timesInteger") timesIntegerIdKey
smallIntegerName = varQual gHC_INTEGER_TYPE (fsLit "smallInteger") smallIntegerIdKey
@@ -1355,17 +1360,6 @@ gtDataConKey = mkPreludeDataConUnique 29
integerGmpSDataConKey, integerGmpJDataConKey :: Unique
integerGmpSDataConKey = mkPreludeDataConUnique 30
integerGmpJDataConKey = mkPreludeDataConUnique 31
-
--- For integer-simple only
-integerSimpleNaughtDataConKey,
- integerSimplePositiveDataConKey, integerSimpleNegativeDataConKey :: Unique
-integerSimpleNaughtDataConKey = mkPreludeDataConUnique 32
-integerSimplePositiveDataConKey = mkPreludeDataConUnique 33
-integerSimpleNegativeDataConKey = mkPreludeDataConUnique 34
-
-digitsSomeDataConKey, digitsNoneDataConKey :: Unique
-digitsSomeDataConKey = mkPreludeDataConUnique 35
-digitsNoneDataConKey = mkPreludeDataConUnique 36
\end{code}
%************************************************************************
@@ -1434,7 +1428,7 @@ smallIntegerIdKey, integerToWordIdKey, integerToIntIdKey,
compareIntegerIdKey,
gcdIntegerIdKey, lcmIntegerIdKey,
andIntegerIdKey, orIntegerIdKey, xorIntegerIdKey, complementIntegerIdKey,
- shiftLIntegerIdKey, shiftRIntegerIdKey :: Unique
+ shiftLIntegerIdKey, shiftRIntegerIdKey, mkIntegerIdKey :: Unique
smallIntegerIdKey = mkPreludeMiscIdUnique 60
integerToWordIdKey = mkPreludeMiscIdUnique 61
integerToIntIdKey = mkPreludeMiscIdUnique 62
@@ -1459,6 +1453,7 @@ xorIntegerIdKey = mkPreludeMiscIdUnique 89
complementIntegerIdKey = mkPreludeMiscIdUnique 90
shiftLIntegerIdKey = mkPreludeMiscIdUnique 91
shiftRIntegerIdKey = mkPreludeMiscIdUnique 92
+mkIntegerIdKey = mkPreludeMiscIdUnique 93
rootMainKey, runMainKey :: Unique
rootMainKey = mkPreludeMiscIdUnique 100
diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs
index 502447d17d..e8467aa27d 100644
--- a/compiler/prelude/PrelRules.lhs
+++ b/compiler/prelude/PrelRules.lhs
@@ -726,7 +726,7 @@ match_Integer_convert :: Num a
-> IdUnfoldingFun
-> [Expr CoreBndr]
-> Maybe (Expr CoreBndr)
-match_Integer_convert convert _ [Lit (LitInteger x)]
+match_Integer_convert convert _ [Lit (LitInteger x _)]
= Just (convert (fromIntegral x))
match_Integer_convert _ _ _ = Nothing
@@ -734,31 +734,31 @@ match_Integer_unop :: (Integer -> Integer)
-> IdUnfoldingFun
-> [Expr CoreBndr]
-> Maybe (Expr CoreBndr)
-match_Integer_unop unop _ [Lit (LitInteger x)]
- = Just (Lit (LitInteger (unop x)))
+match_Integer_unop unop _ [Lit (LitInteger x i)]
+ = Just (Lit (LitInteger (unop x) i))
match_Integer_unop _ _ _ = Nothing
match_Integer_binop :: (Integer -> Integer -> Integer)
-> IdUnfoldingFun
-> [Expr CoreBndr]
-> Maybe (Expr CoreBndr)
-match_Integer_binop binop _ [Lit (LitInteger x), Lit (LitInteger y)]
- = Just (Lit (LitInteger (x `binop` y)))
+match_Integer_binop binop _ [Lit (LitInteger x i), Lit (LitInteger y _)]
+ = Just (Lit (LitInteger (x `binop` y) i))
match_Integer_binop _ _ _ = Nothing
match_Integer_Int_binop :: (Integer -> Int -> Integer)
-> IdUnfoldingFun
-> [Expr CoreBndr]
-> Maybe (Expr CoreBndr)
-match_Integer_Int_binop binop _ [Lit (LitInteger x), Lit (MachInt y)]
- = Just (Lit (LitInteger (x `binop` fromIntegral y)))
+match_Integer_Int_binop binop _ [Lit (LitInteger x i), Lit (MachInt y)]
+ = Just (Lit (LitInteger (x `binop` fromIntegral y) i))
match_Integer_Int_binop _ _ _ = Nothing
match_Integer_binop_Bool :: (Integer -> Integer -> Bool)
-> IdUnfoldingFun
-> [Expr CoreBndr]
-> Maybe (Expr CoreBndr)
-match_Integer_binop_Bool binop _ [Lit (LitInteger x), Lit (LitInteger y)]
+match_Integer_binop_Bool binop _ [Lit (LitInteger x _), Lit (LitInteger y _)]
= Just (if x `binop` y then trueVal else falseVal)
match_Integer_binop_Bool _ _ _ = Nothing
@@ -766,7 +766,7 @@ match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering)
-> IdUnfoldingFun
-> [Expr CoreBndr]
-> Maybe (Expr CoreBndr)
-match_Integer_binop_Ordering binop _ [Lit (LitInteger x), Lit (LitInteger y)]
+match_Integer_binop_Ordering binop _ [Lit (LitInteger x _), Lit (LitInteger y _)]
= Just $ case x `binop` y of
LT -> ltVal
EQ -> eqVal
diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs
index 0fdc66839b..6b64ae7f7d 100644
--- a/compiler/prelude/TysWiredIn.lhs
+++ b/compiler/prelude/TysWiredIn.lhs
@@ -24,17 +24,9 @@ module TysWiredIn (
charTyCon, charDataCon, charTyCon_RDR,
charTy, stringTy, charTyConName,
- -- * Integer
- integerTy, integerTyConName,
-
-- integer-gmp only:
integerGmpSDataCon,
- -- integer-simple only:
- integerSimpleNaughtDataConName,
- integerSimplePositiveDataConName, integerSimpleNegativeDataConName,
- digitsTy, digitsSomeDataConName, digitsNoneDataConName,
-
-- * Double
doubleTyCon, doubleDataCon, doubleTy, doubleTyConName,
@@ -144,12 +136,13 @@ wiredInTyCons = [ unitTyCon -- Not treated like other tuples, because
, doubleTyCon
, floatTyCon
, intTyCon
- , integerTyCon
- , digitsTyCon
, listTyCon
, parrTyCon
, eqTyCon
]
+ ++ (case cIntegerLibraryType of
+ IntegerGMP -> [integerTyCon]
+ _ -> [])
\end{code}
\begin{code}
@@ -191,24 +184,14 @@ floatDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "F#") floa
doubleTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Double") doubleTyConKey doubleTyCon
doubleDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "D#") doubleDataConKey doubleDataCon
--- For all integer implementations:
-integerTyConName :: Name
-integerTyConName = mkWiredInTyConName UserSyntax gHC_INTEGER_TYPE (fsLit "Integer") integerTyConKey integerTyCon
-- For integer-gmp only:
+integerRealTyConName :: Name
+integerRealTyConName = case cIntegerLibraryType of
+ IntegerGMP -> mkWiredInTyConName UserSyntax gHC_INTEGER_TYPE (fsLit "Integer") integerTyConKey integerTyCon
+ _ -> panic "integerRealTyConName evaluated, but not integer-gmp"
integerGmpSDataConName, integerGmpJDataConName :: Name
integerGmpSDataConName = mkWiredInDataConName UserSyntax gHC_INTEGER_TYPE (fsLit "S#") integerGmpSDataConKey integerGmpSDataCon
integerGmpJDataConName = mkWiredInDataConName UserSyntax gHC_INTEGER_TYPE (fsLit "J#") integerGmpJDataConKey integerGmpJDataCon
--- For integer-simple only:
-integerSimpleNaughtDataConName,
- integerSimplePositiveDataConName, integerSimpleNegativeDataConName :: Name
-integerSimpleNaughtDataConName = mkWiredInDataConName UserSyntax gHC_INTEGER_TYPE (fsLit "Naught") integerSimpleNaughtDataConKey integerSimpleNaughtDataCon
-integerSimplePositiveDataConName = mkWiredInDataConName UserSyntax gHC_INTEGER_TYPE (fsLit "Positive") integerSimplePositiveDataConKey integerSimplePositiveDataCon
-integerSimpleNegativeDataConName = mkWiredInDataConName UserSyntax gHC_INTEGER_TYPE (fsLit "Negative") integerSimpleNegativeDataConKey integerSimpleNegativeDataCon
-digitsTyConName :: Name
-digitsTyConName = mkWiredInTyConName UserSyntax gHC_INTEGER_TYPE (fsLit "Digits") digitsTyConKey digitsTyCon
-digitsSomeDataConName, digitsNoneDataConName :: Name
-digitsSomeDataConName = mkWiredInDataConName UserSyntax gHC_INTEGER_TYPE (fsLit "Some") digitsSomeDataConKey digitsSomeDataCon
-digitsNoneDataConName = mkWiredInDataConName UserSyntax gHC_INTEGER_TYPE (fsLit "None") digitsNoneDataConKey digitsNoneDataCon
parrTyConName, parrDataConName :: Name
parrTyConName = mkWiredInTyConName BuiltInSyntax
@@ -457,19 +440,13 @@ stringTy = mkListTy charTy -- convenience only
\end{code}
\begin{code}
-integerTy :: Type
-integerTy = mkTyConTy integerTyCon
-
integerTyCon :: TyCon
integerTyCon = case cIntegerLibraryType of
IntegerGMP ->
- pcNonRecDataTyCon integerTyConName []
+ pcNonRecDataTyCon integerRealTyConName []
[integerGmpSDataCon, integerGmpJDataCon]
- IntegerSimple ->
- pcNonRecDataTyCon integerTyConName []
- [integerSimplePositiveDataCon,
- integerSimpleNegativeDataCon,
- integerSimpleNaughtDataCon]
+ _ ->
+ panic "Evaluated integerTyCon, but not using IntegerGMP"
integerGmpSDataCon :: DataCon
integerGmpSDataCon = pcDataCon integerGmpSDataConName []
@@ -482,38 +459,6 @@ integerGmpJDataCon :: DataCon
integerGmpJDataCon = pcDataCon integerGmpJDataConName []
[intPrimTy, byteArrayPrimTy]
integerTyCon
-
-integerSimplePositiveDataCon :: DataCon
-integerSimplePositiveDataCon = pcDataCon integerSimplePositiveDataConName []
- [digitsTy]
- integerTyCon
-
-integerSimpleNegativeDataCon :: DataCon
-integerSimpleNegativeDataCon = pcDataCon integerSimpleNegativeDataConName []
- [digitsTy]
- integerTyCon
-
-integerSimpleNaughtDataCon :: DataCon
-integerSimpleNaughtDataCon = pcDataCon integerSimpleNaughtDataConName []
- []
- integerTyCon
-
-digitsTy :: Type
-digitsTy = mkTyConTy digitsTyCon
-
-digitsTyCon :: TyCon
-digitsTyCon = pcNonRecDataTyCon digitsTyConName []
- [digitsSomeDataCon, digitsNoneDataCon]
-
-digitsSomeDataCon :: DataCon
-digitsSomeDataCon = pcDataCon digitsSomeDataConName []
- [wordPrimTy, digitsTy]
- digitsTyCon
-
-digitsNoneDataCon :: DataCon
-digitsNoneDataCon = pcDataCon digitsNoneDataConName []
- []
- digitsTyCon
\end{code}
\begin{code}
diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs
index d55943c1d5..1ebb564928 100644
--- a/compiler/stgSyn/CoreToStg.lhs
+++ b/compiler/stgSyn/CoreToStg.lhs
@@ -315,7 +315,7 @@ decisions. Hence no black holes.
\begin{code}
-- No LitInteger's should be left by the time this is called. CorePrep
-- should have converted them all to a real core representation.
-coreToStgExpr (Lit (LitInteger _)) = panic "coreToStgExpr: LitInteger"
+coreToStgExpr (Lit (LitInteger {})) = panic "coreToStgExpr: LitInteger"
coreToStgExpr (Lit l) = return (StgLit l, emptyFVInfo, emptyVarSet)
coreToStgExpr (Var v) = coreToStgApp Nothing v []
coreToStgExpr (Coercion _) = coreToStgApp Nothing coercionTokenId []
diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs
index 66402b8976..1690079bba 100644
--- a/compiler/typecheck/Inst.lhs
+++ b/compiler/typecheck/Inst.lhs
@@ -54,7 +54,6 @@ import Var ( Var, EvVar, varType, setVarType )
import VarEnv
import VarSet
import PrelNames
-import TysWiredIn
import SrcLoc
import DynFlags
import Bag
View Lorry Controller Status