Commit 0e1f0f7d authored by Herbert Valerio Riedel's avatar Herbert Valerio Riedel 🕺

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
parent 9e2cb00e
......@@ -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
......
......@@ -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
......
......@@ -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}
......
......@@ -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
......@@ -570,28 +554,6 @@ stringTy :: Type
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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment