change how Integer's are handled in Core

We now treat them as literals until CorePrep, when we finally
convert them into the real Core representation. This makes it a lot
simpler to implement built-in rules on them.

3 files changed, 126 insertions, 48 deletions

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