Un-wire `Integer` type (re #9714)

Integer is currently a wired-in type for integer-gmp. This requires
replicating its inner structure in `TysWiredIn`, which makes it much
harder to change Integer to a more complex representation (as
e.g. needed for implementing #9281)

This commit stops `Integer` being a wired-in type, and makes it
known-key type instead, thereby simplifying code notably.

Reviewed By: austin

Differential Revision: https://phabricator.haskell.org/D351

diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs
index bbf104b..7ef5d42 100644 (file)
--- a/compiler/coreSyn/CorePrep.lhs
+++ b/compiler/coreSyn/CorePrep.lhs
@@ -9,7 +9,7 @@ Core pass to saturate constructors and PrimOps
 
 module CorePrep (
       corePrepPgm, corePrepExpr, cvtLitInteger,
-      lookupMkIntegerName,
+      lookupMkIntegerName, lookupIntegerSDataConName
   ) where
 
 #include "HsVersions.h"
@@ -479,7 +479,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 (cpe_dynFlags env) (getMkIntegerId env) i)
+    = cpeRhsE env (cvtLitInteger (cpe_dynFlags env) (getMkIntegerId env)
+                   (cpe_integerSDataCon env) i)
 cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr)
 cpeRhsE env expr@(Var {})  = cpeApp env expr
 
@@ -529,18 +530,17 @@ cpeRhsE env (Case scrut bndr ty alts)
             ; rhs' <- cpeBodyNF env2 rhs
             ; return (con, bs', rhs') }
 
-cvtLitInteger :: DynFlags -> Id -> Integer -> CoreExpr
+cvtLitInteger :: DynFlags -> Id -> Maybe DataCon -> 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.
 -- See Note [Integer literals] in Literal
-cvtLitInteger dflags mk_integer i
-  | cIntegerLibraryType == IntegerGMP
-  , inIntRange dflags i       -- Special case for small integers in GMP
-    = mkConApp integerGmpSDataCon [Lit (mkMachInt dflags i)]
+cvtLitInteger dflags _ (Just sdatacon) i
+  | inIntRange dflags i -- Special case for small integers
+    = mkConApp sdatacon [Lit (mkMachInt dflags i)]
 
-  | otherwise
+cvtLitInteger dflags mk_integer _ i
     = mkApps (Var mk_integer) [isNonNegative, ints]
   where isNonNegative = if i < 0 then mkConApp falseDataCon []
                                  else mkConApp trueDataCon  []
@@ -1110,25 +1110,40 @@ allLazyNested is_rec (Floats IfUnboxedOk _) = isNonRec is_rec
 data CorePrepEnv = CPE {
                        cpe_dynFlags    :: DynFlags,
                        cpe_env         :: (IdEnv Id), -- Clone local Ids
-                       cpe_mkIntegerId :: Id
+                       cpe_mkIntegerId :: Id,
+                       cpe_integerSDataCon :: Maybe DataCon
                    }
 
 lookupMkIntegerName :: DynFlags -> HscEnv -> IO Id
 lookupMkIntegerName dflags hsc_env
-    = if thisPackage dflags == primPackageKey
-      then return $ panic "Can't use Integer in ghc-prim"
-      else if thisPackage dflags == integerPackageKey
-      then return $ panic "Can't use Integer in integer"
-      else liftM tyThingId
-         $ initTcForLookup hsc_env (tcLookupGlobal mkIntegerName)
+    = guardIntegerUse dflags $ liftM tyThingId $
+      initTcForLookup hsc_env (tcLookupGlobal mkIntegerName)
+
+lookupIntegerSDataConName :: DynFlags -> HscEnv -> IO (Maybe DataCon)
+lookupIntegerSDataConName dflags hsc_env = case cIntegerLibraryType of
+    IntegerGMP -> guardIntegerUse dflags $ liftM Just $
+                  initTcForLookup hsc_env (tcLookupDataCon integerSDataConName)
+
+    IntegerSimple -> return Nothing
+
+-- | Helper for 'lookupMkIntegerName' and 'lookupIntegerSDataConName'
+guardIntegerUse :: DynFlags -> IO a -> IO a
+guardIntegerUse dflags act
+  | thisPackage dflags == primPackageKey
+    = return $ panic "Can't use Integer in ghc-prim"
+  | thisPackage dflags == integerPackageKey
+    = return $ panic "Can't use Integer in integer-*"
+  | otherwise = act
 
 mkInitialCorePrepEnv :: DynFlags -> HscEnv -> IO CorePrepEnv
 mkInitialCorePrepEnv dflags hsc_env
     = do mkIntegerId <- lookupMkIntegerName dflags hsc_env
+         integerSDataCon <- lookupIntegerSDataConName dflags hsc_env
          return $ CPE {
                       cpe_dynFlags = dflags,
                       cpe_env = emptyVarEnv,
-                      cpe_mkIntegerId = mkIntegerId
+                      cpe_mkIntegerId = mkIntegerId,
+                      cpe_integerSDataCon = integerSDataCon
                   }
 
 extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv

diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index 5ba640f..02db8ef 100644 (file)
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -1113,7 +1113,8 @@ tidyTopBinds :: HscEnv
 
 tidyTopBinds hsc_env this_mod unfold_env init_occ_env binds
   = do mkIntegerId <- lookupMkIntegerName dflags hsc_env
-       return $ tidy mkIntegerId init_env binds
+       integerSDataCon <- lookupIntegerSDataConName dflags hsc_env
+       return $ tidy mkIntegerId integerSDataCon init_env binds
   where
     dflags = hsc_dflags hsc_env
 
@@ -1121,32 +1122,37 @@ tidyTopBinds hsc_env this_mod unfold_env init_occ_env binds
 
     this_pkg = thisPackage dflags
 
-    tidy _           env []     = (env, [])
-    tidy mkIntegerId env (b:bs) = let (env1, b')  = tidyTopBind dflags this_pkg this_mod mkIntegerId unfold_env env b
-                                      (env2, bs') = tidy mkIntegerId env1 bs
-                                  in
-                                      (env2, b':bs')
+    tidy _           _                 env []     = (env, [])
+    tidy mkIntegerId integerSDataCon env (b:bs)
+        = let (env1, b')  = tidyTopBind dflags this_pkg this_mod
+                            mkIntegerId integerSDataCon unfold_env env b
+              (env2, bs') = tidy mkIntegerId integerSDataCon env1 bs
+          in  (env2, b':bs')
 
 ------------------------
 tidyTopBind  :: DynFlags
              -> PackageKey
              -> Module
              -> Id
+             -> Maybe DataCon
              -> UnfoldEnv
              -> TidyEnv
              -> CoreBind
              -> (TidyEnv, CoreBind)
 
-tidyTopBind dflags this_pkg this_mod mkIntegerId unfold_env (occ_env,subst1) (NonRec bndr rhs)
+tidyTopBind dflags this_pkg this_mod mkIntegerId integerSDataCon unfold_env
+            (occ_env,subst1) (NonRec bndr rhs)
   = (tidy_env2,  NonRec bndr' rhs')
   where
     Just (name',show_unfold) = lookupVarEnv unfold_env bndr
-    caf_info      = hasCafRefs dflags this_pkg this_mod (mkIntegerId, subst1) (idArity bndr) rhs
+    caf_info      = hasCafRefs dflags this_pkg this_mod
+                    (mkIntegerId, integerSDataCon, subst1) (idArity bndr) rhs
     (bndr', rhs') = tidyTopPair dflags show_unfold tidy_env2 caf_info name' (bndr, rhs)
     subst2        = extendVarEnv subst1 bndr bndr'
     tidy_env2     = (occ_env, subst2)
 
-tidyTopBind dflags this_pkg this_mod mkIntegerId unfold_env (occ_env,subst1) (Rec prs)
+tidyTopBind dflags this_pkg this_mod mkIntegerId integerSDataCon unfold_env
+            (occ_env,subst1) (Rec prs)
   = (tidy_env2, Rec prs')
   where
     prs' = [ tidyTopPair dflags show_unfold tidy_env2 caf_info name' (id,rhs)
@@ -1163,7 +1169,9 @@ tidyTopBind dflags this_pkg this_mod mkIntegerId unfold_env (occ_env,subst1) (Re
         -- the CafInfo for a recursive group says whether *any* rhs in
         -- the group may refer indirectly to a CAF (because then, they all do).
     caf_info
-        | or [ mayHaveCafRefs (hasCafRefs dflags this_pkg this_mod (mkIntegerId, subst1) (idArity bndr) rhs)
+        | or [ mayHaveCafRefs (hasCafRefs dflags this_pkg this_mod
+                               (mkIntegerId, integerSDataCon, subst1)
+                               (idArity bndr) rhs)
              | (bndr,rhs) <- prs ] = MayHaveCafRefs
         | otherwise                = NoCafRefs
 
@@ -1300,7 +1308,7 @@ CAF list to keep track of non-collectable CAFs.
 
 \begin{code}
 hasCafRefs :: DynFlags -> PackageKey -> Module
-           -> (Id, VarEnv Var) -> Arity -> CoreExpr
+           -> (Id, Maybe DataCon, VarEnv Var) -> Arity -> CoreExpr
            -> CafInfo
 hasCafRefs dflags this_pkg this_mod p arity expr
   | is_caf || mentions_cafs = MayHaveCafRefs
@@ -1316,7 +1324,7 @@ hasCafRefs dflags this_pkg this_mod p arity expr
   -- CorePrep later on, and we don't want to duplicate that
   -- knowledge in rhsIsStatic below.
 
-cafRefsE :: DynFlags -> (Id, VarEnv Id) -> Expr a -> FastBool
+cafRefsE :: DynFlags -> (Id, Maybe DataCon, VarEnv Id) -> Expr a -> FastBool
 cafRefsE _      p (Var id)            = cafRefsV p id
 cafRefsE dflags p (Lit lit)           = cafRefsL dflags p lit
 cafRefsE dflags p (App f a)           = fastOr (cafRefsE dflags p f) (cafRefsE dflags p) a
@@ -1328,19 +1336,20 @@ cafRefsE dflags p (Cast e _co)        = cafRefsE dflags p e
 cafRefsE _      _ (Type _)            = fastBool False
 cafRefsE _      _ (Coercion _)        = fastBool False
 
-cafRefsEs :: DynFlags -> (Id, VarEnv Id) -> [Expr a] -> FastBool
+cafRefsEs :: DynFlags -> (Id, Maybe DataCon, VarEnv Id) -> [Expr a] -> FastBool
 cafRefsEs _      _ []     = fastBool False
 cafRefsEs dflags p (e:es) = fastOr (cafRefsE dflags p e) (cafRefsEs dflags p) es
 
-cafRefsL :: DynFlags -> (Id, VarEnv Id) -> Literal -> FastBool
+cafRefsL :: DynFlags -> (Id, Maybe DataCon, VarEnv Id) -> Literal -> FastBool
 -- Don't forget that mk_integer id might have Caf refs!
 -- We first need to convert the Integer into its final form, to
 -- see whether mkInteger is used.
-cafRefsL dflags p@(mk_integer, _) (LitInteger i _) = cafRefsE dflags p (cvtLitInteger dflags mk_integer i)
+cafRefsL dflags p@(mk_integer, sdatacon, _) (LitInteger i _)
+    = cafRefsE dflags p (cvtLitInteger dflags mk_integer sdatacon i)
 cafRefsL _      _ _                         = fastBool False
 
-cafRefsV :: (Id, VarEnv Id) -> Id -> FastBool
-cafRefsV (_, p) id
+cafRefsV :: (Id, Maybe DataCon, VarEnv Id) -> Id -> FastBool
+cafRefsV (_, _, p) id
   | not (isLocalId id)            = fastBool (mayHaveCafRefs (idCafInfo id))
   | Just id' <- lookupVarEnv p id = fastBool (mayHaveCafRefs (idCafInfo id'))
   | otherwise                     = fastBool False

diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index e053b11..4e98739 100644 (file)
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -125,6 +125,8 @@ import BasicTypes
 import Name
 import SrcLoc
 import FastString
+import Config ( cIntegerLibraryType, IntegerLibrary(..) )
+import Panic ( panic )
 \end{code}
 
 
@@ -356,7 +358,9 @@ basicKnownKeyNames
 
         -- GHCi Sandbox
         , ghciIoClassName, ghciStepIoMName
-    ]
+    ] ++ case cIntegerLibraryType of
+           IntegerGMP    -> [integerSDataConName]
+           IntegerSimple -> []
 
 genericTyConNames :: [Name]
 genericTyConNames = [
@@ -916,7 +920,7 @@ fromIntegerName   = varQual gHC_NUM (fsLit "fromInteger") fromIntegerClassOpKey
 minusName         = varQual gHC_NUM (fsLit "-")           minusClassOpKey
 negateName        = varQual gHC_NUM (fsLit "negate")      negateClassOpKey
 
-integerTyConName, mkIntegerName,
+integerTyConName, mkIntegerName, integerSDataConName,
     integerToWord64Name, integerToInt64Name,
     word64ToIntegerName, int64ToIntegerName,
     plusIntegerName, timesIntegerName, smallIntegerName,
@@ -934,6 +938,10 @@ integerTyConName, mkIntegerName,
     andIntegerName, orIntegerName, xorIntegerName, complementIntegerName,
     shiftLIntegerName, shiftRIntegerName :: Name
 integerTyConName      = tcQual  gHC_INTEGER_TYPE (fsLit "Integer")           integerTyConKey
+integerSDataConName   = conName gHC_INTEGER_TYPE (fsLit n)                   integerSDataConKey
+  where n = case cIntegerLibraryType of
+            IntegerGMP    -> "S#"
+            IntegerSimple -> panic "integerSDataConName evaluated for integer-simple"
 mkIntegerName         = varQual gHC_INTEGER_TYPE (fsLit "mkInteger")         mkIntegerIdKey
 integerToWord64Name   = varQual gHC_INTEGER_TYPE (fsLit "integerToWord64")   integerToWord64IdKey
 integerToInt64Name    = varQual gHC_INTEGER_TYPE (fsLit "integerToInt64")    integerToInt64IdKey
@@ -1515,8 +1523,8 @@ unitTyConKey = mkTupleTyConUnique BoxedTuple 0
 
 \begin{code}
 charDataConKey, consDataConKey, doubleDataConKey, falseDataConKey,
-    floatDataConKey, intDataConKey, nilDataConKey, ratioDataConKey,
-    stableNameDataConKey, trueDataConKey, wordDataConKey,
+    floatDataConKey, intDataConKey, integerSDataConKey, nilDataConKey,
+    ratioDataConKey, stableNameDataConKey, trueDataConKey, wordDataConKey,
     ioDataConKey, integerDataConKey, eqBoxDataConKey, coercibleDataConKey :: Unique
 charDataConKey                          = mkPreludeDataConUnique  1
 consDataConKey                          = mkPreludeDataConUnique  2
@@ -1524,6 +1532,7 @@ doubleDataConKey                        = mkPreludeDataConUnique  3
 falseDataConKey                         = mkPreludeDataConUnique  4
 floatDataConKey                         = mkPreludeDataConUnique  5
 intDataConKey                           = mkPreludeDataConUnique  6
+integerSDataConKey                      = mkPreludeDataConUnique  7
 nilDataConKey                           = mkPreludeDataConUnique 11
 ratioDataConKey                         = mkPreludeDataConUnique 12
 stableNameDataConKey                    = mkPreludeDataConUnique 14
@@ -1553,11 +1562,6 @@ ltDataConKey                            = mkPreludeDataConUnique 27
 eqDataConKey                            = mkPreludeDataConUnique 28
 gtDataConKey                            = mkPreludeDataConUnique 29
 
--- For integer-gmp only
-integerGmpSDataConKey, integerGmpJDataConKey :: Unique
-integerGmpSDataConKey                   = mkPreludeDataConUnique 30
-integerGmpJDataConKey                   = mkPreludeDataConUnique 31
-
 coercibleDataConKey                     = mkPreludeDataConUnique 32
 \end{code}
 

diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs
index b4ada73..f4dca9a 100644 (file)
--- a/compiler/prelude/TysWiredIn.lhs
+++ b/compiler/prelude/TysWiredIn.lhs
@@ -29,9 +29,6 @@ module TysWiredIn (
         charTyCon, charDataCon, charTyCon_RDR,
         charTy, stringTy, charTyConName,
 
-        -- integer-gmp only:
-        integerGmpSDataCon,
-
         -- * Double
         doubleTyCon, doubleDataCon, doubleTy, doubleTyConName,
 
@@ -106,7 +103,6 @@ import Unique           ( incrUnique, mkTupleTyConUnique,
 import Data.Array
 import FastString
 import Outputable
-import Config
 import Util
 import BooleanFormula   ( mkAnd )
 
@@ -160,9 +156,6 @@ wiredInTyCons = [ unitTyCon     -- Not treated like other tuples, because
               , typeNatKindCon
               , typeSymbolKindCon
               ]
-           ++ (case cIntegerLibraryType of
-               IntegerGMP -> [integerTyCon]
-               _ -> [])
 \end{code}
 
 \begin{code}
@@ -217,15 +210,6 @@ typeNatKindConName, typeSymbolKindConName :: Name
 typeNatKindConName    = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "Nat")    typeNatKindConNameKey    typeNatKindCon
 typeSymbolKindConName = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "Symbol") typeSymbolKindConNameKey typeSymbolKindCon
 
--- 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
-
 parrTyConName, parrDataConName :: Name
 parrTyConName   = mkWiredInTyConName   BuiltInSyntax
                     gHC_PARR' (fsLit "[::]") parrTyConKey parrTyCon
@@ -571,28 +555,6 @@ stringTy = mkListTy charTy -- convenience only
 \end{code}
 
 \begin{code}
-integerTyCon :: TyCon
-integerTyCon = case cIntegerLibraryType of
-               IntegerGMP ->
-                   pcNonRecDataTyCon integerRealTyConName Nothing []
-                                     [integerGmpSDataCon, integerGmpJDataCon]
-               _ ->
-                   panic "Evaluated integerTyCon, but not using IntegerGMP"
-
-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
-\end{code}
-
-\begin{code}
 intTy :: Type
 intTy = mkTyConTy intTyCon