Commit 96aa5787 authored by Sylvain Henry's avatar Sylvain Henry Committed by Ben Gamari

Update compiler

Thanks to ghc-bignum, the compiler can be simplified:

* Types and constructors of Integer and Natural can be wired-in. It
  means that we don't have to query them from interfaces. It also means
  that numeric literals don't have to carry their type with them.

* The same code is used whatever ghc-bignum backend is enabled. In
  particular, conversion of bignum literals into final Core expressions
  is now much more straightforward. Bignum closure inspection too.

* GHC itself doesn't depend on any integer-* package anymore

* The `integerLibrary` setting is gone.
parent 9f96bc12
This diff is collapsed.
......@@ -453,7 +453,7 @@ Duplicate YES NO
just look at Control.Monad.ST.Lazy.Imp.strictToLazy! We get
something like this
p = case readMutVar# s v of
(# s', r #) -> (S# s', r)
(# s', r #) -> (State# s', r)
s' = case p of (s', r) -> s'
r = case p of (s', r) -> r
......
......@@ -134,7 +134,16 @@ module GHC.Builtin.Types (
oneDataConTyCon, manyDataConTyCon,
multMulTyCon,
unrestrictedFunTyCon, unrestrictedFunTyConName
unrestrictedFunTyCon, unrestrictedFunTyConName,
-- * Bignum
integerTy, integerTyCon, integerTyConName,
integerISDataCon, integerISDataConName,
integerIPDataCon, integerIPDataConName,
integerINDataCon, integerINDataConName,
naturalTy, naturalTyCon, naturalTyConName,
naturalNSDataCon, naturalNSDataConName,
naturalNBDataCon, naturalNBDataConName
) where
......@@ -252,6 +261,8 @@ wiredInTyCons = [ -- Units are not treated like other tuples, because they
, constraintKindTyCon
, liftedTypeKindTyCon
, multiplicityTyCon
, naturalTyCon
, integerTyCon
]
mkWiredInTyConName :: BuiltInSyntax -> Module -> FastString -> Unique -> TyCon -> Name
......@@ -1827,3 +1838,98 @@ extractPromotedList tys = go tys
| otherwise
= pprPanic "extractPromotedList" (ppr tys)
---------------------------------------
-- ghc-bignum
---------------------------------------
integerTyConName
, integerISDataConName
, integerIPDataConName
, integerINDataConName
:: Name
integerTyConName
= mkWiredInTyConName
UserSyntax
gHC_NUM_INTEGER
(fsLit "Integer")
integerTyConKey
integerTyCon
integerISDataConName
= mkWiredInDataConName
UserSyntax
gHC_NUM_INTEGER
(fsLit "IS")
integerISDataConKey
integerISDataCon
integerIPDataConName
= mkWiredInDataConName
UserSyntax
gHC_NUM_INTEGER
(fsLit "IP")
integerIPDataConKey
integerIPDataCon
integerINDataConName
= mkWiredInDataConName
UserSyntax
gHC_NUM_INTEGER
(fsLit "IN")
integerINDataConKey
integerINDataCon
integerTy :: Type
integerTy = mkTyConTy integerTyCon
integerTyCon :: TyCon
integerTyCon = pcTyCon integerTyConName Nothing []
[integerISDataCon, integerIPDataCon, integerINDataCon]
integerISDataCon :: DataCon
integerISDataCon = pcDataCon integerISDataConName [] [intPrimTy] integerTyCon
integerIPDataCon :: DataCon
integerIPDataCon = pcDataCon integerIPDataConName [] [byteArrayPrimTy] integerTyCon
integerINDataCon :: DataCon
integerINDataCon = pcDataCon integerINDataConName [] [byteArrayPrimTy] integerTyCon
naturalTyConName
, naturalNSDataConName
, naturalNBDataConName
:: Name
naturalTyConName
= mkWiredInTyConName
UserSyntax
gHC_NUM_NATURAL
(fsLit "Natural")
naturalTyConKey
naturalTyCon
naturalNSDataConName
= mkWiredInDataConName
UserSyntax
gHC_NUM_NATURAL
(fsLit "NS")
naturalNSDataConKey
naturalNSDataCon
naturalNBDataConName
= mkWiredInDataConName
UserSyntax
gHC_NUM_NATURAL
(fsLit "NB")
naturalNBDataConKey
naturalNBDataCon
naturalTy :: Type
naturalTy = mkTyConTy naturalTyCon
naturalTyCon :: TyCon
naturalTyCon = pcTyCon naturalTyConName Nothing []
[naturalNSDataCon, naturalNBDataCon]
naturalNSDataCon :: DataCon
naturalNSDataCon = pcDataCon naturalNSDataConName [] [wordPrimTy] naturalTyCon
naturalNBDataCon :: DataCon
naturalNBDataCon = pcDataCon naturalNBDataConName [] [byteArrayPrimTy] naturalTyCon
......@@ -54,3 +54,5 @@ unrestrictedFunTyCon :: TyCon
multMulTyCon :: TyCon
tupleTyConName :: TupleSort -> Arity -> Name
integerTy, naturalTy :: Type
......@@ -232,7 +232,7 @@ eqPhantPrimTyConName = mkBuiltInPrimTc (fsLit "~P#") eqPhantPrimTyConKe
realWorldTyConName = mkPrimTc (fsLit "RealWorld") realWorldTyConKey realWorldTyCon
arrayPrimTyConName = mkPrimTc (fsLit "Array#") arrayPrimTyConKey arrayPrimTyCon
byteArrayPrimTyConName = mkPrimTc (fsLit "ByteArray#") byteArrayPrimTyConKey byteArrayPrimTyCon
arrayArrayPrimTyConName = mkPrimTc (fsLit "ArrayArray#") arrayArrayPrimTyConKey arrayArrayPrimTyCon
arrayArrayPrimTyConName = mkPrimTc (fsLit "ArrayArray#") arrayArrayPrimTyConKey arrayArrayPrimTyCon
smallArrayPrimTyConName = mkPrimTc (fsLit "SmallArray#") smallArrayPrimTyConKey smallArrayPrimTyCon
mutableArrayPrimTyConName = mkPrimTc (fsLit "MutableArray#") mutableArrayPrimTyConKey mutableArrayPrimTyCon
mutableByteArrayPrimTyConName = mkPrimTc (fsLit "MutableByteArray#") mutableByteArrayPrimTyConKey mutableByteArrayPrimTyCon
......
......@@ -453,7 +453,7 @@ assembleI platform i = case i of
literal (LitChar c) = int (ord c)
literal (LitString bs) = lit [BCONPtrStr bs]
-- LitString requires a zero-terminator when emitted
literal (LitNumber nt i _) = case nt of
literal (LitNumber nt i) = case nt of
LitNumInt -> int (fromIntegral i)
LitNumWord -> int (fromIntegral i)
LitNumInt64 -> int64 (fromIntegral i)
......
......@@ -345,9 +345,10 @@ We have one literal, a literal Integer, that is lifted, and we don't
allow in a LitAlt, because LitAlt cases don't do any evaluation. Also
(see #5603) if you say
case 3 of
S# x -> ...
J# _ _ -> ...
(where S#, J# are the constructors for Integer) we don't want the
IS x -> ...
IP _ -> ...
IN _ -> ...
(where IS, IP, IN are the constructors for Integer) we don't want the
simplifier calling findAlt with argument (LitAlt 3). No no. Integer
literals are an opaque encoding of an algebraic data type, not of
an unlifted literal, like all the others.
......
......@@ -14,7 +14,7 @@ module GHC.Core.Make (
-- * Constructing boxed literals
mkWordExpr, mkWordExprWord,
mkIntExpr, mkIntExprInt,
mkIntExpr, mkIntExprInt, mkUncheckedIntExpr,
mkIntegerExpr, mkNaturalExpr,
mkFloatExpr, mkDoubleExpr,
mkCharExpr, mkStringExpr, mkStringExprFS, mkStringExprFSWith,
......@@ -253,6 +253,11 @@ castBottomExpr e res_ty
mkIntExpr :: Platform -> Integer -> CoreExpr -- Result = I# i :: Int
mkIntExpr platform i = mkCoreConApps intDataCon [mkIntLit platform i]
-- | Create a 'CoreExpr' which will evaluate to the given @Int@. Don't check
-- that the number is in the range of the target platform @Int@
mkUncheckedIntExpr :: Integer -> CoreExpr -- Result = I# i :: Int
mkUncheckedIntExpr i = mkCoreConApps intDataCon [Lit (mkLitIntUnchecked i)]
-- | Create a 'CoreExpr' which will evaluate to the given @Int@
mkIntExprInt :: Platform -> Int -> CoreExpr -- Result = I# i :: Int
mkIntExprInt platform i = mkCoreConApps intDataCon [mkIntLitInt platform i]
......@@ -266,14 +271,12 @@ mkWordExprWord :: Platform -> Word -> CoreExpr
mkWordExprWord platform w = mkCoreConApps wordDataCon [mkWordLitWord platform w]
-- | Create a 'CoreExpr' which will evaluate to the given @Integer@
mkIntegerExpr :: MonadThings m => Integer -> m CoreExpr -- Result :: Integer
mkIntegerExpr i = do t <- lookupTyCon integerTyConName
return (Lit (mkLitInteger i (mkTyConTy t)))
mkIntegerExpr :: Integer -> CoreExpr -- Result :: Integer
mkIntegerExpr i = Lit (mkLitInteger i)
-- | Create a 'CoreExpr' which will evaluate to the given @Natural@
mkNaturalExpr :: MonadThings m => Integer -> m CoreExpr
mkNaturalExpr i = do t <- lookupTyCon naturalTyConName
return (Lit (mkLitNatural i (mkTyConTy t)))
mkNaturalExpr :: Integer -> CoreExpr
mkNaturalExpr i = Lit (mkLitNatural i)
-- | Create a 'CoreExpr' which will evaluate to the given @Float@
mkFloatExpr :: Float -> CoreExpr
......
This diff is collapsed.
......@@ -4,6 +4,8 @@
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiWayIf #-}
module GHC.Core.SimpleOpt (
-- ** Simple expression optimiser
simpleOptPgm, simpleOptExpr, simpleOptExprWith,
......@@ -32,7 +34,7 @@ import {-# SOURCE #-} GHC.Core.Unfold( mkUnfolding )
import GHC.Core.Make ( FloatBind(..) )
import GHC.Core.Ppr ( pprCoreBindings, pprRules )
import GHC.Core.Opt.OccurAnal( occurAnalyseExpr, occurAnalysePgm )
import GHC.Types.Literal ( Literal(LitString) )
import GHC.Types.Literal
import GHC.Types.Id
import GHC.Types.Id.Info ( unfoldingInfo, setUnfoldingInfo, setRuleInfo, IdInfo (..) )
import GHC.Types.Var ( isNonCoVarId )
......@@ -1242,8 +1244,18 @@ exprIsLiteral_maybe env@(_, id_unf) e
= case e of
Lit l -> Just l
Tick _ e' -> exprIsLiteral_maybe env e' -- dubious?
Var v | Just rhs <- expandUnfolding_maybe (id_unf v)
-> exprIsLiteral_maybe env rhs
Var v
| Just rhs <- expandUnfolding_maybe (id_unf v)
, Just l <- exprIsLiteral_maybe env rhs
-> Just l
Var v
| Just rhs <- expandUnfolding_maybe (id_unf v)
, Just (_env,_fb,dc,_tys,[arg]) <- exprIsConApp_maybe env rhs
, Just (LitNumber _ i) <- exprIsLiteral_maybe env arg
-> if
| dc == naturalNSDataCon -> Just (mkLitNatural i)
| dc == integerISDataCon -> Just (mkLitInteger i)
| otherwise -> Nothing
_ -> Nothing
{-
......
......@@ -807,8 +807,8 @@ sizeExpr dflags bOMB_OUT_SIZE top_args expr
-- | Finds a nominal size of a string literal.
litSize :: Literal -> Int
-- Used by GHC.Core.Unfold.sizeExpr
litSize (LitNumber LitNumInteger _ _) = 100 -- Note [Size of literal integers]
litSize (LitNumber LitNumNatural _ _) = 100
litSize (LitNumber LitNumInteger _) = 100 -- Note [Size of literal integers]
litSize (LitNumber LitNumNatural _) = 100
litSize (LitString str) = 10 + 10 * ((BS.length str + 3) `div` 4)
-- If size could be 0 then @f "x"@ might be too small
-- [Sept03: make literal strings a bit bigger to avoid fruitless
......@@ -958,10 +958,10 @@ Conclusion:
Note [Literal integer size]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
Literal integers *can* be big (mkInteger [...coefficients...]), but
need not be (S# n). We just use an arbitrary big-ish constant here
need not be (IS n). We just use an arbitrary big-ish constant here
so that, in particular, we don't inline top-level defns like
n = S# 5
There's no point in doing so -- any optimisations will see the S#
n = IS 5
There's no point in doing so -- any optimisations will see the IS
through n's unfolding. Nor will a big size inhibit unfoldings functions
that mention a literal Integer, because the float-out pass will float
all those constants to top level.
......
......@@ -1091,8 +1091,8 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
| otherwise
= DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))
my_discr (LitAlt l, _, _)
= case l of LitNumber LitNumInt i _ -> DiscrI (fromInteger i)
LitNumber LitNumWord w _ -> DiscrW (fromInteger w)
= case l of LitNumber LitNumInt i -> DiscrI (fromInteger i)
LitNumber LitNumWord w -> DiscrW (fromInteger w)
LitFloat r -> DiscrF (fromRational r)
LitDouble r -> DiscrD (fromRational r)
LitChar i -> DiscrI (ord i)
......@@ -1619,14 +1619,14 @@ pushAtom _ _ (AnnLit lit) = do
wordsToBytes platform size_words)
case lit of
LitLabel _ _ _ -> code N
LitFloat _ -> code F
LitDouble _ -> code D
LitChar _ -> code N
LitNullAddr -> code N
LitString _ -> code N
LitRubbish -> code N
LitNumber nt _ _ -> case nt of
LitLabel _ _ _ -> code N
LitFloat _ -> code F
LitDouble _ -> code D
LitChar _ -> code N
LitNullAddr -> code N
LitString _ -> code N
LitRubbish -> code N
LitNumber nt _ -> case nt of
LitNumInt -> code N
LitNumWord -> code N
LitNumInt64 -> code L
......
......@@ -372,8 +372,8 @@ coreToStgExpr
-- No LitInteger's or LitNatural's should be left by the time this is called.
-- CorePrep should have converted them all to a real core representation.
coreToStgExpr (Lit (LitNumber LitNumInteger _ _)) = panic "coreToStgExpr: LitInteger"
coreToStgExpr (Lit (LitNumber LitNumNatural _ _)) = panic "coreToStgExpr: LitNatural"
coreToStgExpr (Lit (LitNumber LitNumInteger _)) = panic "coreToStgExpr: LitInteger"
coreToStgExpr (Lit (LitNumber LitNumNatural _)) = panic "coreToStgExpr: LitNatural"
coreToStgExpr (Lit l) = return (StgLit l)
coreToStgExpr (App (Lit LitRubbish) _some_unlifted_type)
-- We lower 'LitRubbish' to @()@ here, which is much easier than doing it in
......
This diff is collapsed.
......@@ -193,7 +193,7 @@ import GHC.Iface.Ext.Debug ( diffFile, validateScopes )
newHscEnv :: DynFlags -> IO HscEnv
newHscEnv dflags = do
eps_var <- newIORef initExternalPackageState
eps_var <- newIORef (initExternalPackageState dflags)
us <- mkSplitUniqSupply 'r'
nc_var <- newIORef (initNameCache us knownKeyNames)
fc_var <- newIORef emptyInstalledModuleEnv
......@@ -1888,16 +1888,14 @@ hscCompileCoreExpr hsc_env =
hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
hscCompileCoreExpr' hsc_env srcspan ds_expr
= do { let dflags = hsc_dflags hsc_env
{- Simplify it -}
; simpl_expr <- simplifyExpr hsc_env ds_expr
= do { {- Simplify it -}
simpl_expr <- simplifyExpr hsc_env ds_expr
{- Tidy it (temporary, until coreSat does cloning) -}
; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
{- Prepare for codegen -}
; prepd_expr <- corePrepExpr dflags hsc_env tidy_expr
; prepd_expr <- corePrepExpr hsc_env tidy_expr
{- Lint if necessary -}
; lintInteractiveExpr "hscCompileExpr" hsc_env prepd_expr
......
......@@ -128,8 +128,6 @@ module GHC.Driver.Session (
sOpt_i,
sExtraGccViaCFlags,
sTargetPlatformString,
sIntegerLibrary,
sIntegerLibraryType,
sGhcWithInterpreter,
sGhcWithNativeCodeGen,
sGhcWithSMP,
......@@ -139,7 +137,6 @@ module GHC.Driver.Session (
sGhcThreaded,
sGhcDebugged,
sGhcRtsWithLibdw,
IntegerLibrary(..),
GhcNameVersion(..),
FileSettings(..),
PlatformMisc(..),
......@@ -460,9 +457,6 @@ data DynFlags = DynFlags {
platformConstants :: PlatformConstants,
rawSettings :: [(String, String)],
integerLibrary :: IntegerLibrary,
-- ^ IntegerGMP or IntegerSimple. Set at configure time, but may be overridden
-- by GHC-API users. See Note [The integer library] in GHC.Builtin.Names
llvmConfig :: LlvmConfig,
-- ^ N.B. It's important that this field is lazy since we load the LLVM
-- configuration lazily. See Note [LLVM Configuration] in GHC.SysTools.
......@@ -1286,7 +1280,6 @@ defaultDynFlags mySettings llvmConfig =
ghcMode = CompManager,
ghcLink = LinkBinary,
hscTarget = defaultHscTarget (sTargetPlatform mySettings) (sPlatformMisc mySettings),
integerLibrary = sIntegerLibraryType mySettings,
verbosity = 0,
optLevel = 0,
debugLevel = 0,
......
......@@ -59,7 +59,7 @@ unboxing any boxed primitive arguments and boxing the result if
desired.
The state stuff just consists of adding in
@PrimIO (\ s -> case s of { S# s# -> ... })@ in an appropriate place.
@PrimIO (\ s -> case s of { State# s# -> ... })@ in an appropriate place.
The unboxing is straightforward, as all information needed to unbox is
available from the type. For each boxed-primitive argument, we
......
......@@ -101,13 +101,13 @@ dsLit l = do
HsDoublePrim _ d -> return (Lit (LitDouble (fl_value d)))
HsChar _ c -> return (mkCharExpr c)
HsString _ str -> mkStringExprFS str
HsInteger _ i _ -> mkIntegerExpr i
HsInteger _ i _ -> return (mkIntegerExpr i)
HsInt _ i -> return (mkIntExpr platform (il_value i))
HsRat _ (FL _ _ val) ty -> do
num <- mkIntegerExpr (numerator val)
denom <- mkIntegerExpr (denominator val)
return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])
where
num = mkIntegerExpr (numerator val)
denom = mkIntegerExpr (denominator val)
(ratio_data_con, integer_ty)
= case tcSplitTyConApp ty of
(tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
......
......@@ -288,7 +288,7 @@ literalToPmLit ty l = PmLit ty <$> go l
go (LitFloat r) = Just (PmLitRat r)
go (LitDouble r) = Just (PmLitRat r)
go (LitString s) = Just (PmLitString (mkFastStringByteString s))
go (LitNumber _ i _) = Just (PmLitInt i)
go (LitNumber _ i) = Just (PmLitInt i)
go _ = Nothing
negatePmLit :: PmLit -> Maybe PmLit
......
......@@ -1364,8 +1364,7 @@ repTy (HsIParamTy _ n t) = do
repTy ty = notHandled "Exotic form of type" (ppr ty)
repTyLit :: HsTyLit -> MetaM (Core (M TH.TyLit))
repTyLit (HsNumTy _ i) = do iExpr <- mkIntegerExpr i
rep2 numTyLitName [iExpr]
repTyLit (HsNumTy _ i) = rep2 numTyLitName [mkIntegerExpr i]
repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s
; rep2 strTyLitName [s']
}
......@@ -2755,8 +2754,7 @@ repLiteral lit
_ -> Nothing
mk_integer :: Integer -> MetaM (HsLit GhcRn)
mk_integer i = do integer_ty <- lookupType integerTyConName
return $ HsInteger NoSourceText i integer_ty
mk_integer i = return $ HsInteger NoSourceText i integerTy
mk_rational :: FractionalLit -> MetaM (HsLit GhcRn)
mk_rational r = do rat_ty <- lookupType rationalTyConName
......@@ -2913,7 +2911,7 @@ coreIntLit i = do platform <- getPlatform
return (MkC (mkIntExprInt platform i))
coreIntegerLit :: MonadThings m => Integer -> m (Core Integer)
coreIntegerLit i = fmap MkC (mkIntegerExpr i)
coreIntegerLit i = pure (MkC (mkIntegerExpr i))
coreVar :: Id -> Core TH.Name -- The Id has type Name
coreVar id = MkC (Var id)
......
......@@ -53,7 +53,7 @@ import GHC.Settings.Constants
import GHC.Builtin.Names
import GHC.Builtin.Utils
import GHC.Builtin.PrimOps ( allThePrimOps, primOpFixity, primOpOcc )
import GHC.Types.Id.Make ( seqId )
import GHC.Types.Id.Make ( seqId, EnableBignumRules(..) )
import GHC.Core.Rules
import GHC.Core.TyCon
import GHC.Types.Annotations
......@@ -1016,8 +1016,8 @@ readIface wanted_mod file_path
*********************************************************
-}
initExternalPackageState :: ExternalPackageState
initExternalPackageState
initExternalPackageState :: DynFlags -> ExternalPackageState
initExternalPackageState dflags
= EPS {
eps_is_boot = emptyUFM,
eps_PIT = emptyPackageIfaceTable,
......@@ -1025,7 +1025,7 @@ initExternalPackageState
eps_PTE = emptyTypeEnv,
eps_inst_env = emptyInstEnv,
eps_fam_inst_env = emptyFamInstEnv,
eps_rule_base = mkRuleBase builtinRules,
eps_rule_base = mkRuleBase builtinRules',
-- Initialise the EPS rule pool with the built-in rules
eps_mod_fam_inst_env
= emptyModuleEnv,
......@@ -1033,8 +1033,14 @@ initExternalPackageState
eps_ann_env = emptyAnnEnv,
eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0
, n_insts_in = 0, n_insts_out = 0
, n_rules_in = length builtinRules, n_rules_out = 0 }
, n_rules_in = length builtinRules', n_rules_out = 0 }
}
where
enableBignumRules
| homeUnitId dflags == primUnitId = EnableBignumRules False
| homeUnitId dflags == bignumUnitId = EnableBignumRules False
| otherwise = EnableBignumRules True
builtinRules' = builtinRules enableBignumRules
{-
*********************************************************
......
......@@ -57,7 +57,6 @@ import GHC.Core.Class
import GHC.Core.TyCon
import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Builtin.Names
import GHC.Builtin.Types
import GHC.Types.Literal
import GHC.Types.Var as Var
......@@ -1404,18 +1403,6 @@ tcIfaceTickish (IfaceSource src name) = return (SourceNote src name)
-------------------------
tcIfaceLit :: Literal -> IfL Literal
-- Integer literals deserialise to (LitInteger i <error thunk>)
-- so tcIfaceLit just fills in the type.
-- See Note [Integer literals] in GHC.Types.Literal
tcIfaceLit (LitNumber LitNumInteger i _)
= do t <- tcIfaceTyConByName integerTyConName
return (mkLitInteger i (mkTyConTy t))
-- Natural literals deserialise to (LitNatural i <error thunk>)
-- so tcIfaceLit just fills in the type.
-- See Note [Natural literals] in GHC.Types.Literal
tcIfaceLit (LitNumber LitNumNatural i _)
= do t <- tcIfaceTyConByName naturalTyConName
return (mkLitNatural i (mkTyConTy t))
tcIfaceLit lit = return lit
-------------------------
......@@ -1747,11 +1734,6 @@ tcIfaceGlobal name
-- the constructor (A and B) means that GHC will always typecheck
-- this expression *after* typechecking T.
tcIfaceTyConByName :: IfExtName -> IfL TyCon
tcIfaceTyConByName name
= do { thing <- tcIfaceGlobal name
; return (tyThingTyCon thing) }
tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
tcIfaceTyCon (IfaceTyCon name info)
= do { thing <- tcIfaceGlobal name
......
......@@ -55,7 +55,6 @@ import GHC.Utils.Misc
import GHC.Types.Var.Set
import GHC.Types.Basic ( Boxity(..) )
import GHC.Builtin.Types.Prim
import GHC.Builtin.Names
import GHC.Builtin.Types
import GHC.Driver.Session
import GHC.Utils.Outputable as Ppr
......@@ -66,21 +65,13 @@ import GHC.IO (throwIO)
import Control.Monad
import Data.Maybe
import Data.List ((\\))
#if defined(INTEGER_GMP)
import Data.List
import GHC.Exts
import Data.Array.Base
import GHC.Integer.GMP.Internals
#elif defined(INTEGER_SIMPLE)
import GHC.Exts
import GHC.Integer.Simple.Internals
#endif
import qualified Data.Sequence as Seq
import Data.Sequence (viewl, ViewL(..))
import Foreign
import System.IO.Unsafe
---------------------------------------------
-- * A representation of semi evaluated Terms
---------------------------------------------
......@@ -330,11 +321,12 @@ cPprTermBase y =
. subTerms)
, ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
ppr_list
, ifTerm' (isTyCon intTyCon . ty) ppr_int
, ifTerm' (isTyCon charTyCon . ty) ppr_char
, ifTerm' (isTyCon floatTyCon . ty) ppr_float
, ifTerm' (isTyCon doubleTyCon . ty) ppr_double
, ifTerm' (isIntegerTy . ty) ppr_integer
, ifTerm' (isTyCon intTyCon . ty) ppr_int
, ifTerm' (isTyCon charTyCon . ty) ppr_char
, ifTerm' (isTyCon floatTyCon . ty) ppr_float
, ifTerm' (isTyCon doubleTyCon . ty) ppr_double
, ifTerm' (isTyCon integerTyCon . ty) ppr_integer
, ifTerm' (isTyCon naturalTyCon . ty) ppr_natural
]
where
ifTerm :: (Term -> Bool)
......@@ -357,10 +349,6 @@ cPprTermBase y =
(tc,_) <- tcSplitTyConApp_maybe ty
return (a_tc == tc)
isIntegerTy ty = fromMaybe False $ do
(tc,_) <- tcSplitTyConApp_maybe ty
return (tyConName tc == integerTyConName)
ppr_int, ppr_char, ppr_float, ppr_double
:: Precedence -> Term -> m (Maybe SDoc)
ppr_int _ Term{subTerms=[Prim{valRaw=[w]}]} =
......@@ -393,63 +381,53 @@ cPprTermBase y =
return (Just (Ppr.double f))
ppr_double _ _ = return Nothing
ppr_integer :: Precedence -> Term -> m (Maybe SDoc)
#if defined(INTEGER_GMP)
-- Reconstructing Integers is a bit of a pain. This depends deeply
-- on the integer-gmp representation, so it'll break if that
-- changes (but there are several tests in
-- tests/ghci.debugger/scripts that will tell us if this is wrong).
--
-- data Integer
-- = S# Int#
-- | Jp# {-# UNPACK #-} !BigNat
-- | Jn# {-# UNPACK #-} !BigNat
--
-- data BigNat = BN# ByteArray#
--
ppr_integer _ Term{subTerms=[Prim{valRaw=[W# w]}]} =
return (Just (Ppr.integer (S# (word2Int# w))))
ppr_integer _ Term{dc=Right con,
subTerms=[Term{subTerms=[Prim{valRaw=ws}]}]} = do
-- We don't need to worry about sizes that are not an integral
-- number of words, because luckily GMP uses arrays of words
-- (see GMP_LIMB_SHIFT).
ppr_bignat :: Bool -> Precedence -> [Word] -> m (Maybe SDoc)
ppr_bignat sign _ ws = do
let
!(UArray _ _ _ arr#) = listArray (0,length ws-1) ws
constr
| "Jp#" <- getOccString (dataConName con) = Jp#
| otherwise = Jn#
return (Just (Ppr.integer (constr (BN# arr#))))
#elif defined(INTEGER_SIMPLE)
-- As with the GMP case, this depends deeply on the integer-simple
-- representation.
wordSize = finiteBitSize (0 :: Word) -- does the word size depend on the target?
makeInteger n _ [] = n
makeInteger n s (x:xs) = makeInteger (n + (fromIntegral x `shiftL` s)) (s + wordSize) xs
signf = case sign of
False -> 1
True -> -1
return $ Just $ Ppr.integer $ signf * (makeInteger 0 0 ws)
-- Reconstructing Bignums is a bit of a pain. This depends deeply on their
-- representation, so it'll break if that changes (but there are several
-- tests in tests/ghci.debugger/scripts that will tell us if this is wrong).
--
-- @
-- data Integer = Positive !Digits | Negative !Digits | Naught
-- data Integer
-- = IS !Int#
-- | IP !BigNat
-- | IN !BigNat
--
-- data Digits = Some !Word# !Digits
-- | None
-- @
-- data Natural
-- = NS !Word#
-- | NB !BigNat
--
-- NB: the above has some type synonyms expanded out for the sake of brevity
ppr_integer _ Term{subTerms=[]} =
return (Just (Ppr.integer Naught))
ppr_integer _ Term{dc=Right con, subTerms=[digitTerm]}
| Just digits <- get_digits digitTerm
= return (Just (Ppr.integer (constr digits)))
where
get_digits :: Term -> Maybe Digits
get_digits Term{subTerms=[]} = Just None
get_digits Term{subTerms=[Prim{valRaw=[W# w]},t]}
= Some w <$> get_digits t
get_digits _ = Nothing
constr
| "Positive" <- getOccString (dataConName con) = Positive
| otherwise = Negative
#endif
-- type BigNat = ByteArray#
ppr_integer :: Precedence -> Term -> m (Maybe SDoc)
ppr_integer _ Term{dc=Right con, subTerms=[Prim{valRaw=ws}]}
| con == integerISDataCon
, [W# w] <- ws
= return (Just (Ppr.integer (fromIntegral (I# (word2Int# w)))))
ppr_integer p Term{dc=Right con, subTerms=[Term{subTerms=[Prim{valRaw=ws}]}]}
| con == integerIPDataCon = ppr_bignat False p ws
| con == integerINDataCon = ppr_bignat True p ws
| otherwise = panic "Unexpected Integer constructor"
ppr_integer _ _ = return Nothing
ppr_natural :: Precedence -> Term -> m (Maybe SDoc)
ppr_natural _ Term{dc=Right con, subTerms=[Prim{valRaw