diff options
| -rw-r--r-- | compiler/basicTypes/Literal.lhs | 27 | ||||
| -rw-r--r-- | compiler/basicTypes/MkId.lhs | 49 | ||||
| -rw-r--r-- | compiler/codeGen/CgUtils.hs | 3 | ||||
| -rw-r--r-- | compiler/coreSyn/CoreLint.lhs | 15 | ||||
| -rw-r--r-- | compiler/coreSyn/CorePrep.lhs | 43 | ||||
| -rw-r--r-- | compiler/coreSyn/CoreUtils.lhs | 1 | ||||
| -rw-r--r-- | compiler/coreSyn/MkCore.lhs | 34 | ||||
| -rw-r--r-- | compiler/ghc.mk | 10 | ||||
| -rw-r--r-- | compiler/ghci/ByteCodeGen.lhs | 4 | ||||
| -rw-r--r-- | compiler/prelude/PrelNames.lhs | 29 | ||||
| -rw-r--r-- | compiler/prelude/PrelRules.lhs | 54 | ||||
| -rw-r--r-- | compiler/prelude/TysWiredIn.lhs | 91 | ||||
| -rw-r--r-- | compiler/simplCore/OccurAnal.lhs | 2 | ||||
| -rw-r--r-- | compiler/stgSyn/CoreToStg.lhs | 4 | ||||
| -rw-r--r-- | compiler/typecheck/Inst.lhs | 1 |
15 files changed, 274 insertions, 93 deletions
diff --git a/compiler/basicTypes/Literal.lhs b/compiler/basicTypes/Literal.lhs index 21ae638023..ba8bc22a0b 100644 --- a/compiler/basicTypes/Literal.lhs +++ b/compiler/basicTypes/Literal.lhs @@ -40,6 +40,7 @@ module Literal import TysPrim import PrelNames +import TysWiredIn import Type import TyCon import Outputable @@ -106,6 +107,11 @@ data Literal -- the label expects. Only applicable with -- @stdcall@ labels. @Just x@ => @\<x\>@ will -- be appended to label name when emitting assembly. + + | LitInteger Integer + -- ^ 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. deriving (Data, Typeable) \end{code} @@ -127,6 +133,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 get bh = do h <- getByte bh case h of @@ -156,11 +163,14 @@ instance Binary Literal where 8 -> do ai <- get bh return (MachDouble ai) - _ -> do + 9 -> do aj <- get bh mb <- get bh fod <- get bh return (MachLabel aj mb fod) + _ -> do + i <- get bh + return (LitInteger i) \end{code} \begin{code} @@ -308,15 +318,17 @@ nullAddrLit = MachNullAddr -- False principally of strings litIsTrivial :: Literal -> Bool -- c.f. CoreUtils.exprIsTrivial -litIsTrivial (MachStr _) = 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 _ = True +litIsDupable (MachStr _) = False +litIsDupable (LitInteger i) = inIntRange i +litIsDupable _ = True litFitsInChar :: Literal -> Bool litFitsInChar (MachInt i) @@ -340,6 +352,7 @@ literalType (MachWord64 _) = word64PrimTy literalType (MachFloat _) = floatPrimTy literalType (MachDouble _) = doublePrimTy literalType (MachLabel _ _ _) = addrPrimTy +literalType (LitInteger _) = integerTy absentLiteralOf :: TyCon -> Maybe Literal -- Return a literal of the appropriate primtive @@ -372,6 +385,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 lit1 lit2 | litTag lit1 <# litTag lit2 = LT | otherwise = GT @@ -386,6 +400,7 @@ litTag (MachWord64 _) = _ILIT(7) litTag (MachFloat _) = _ILIT(8) litTag (MachDouble _) = _ILIT(9) litTag (MachLabel _ _ _) = _ILIT(10) +litTag (LitInteger _) = _ILIT(11) \end{code} Printing @@ -408,6 +423,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 pprIntVal :: Integer -> SDoc -- ^ Print negative integers with parens to be sure it's unambiguous @@ -437,6 +453,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 hashRational :: Rational -> Int hashRational r = hashInteger (numerator r) diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 5ad9b0ec90..2352518f09 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -28,6 +28,19 @@ 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, + orIntegerId, + -- Re-export error Ids module PrelRules ) where @@ -36,7 +49,7 @@ module MkId ( import Rules import TysPrim -import TysWiredIn ( unitTy ) +import TysWiredIn import PrelRules import Type import Coercion @@ -1045,6 +1058,40 @@ coercionTokenId -- Used to replace Coercion terms when we go to STG = pcMiscPrelId coercionTokenName (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 +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 = mkVanillaGlobal shiftLIntegerName + (mkFunTy integerTy + (mkFunTy intPrimTy integerTy)) + +negateIntegerId :: Id +negateIntegerId = mkVanillaGlobal negateIntegerName + (mkFunTy integerTy integerTy) + +orIntegerId :: Id +orIntegerId = mkVanillaGlobal orIntegerName + (mkFunTy integerTy + (mkFunTy integerTy integerTy)) \end{code} diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index aa86690612..e01457ae99 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -108,6 +108,9 @@ mkSimpleLit (MachLabel fs ms fod) -- TODO: Literal labels might not actually be in the current package... labelSrc = ForeignLabelInThisPackage 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" 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 db3a108784..851b84380f 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -511,10 +511,13 @@ lintCoreAlt _ alt_ty (DEFAULT, args, rhs) = do { checkL (null args) (mkDefaultArgsMsg args) ; checkAltExpr rhs alt_ty } -lintCoreAlt scrut_ty alt_ty (LitAlt lit, args, rhs) = - do { checkL (null args) (mkDefaultArgsMsg args) - ; checkTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty) - ; checkAltExpr rhs alt_ty } +lintCoreAlt scrut_ty alt_ty (LitAlt lit, args, rhs) + | integerTy `eqType` scrut_ty + = failWithL integerScrutinisedMsg + | otherwise + = do { checkL (null args) (mkDefaultArgsMsg args) + ; checkTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty) + ; checkAltExpr rhs alt_ty } where lit_ty = literalType lit @@ -1070,6 +1073,10 @@ mkBadPatMsg con_result_ty scrut_ty text "Scrutinee type:" <+> ppr scrut_ty ] +integerScrutinisedMsg :: Message +integerScrutinisedMsg + = text "In a case alternative, scrutinee type is Integer" + mkBadAltMsg :: Type -> CoreAlt -> Message mkBadAltMsg scrut_ty alt = vcat [ text "Data alternative when scrutinee is not a tycon application", diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index fdd92794bb..b480c6bcef 100644 --- a/compiler/coreSyn/CorePrep.lhs +++ b/compiler/coreSyn/CorePrep.lhs @@ -11,7 +11,7 @@ module CorePrep ( #include "HsVersions.h" -import PrelNames ( lazyIdKey, hasKey ) +import PrelNames import CoreUtils import CoreArity import CoreFVs @@ -20,6 +20,7 @@ import CoreSyn import CoreSubst import OccurAnal ( occurAnalyseExpr ) import Type +import Literal import Coercion import TyCon import Demand @@ -28,6 +29,7 @@ import VarSet import VarEnv import Id import IdInfo +import MkId import DataCon import PrimOp import BasicTypes @@ -41,7 +43,10 @@ import Pair import Outputable import MonadUtils import FastString +import Config +import Data.Bits import Data.List ( mapAccumL ) +import Data.Word import Control.Monad \end{code} @@ -446,6 +451,7 @@ 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)) = cpeInteger env i cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr) cpeRhsE env expr@(Var {}) = cpeApp env expr @@ -495,6 +501,41 @@ 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 + -- --------------------------------------------------------------------------- -- CpeBody: produces a result satisfying CpeBody -- --------------------------------------------------------------------------- diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index bc1e45ee33..be071191a2 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -1539,6 +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 (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 214615866d..53355910d3 100644 --- a/compiler/coreSyn/MkCore.lhs +++ b/compiler/coreSyn/MkCore.lhs @@ -219,39 +219,7 @@ 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 - | inIntRange i -- Small enough, so start from an Int - = do integer_id <- lookupId smallIntegerName - return (mkSmallIntegerLit integer_id i) - --- Special case for integral literals with a large magnitude: --- They are transformed into an expression involving only smaller --- integral literals. This improves constant folding. - - | otherwise = do -- Big, so start from a string - plus_id <- lookupId plusIntegerName - times_id <- lookupId timesIntegerName - integer_id <- lookupId smallIntegerName - let - lit i = mkSmallIntegerLit integer_id i - plus a b = Var plus_id `App` a `App` b - times a b = Var times_id `App` a `App` b - - -- Transform i into (x1 + (x2 + (x3 + (...) * b) * b) * b) with abs xi <= b - horner :: Integer -> Integer -> CoreExpr - horner b i | abs q <= 1 = if r == 0 || r == i - then lit i - else lit r `plus` lit (i-r) - | r == 0 = horner b q `times` lit b - | otherwise = lit r `plus` (horner b q `times` lit b) - where - (q,r) = i `quotRem` b - - return (horner tARGET_MAX_INT i) - where - mkSmallIntegerLit :: Id -> Integer -> CoreExpr - mkSmallIntegerLit small_integer i = mkApps (Var small_integer) [mkIntLit i] - +mkIntegerExpr i = return (Lit (LitInteger i)) -- | Create a 'CoreExpr' which will evaluate to the given @Float@ mkFloatExpr :: Float -> CoreExpr diff --git a/compiler/ghc.mk b/compiler/ghc.mk index 1a7fa07219..735d0ec183 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -51,6 +51,8 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/. @echo >> $@ @echo '#include "ghc_boot_platform.h"' >> $@ @echo >> $@ + @echo 'data IntegerLibrary = IntegerGMP | IntegerSimple' >> $@ + @echo >> $@ @echo 'cBuildPlatformString :: String' >> $@ @echo 'cBuildPlatformString = BuildPlatform_NAME' >> $@ @echo 'cHostPlatformString :: String' >> $@ @@ -76,6 +78,14 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/. @echo 'cLdLinkerOpts = words "$(CONF_LD_LINKER_OPTS_STAGE$*)"' >> $@ @echo 'cIntegerLibrary :: String' >> $@ @echo 'cIntegerLibrary = "$(INTEGER_LIBRARY)"' >> $@ + @echo 'cIntegerLibraryType :: IntegerLibrary' >> $@ +ifeq "$(INTEGER_LIBRARY)" "integer-gmp" + @echo 'cIntegerLibraryType = IntegerGMP' >> $@ +else ifeq "$(INTEGER_LIBRARY)" "integer-simple" + @echo 'cIntegerLibraryType = IntegerSimple' >> $@ +else ifneq "$(CLEANING)" "YES" +$(error Unknown integer library) +endif @echo 'cSupportsSplitObjs :: String' >> $@ @echo 'cSupportsSplitObjs = "$(SupportsSplitObjs)"' >> $@ @echo 'cGhcWithInterpreter :: String' >> $@ diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs index 8cbf5d0310..8778933bdb 100644 --- a/compiler/ghci/ByteCodeGen.lhs +++ b/compiler/ghci/ByteCodeGen.lhs @@ -1241,6 +1241,10 @@ pushAtom _ _ (AnnLit lit) MachChar _ -> code NonPtrArg MachNullAddr -> code NonPtrArg MachStr s -> pushStr s + -- 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" where code rep = let size_host_words = fromIntegral (cgRepSizeW rep) diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 467eb3f18e..2334d0519a 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -205,7 +205,7 @@ basicKnownKeyNames printName, fstName, sndName, -- Integer - integerTyConName, plusIntegerName, timesIntegerName, smallIntegerName, + plusIntegerName, timesIntegerName, smallIntegerName, integerToWordName, integerToIntName, minusIntegerName, negateIntegerName, eqIntegerName, neqIntegerName, absIntegerName, signumIntegerName, @@ -786,7 +786,7 @@ fromIntegerName = methName gHC_NUM (fsLit "fromInteger") fromIntegerClassOpKey minusName = methName gHC_NUM (fsLit "-") minusClassOpKey negateName = methName gHC_NUM (fsLit "negate") negateClassOpKey -integerTyConName, plusIntegerName, timesIntegerName, smallIntegerName, +plusIntegerName, timesIntegerName, smallIntegerName, integerToWordName, integerToIntName, minusIntegerName, negateIntegerName, eqIntegerName, neqIntegerName, absIntegerName, signumIntegerName, @@ -795,7 +795,6 @@ integerTyConName, plusIntegerName, timesIntegerName, smallIntegerName, gcdIntegerName, lcmIntegerName, andIntegerName, orIntegerName, xorIntegerName, complementIntegerName, shiftLIntegerName, shiftRIntegerName :: Name -integerTyConName = tcQual gHC_INTEGER_TYPE (fsLit "Integer") integerTyConKey plusIntegerName = varQual gHC_INTEGER_TYPE (fsLit "plusInteger") plusIntegerIdKey timesIntegerName = varQual gHC_INTEGER_TYPE (fsLit "timesInteger") timesIntegerIdKey smallIntegerName = varQual gHC_INTEGER_TYPE (fsLit "smallInteger") smallIntegerIdKey @@ -1133,7 +1132,8 @@ addrPrimTyConKey, arrayPrimTyConKey, boolTyConKey, byteArrayPrimTyConKey, charPrimTyConKey, charTyConKey, doublePrimTyConKey, doubleTyConKey, floatPrimTyConKey, floatTyConKey, funTyConKey, intPrimTyConKey, intTyConKey, int8TyConKey, int16TyConKey, int32PrimTyConKey, - int32TyConKey, int64PrimTyConKey, int64TyConKey, integerTyConKey, + int32TyConKey, int64PrimTyConKey, int64TyConKey, + integerTyConKey, digitsTyConKey, listTyConKey, foreignObjPrimTyConKey, weakPrimTyConKey, mutableArrayPrimTyConKey, mutableByteArrayPrimTyConKey, orderingTyConKey, mVarPrimTyConKey, ratioTyConKey, rationalTyConKey, @@ -1159,8 +1159,9 @@ int32TyConKey = mkPreludeTyConUnique 19 int64PrimTyConKey = mkPreludeTyConUnique 20 int64TyConKey = mkPreludeTyConUnique 21 integerTyConKey = mkPreludeTyConUnique 22 -listTyConKey = mkPreludeTyConUnique 23 -foreignObjPrimTyConKey = mkPreludeTyConUnique 24 +digitsTyConKey = mkPreludeTyConUnique 23 +listTyConKey = mkPreludeTyConUnique 24 +foreignObjPrimTyConKey = mkPreludeTyConUnique 25 weakPrimTyConKey = mkPreludeTyConUnique 27 mutableArrayPrimTyConKey = mkPreludeTyConUnique 28 mutableByteArrayPrimTyConKey = mkPreludeTyConUnique 29 @@ -1349,6 +1350,22 @@ ltDataConKey, eqDataConKey, gtDataConKey :: Unique ltDataConKey = mkPreludeDataConUnique 27 eqDataConKey = mkPreludeDataConUnique 28 gtDataConKey = mkPreludeDataConUnique 29 + +-- For integer-gmp only +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} %************************************************************************ diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs index 9dbc32f4fc..502447d17d 100644 --- a/compiler/prelude/PrelRules.lhs +++ b/compiler/prelude/PrelRules.lhs @@ -611,8 +611,6 @@ builtinRules ru_nargs = 2, ru_try = match_eq_string }, BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName, ru_nargs = 2, ru_try = match_inline }, - -- TODO: All the below rules need to handle target platform - -- having a different wordsize than the host platform rule_Integer_convert "integerToWord" integerToWordName mkWordLitWord, rule_Integer_convert "integerToInt" integerToIntName mkIntLitInt, rule_Integer_binop "plusInteger" plusIntegerName (+), @@ -661,7 +659,6 @@ builtinRules = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, ru_try = match_Integer_binop_Ordering op } - --------------------------------------------------- -- The rule is this: -- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) @@ -729,75 +726,48 @@ match_Integer_convert :: Num a -> IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_Integer_convert convert _ [x] - | (Var fx, [Lit (MachInt ix)]) <- collectArgs x, - idName fx == smallIntegerName - = Just (convert (fromIntegral ix)) +match_Integer_convert convert _ [Lit (LitInteger x)] + = Just (convert (fromIntegral x)) match_Integer_convert _ _ _ = Nothing match_Integer_unop :: (Integer -> Integer) -> IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_Integer_unop unop _ [x] - | (Var fx, [Lit (MachInt ix)]) <- collectArgs x, - idName fx == smallIntegerName, - let iz = unop ix, - iz >= fromIntegral (minBound :: Int), - iz <= fromIntegral (maxBound :: Int) - = Just (Var fx `App` Lit (MachInt iz)) +match_Integer_unop unop _ [Lit (LitInteger x)] + = Just (Lit (LitInteger (unop x))) match_Integer_unop _ _ _ = Nothing match_Integer_binop :: (Integer -> Integer -> Integer) -> IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_Integer_binop binop _ [x, y] - | (Var fx, [Lit (MachInt ix)]) <- collectArgs x, - (Var fy, [Lit (MachInt iy)]) <- collectArgs y, - idName fx == smallIntegerName, - idName fy == smallIntegerName, - let iz = ix `binop` iy, - iz >= fromIntegral (minBound :: Int), - iz <= fromIntegral (maxBound :: Int) - = Just (Var fx `App` Lit (MachInt iz)) +match_Integer_binop binop _ [Lit (LitInteger x), Lit (LitInteger y)] + = Just (Lit (LitInteger (x `binop` y))) match_Integer_binop _ _ _ = Nothing match_Integer_Int_binop :: (Integer -> Int -> Integer) -> IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_Integer_Int_binop binop _ [x, Lit (MachInt iy)] - | (Var fx, [Lit (MachInt ix)]) <- collectArgs x, - idName fx == smallIntegerName, - let iz = ix `binop` fromIntegral iy, - iz >= fromIntegral (minBound :: Int), - iz <= fromIntegral (maxBound :: Int) - = Just (Var fx `App` Lit (MachInt iz)) +match_Integer_Int_binop binop _ [Lit (LitInteger x), Lit (MachInt y)] + = Just (Lit (LitInteger (x `binop` fromIntegral y))) match_Integer_Int_binop _ _ _ = Nothing match_Integer_binop_Bool :: (Integer -> Integer -> Bool) -> IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_Integer_binop_Bool binop _ [x, y] - | (Var fx, [Lit (MachInt ix)]) <- collectArgs x, - (Var fy, [Lit (MachInt iy)]) <- collectArgs y, - idName fx == smallIntegerName, - idName fy == smallIntegerName - = Just (if ix `binop` iy then trueVal else falseVal) +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 match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering) -> IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_Integer_binop_Ordering binop _ [x, y] - | (Var fx, [Lit (MachInt ix)]) <- collectArgs x, - (Var fy, [Lit (MachInt iy)]) <- collectArgs y, - idName fx == smallIntegerName, - idName fy == smallIntegerName - = Just $ case ix `binop` iy of +match_Integer_binop_Ordering binop _ [Lit (LitInteger x), Lit (LitInteger y)] + = Just $ case x `binop` y of LT -> ltVal EQ -> eqVal GT -> gtVal diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index bad62a599b..8ab7ba478b 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -24,6 +24,15 @@ module TysWiredIn ( charTyCon, charDataCon, charTyCon_RDR, charTy, stringTy, charTyConName, + -- * Integer + integerTy, integerTyConName, + -- integer-gmp only: + integerGmpSDataConName, + -- integer-simple only: + integerSimpleNaughtDataConName, + integerSimplePositiveDataConName, integerSimpleNegativeDataConName, + digitsTy, digitsSomeDataConName, digitsNoneDataConName, + -- * Double doubleTyCon, doubleDataCon, doubleTy, doubleTyConName, @@ -88,6 +97,7 @@ import Unique ( incrUnique, mkTupleTyConUnique, import Data.Array import FastString import Outputable +import Config alpha_tyvar :: [TyVar] alpha_tyvar = [alphaTyVar] @@ -132,6 +142,8 @@ wiredInTyCons = [ unitTyCon -- Not treated like other tuples, because , doubleTyCon , floatTyCon , intTyCon + , integerTyCon + , digitsTyCon , listTyCon , parrTyCon , eqTyCon @@ -177,6 +189,25 @@ 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: +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 gHC_PARR' (fsLit "[::]") parrTyConKey parrTyCon @@ -424,6 +455,66 @@ stringTy = mkListTy charTy -- convenience only \end{code} \begin{code} +integerTy :: Type +integerTy = mkTyConTy integerTyCon + +integerTyCon :: TyCon +integerTyCon = case cIntegerLibraryType of + IntegerGMP -> + pcNonRecDataTyCon integerTyConName [] + [integerGmpSDataCon, integerGmpJDataCon] + IntegerSimple -> + pcNonRecDataTyCon integerTyConName [] + [integerSimplePositiveDataCon, + integerSimpleNegativeDataCon, + integerSimpleNaughtDataCon] + +integerGmpSDataCon :: DataCon +integerGmpSDataCon = pcDataCon integerGmpSDataConName [] + [intPrimTy] + integerTyCon + +-- integerGmpJDataCon isn't exported, but we need to define it to fill +-- out integerTyCon +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} intTy :: Type intTy = mkTyConTy intTyCon diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs index 2225f39956..8a5327ef5d 100644 --- a/compiler/simplCore/OccurAnal.lhs +++ b/compiler/simplCore/OccurAnal.lhs @@ -1052,7 +1052,7 @@ occAnal :: OccEnv CoreExpr) occAnal _ expr@(Type _) = (emptyDetails, expr) -occAnal _ expr@(Lit _) = (emptyDetails, expr) +occAnal _ expr@(Lit _) = (emptyDetails, expr) occAnal env expr@(Var v) = (mkOneOcc env v False, expr) -- At one stage, I gathered the idRuleVars for v here too, -- which in a way is the right thing to do. diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs index bd4e0ae6bd..d55943c1d5 100644 --- a/compiler/stgSyn/CoreToStg.lhs +++ b/compiler/stgSyn/CoreToStg.lhs @@ -29,6 +29,7 @@ import Maybes ( maybeToBool ) import Name ( getOccName, isExternalName, nameOccName ) import OccName ( occNameString, occNameFS ) import BasicTypes ( Arity ) +import Literal import Module import Outputable import MonadUtils @@ -312,6 +313,9 @@ on these components, but it in turn is not scrutinised as the basis for any 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 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 1690079bba..66402b8976 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -54,6 +54,7 @@ import Var ( Var, EvVar, varType, setVarType ) import VarEnv import VarSet import PrelNames +import TysWiredIn import SrcLoc import DynFlags import Bag |