diff options
author | Herbert Valerio Riedel <hvr@gnu.org> | 2014-10-27 16:44:36 +0100 |
---|---|---|
committer | Herbert Valerio Riedel <hvr@gnu.org> | 2014-10-27 16:47:37 +0100 |
commit | 0e1f0f7d1682d77c5dbb1d2b36f57037113cf7b4 (patch) | |
tree | 145d7716300b6df6022a453e192b0eaea25aca99 | |
parent | 9e2cb00e5af9d86546f82a74c3d0382e65704d56 (diff) | |
download | haskell-0e1f0f7d1682d77c5dbb1d2b36f57037113cf7b4.tar.gz |
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
-rw-r--r-- | compiler/coreSyn/CorePrep.lhs | 47 | ||||
-rw-r--r-- | compiler/main/TidyPgm.lhs | 43 | ||||
-rw-r--r-- | compiler/prelude/PrelNames.lhs | 22 | ||||
-rw-r--r-- | compiler/prelude/TysWiredIn.lhs | 38 |
4 files changed, 70 insertions, 80 deletions
diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index bbf104b127..7ef5d42d72 100644 --- 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 5ba640fd05..02db8efec0 100644 --- 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 e053b11c98..4e98739905 100644 --- 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 b4ada73156..f4dca9a0de 100644 --- 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 |