Commit fe770c21 authored by Sylvain Henry's avatar Sylvain Henry Committed by Ben Gamari

Built-in Natural literals in Core

Add support for built-in Natural literals in Core.

- Replace MachInt,MachWord, LitInteger, etc. with a single LitNumber
  constructor with a LitNumType field
- Support built-in Natural literals
- Add desugar warning for negative literals
- Move Maybe(..) from GHC.Base to GHC.Maybe for module dependency
  reasons

This patch introduces only a few rules for Natural literals (compared
to Integer's rules). Factorization of the built-in rules for numeric
literals will be done in another patch as this one is already big to
review.

Test Plan:
  validate
  test build with integer-simple

Reviewers: hvr, bgamari, goldfire, Bodigrim, simonmar

Reviewed By: bgamari

Subscribers: phadej, simonpj, RyanGlScott, carter, hsyl20, rwbarton,
thomie

GHC Trac Issues: #14170, #14465

Differential Revision: https://phabricator.haskell.org/D4212
parent 42f3b53b
This diff is collapsed.
......@@ -198,7 +198,7 @@ because they don't support cross package data references well.
buildDynCon' dflags platform binder _ _cc con [arg]
| maybeIntLikeCon con
, platformOS platform /= OSMinGW32 || not (positionIndependent dflags)
, NonVoid (StgLitArg (MachInt val)) <- arg
, NonVoid (StgLitArg (LitNumber LitNumInt val _)) <- arg
, val <= fromIntegral (mAX_INTLIKE dflags) -- Comparisons at type Integer!
, val >= fromIntegral (mIN_INTLIKE dflags) -- ...ditto...
= do { let intlike_lbl = mkCmmClosureLabel rtsUnitId (fsLit "stg_INTLIKE")
......
......@@ -94,10 +94,10 @@ cgLit other_lit = do dflags <- getDynFlags
mkSimpleLit :: DynFlags -> Literal -> CmmLit
mkSimpleLit dflags (MachChar c) = CmmInt (fromIntegral (ord c)) (wordWidth dflags)
mkSimpleLit dflags MachNullAddr = zeroCLit dflags
mkSimpleLit dflags (MachInt i) = CmmInt i (wordWidth dflags)
mkSimpleLit _ (MachInt64 i) = CmmInt i W64
mkSimpleLit dflags (MachWord i) = CmmInt i (wordWidth dflags)
mkSimpleLit _ (MachWord64 i) = CmmInt i W64
mkSimpleLit dflags (LitNumber LitNumInt i _) = CmmInt i (wordWidth dflags)
mkSimpleLit _ (LitNumber LitNumInt64 i _) = CmmInt i W64
mkSimpleLit dflags (LitNumber LitNumWord i _) = CmmInt i (wordWidth dflags)
mkSimpleLit _ (LitNumber LitNumWord64 i _) = CmmInt i W64
mkSimpleLit _ (MachFloat r) = CmmFloat r W32
mkSimpleLit _ (MachDouble r) = CmmFloat r W64
mkSimpleLit _ (MachLabel fs ms fod)
......@@ -529,8 +529,7 @@ emitCmmLitSwitch scrut branches deflt = do
-- We find the necessary type information in the literals in the branches
let signed = case head branches of
(MachInt _, _) -> True
(MachInt64 _, _) -> True
(LitNumber nt _ _, _) -> litNumIsSigned nt
_ -> False
let range | signed = (tARGET_MIN_INT dflags, tARGET_MAX_INT dflags)
......
......@@ -8,8 +8,9 @@ Core pass to saturate constructors and PrimOps
{-# LANGUAGE BangPatterns, CPP, MultiWayIf #-}
module CorePrep (
corePrepPgm, corePrepExpr, cvtLitInteger,
lookupMkIntegerName, lookupIntegerSDataConName
corePrepPgm, corePrepExpr, cvtLitInteger, cvtLitNatural,
lookupMkIntegerName, lookupIntegerSDataConName,
lookupMkNaturalName, lookupNaturalSDataConName
) where
#include "HsVersions.h"
......@@ -122,11 +123,13 @@ The goal of this pass is to prepare for code generation.
special case where we use the S# constructor for Integers that
are in the range of Int.
11. Uphold tick consistency while doing this: We move ticks out of
11. Same for LitNatural.
12. Uphold tick consistency while doing this: We move ticks out of
(non-type) applications where we can, and make sure that we
annotate according to scoping rules when floating.
12. Collect cost centres (including cost centres in unfoldings) if we're in
13. Collect cost centres (including cost centres in unfoldings) if we're in
profiling mode. We have to do this here beucase we won't have unfoldings
after this pass (see `zapUnfolding` and Note [Drop unfoldings and rules].
......@@ -608,9 +611,12 @@ 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 (Lit (LitNumber LitNumInteger i _))
= cpeRhsE env (cvtLitInteger (cpe_dynFlags env) (getMkIntegerId env)
(cpe_integerSDataCon env) i)
cpeRhsE env (Lit (LitNumber LitNumNatural i _))
= cpeRhsE env (cvtLitNatural (cpe_dynFlags env) (getMkNaturalId env)
(cpe_naturalSDataCon env) i)
cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr)
cpeRhsE env expr@(Var {}) = cpeApp env expr
cpeRhsE env expr@(App {}) = cpeApp env expr
......@@ -693,6 +699,24 @@ cvtLitInteger dflags mk_integer _ i
bits = 31
mask = 2 ^ bits - 1
cvtLitNatural :: DynFlags -> Id -> Maybe DataCon -> Integer -> CoreExpr
-- Here we convert a literal Natural to the low-level
-- representation.
-- See Note [Natural literals] in Literal
cvtLitNatural dflags _ (Just sdatacon) i
| inWordRange dflags i -- Special case for small naturals
= mkConApp sdatacon [Lit (mkMachWord dflags i)]
cvtLitNatural dflags mk_natural _ i
= mkApps (Var mk_natural) [words]
where words = mkListExpr wordTy (f i)
f 0 = []
f x = let low = x .&. mask
high = x `shiftR` bits
in mkConApp wordDataCon [Lit (mkMachWord dflags low)] : f high
bits = 32
mask = 2 ^ bits - 1
-- ---------------------------------------------------------------------------
-- CpeBody: produces a result satisfying CpeBody
-- ---------------------------------------------------------------------------
......@@ -1388,8 +1412,8 @@ canFloatFromNoCaf platform (Floats ok_to_spec fs) rhs
-- the new binding is static. However it can't mention
-- any non-static things or it would *already* be Caffy
rhs_ok = rhsIsStatic platform (\_ -> False)
(\i -> pprPanic "rhsIsStatic" (integer i))
-- Integer literals should not show up
(\_nt i -> pprPanic "rhsIsStatic" (integer i))
-- Integer or Natural literals should not show up
wantFloatNested :: RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> Bool
wantFloatNested is_rec dmd is_unlifted floats rhs
......@@ -1498,7 +1522,9 @@ data CorePrepEnv
-- see Note [lazyId magic], Note [Inlining in CorePrep]
-- and Note [CorePrep inlines trivial CoreExpr not Id] (#12076)
, cpe_mkIntegerId :: Id
, cpe_mkNaturalId :: Id
, cpe_integerSDataCon :: Maybe DataCon
, cpe_naturalSDataCon :: Maybe DataCon
}
lookupMkIntegerName :: DynFlags -> HscEnv -> IO Id
......@@ -1506,13 +1532,24 @@ lookupMkIntegerName dflags hsc_env
= guardIntegerUse dflags $ liftM tyThingId $
lookupGlobal hsc_env mkIntegerName
lookupMkNaturalName :: DynFlags -> HscEnv -> IO Id
lookupMkNaturalName dflags hsc_env
= guardNaturalUse dflags $ liftM tyThingId $
lookupGlobal hsc_env mkNaturalName
lookupIntegerSDataConName :: DynFlags -> HscEnv -> IO (Maybe DataCon)
lookupIntegerSDataConName dflags hsc_env = case cIntegerLibraryType of
IntegerGMP -> guardIntegerUse dflags $ liftM (Just . tyThingDataCon) $
lookupGlobal hsc_env integerSDataConName
IntegerSimple -> return Nothing
-- | Helper for 'lookupMkIntegerName' and 'lookupIntegerSDataConName'
lookupNaturalSDataConName :: DynFlags -> HscEnv -> IO (Maybe DataCon)
lookupNaturalSDataConName dflags hsc_env = case cIntegerLibraryType of
IntegerGMP -> guardNaturalUse dflags $ liftM (Just . tyThingDataCon) $
lookupGlobal hsc_env naturalSDataConName
IntegerSimple -> return Nothing
-- | Helper for 'lookupMkIntegerName', 'lookupIntegerSDataConName'
guardIntegerUse :: DynFlags -> IO a -> IO a
guardIntegerUse dflags act
| thisPackage dflags == primUnitId
......@@ -1521,15 +1558,33 @@ guardIntegerUse dflags act
= return $ panic "Can't use Integer in integer-*"
| otherwise = act
-- | Helper for 'lookupMkNaturalName', 'lookupNaturalSDataConName'
--
-- Just like we can't use Integer literals in `integer-*`, we can't use Natural
-- literals in `base`. If we do, we get interface loading error for GHC.Natural.
guardNaturalUse :: DynFlags -> IO a -> IO a
guardNaturalUse dflags act
| thisPackage dflags == primUnitId
= return $ panic "Can't use Natural in ghc-prim"
| thisPackage dflags == integerUnitId
= return $ panic "Can't use Natural in integer-*"
| thisPackage dflags == baseUnitId
= return $ panic "Can't use Natural in base"
| otherwise = act
mkInitialCorePrepEnv :: DynFlags -> HscEnv -> IO CorePrepEnv
mkInitialCorePrepEnv dflags hsc_env
= do mkIntegerId <- lookupMkIntegerName dflags hsc_env
mkNaturalId <- lookupMkNaturalName dflags hsc_env
integerSDataCon <- lookupIntegerSDataConName dflags hsc_env
naturalSDataCon <- lookupNaturalSDataConName dflags hsc_env
return $ CPE {
cpe_dynFlags = dflags,
cpe_env = emptyVarEnv,
cpe_mkIntegerId = mkIntegerId,
cpe_integerSDataCon = integerSDataCon
cpe_mkNaturalId = mkNaturalId,
cpe_integerSDataCon = integerSDataCon,
cpe_naturalSDataCon = naturalSDataCon
}
extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
......@@ -1554,6 +1609,9 @@ lookupCorePrepEnv cpe id
getMkIntegerId :: CorePrepEnv -> Id
getMkIntegerId = cpe_mkIntegerId
getMkNaturalId :: CorePrepEnv -> Id
getMkNaturalId = cpe_mkNaturalId
------------------------------------------------------------------------------
-- Cloning binders
-- ---------------------------------------------------------------------------
......
......@@ -701,7 +701,8 @@ sizeExpr dflags bOMB_OUT_SIZE top_args expr
-- | Finds a nominal size of a string literal.
litSize :: Literal -> Int
-- Used by CoreUnfold.sizeExpr
litSize (LitInteger {}) = 100 -- Note [Size of literal integers]
litSize (LitNumber LitNumInteger _ _) = 100 -- Note [Size of literal integers]
litSize (LitNumber LitNumNatural _ _) = 100
litSize (MachStr 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
......
......@@ -2409,12 +2409,13 @@ and 'execute' it rather than allocating it statically.
-- | This function is called only on *top-level* right-hand sides.
-- Returns @True@ if the RHS can be allocated statically in the output,
-- with no thunks involved at all.
rhsIsStatic :: Platform
-> (Name -> Bool) -- Which names are dynamic
-> (Integer -> CoreExpr) -- Desugaring for integer literals (disgusting)
-- C.f. Note [Disgusting computation of CafRefs]
-- in TidyPgm
-> CoreExpr -> Bool
rhsIsStatic
:: Platform
-> (Name -> Bool) -- Which names are dynamic
-> (LitNumType -> Integer -> Maybe CoreExpr)
-- Desugaring for some literals (disgusting)
-- C.f. Note [Disgusting computation of CafRefs] in TidyPgm
-> CoreExpr -> Bool
-- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or
-- refers to, CAFs; (ii) in CoreToStg to decide whether to put an
-- update flag on it and (iii) in DsExpr to decide how to expand
......@@ -2469,7 +2470,7 @@ rhsIsStatic :: Platform
--
-- c) don't look through unfolding of f in (f x).
rhsIsStatic platform is_dynamic_name cvt_integer rhs = is_static False rhs
rhsIsStatic platform is_dynamic_name cvt_literal rhs = is_static False rhs
where
is_static :: Bool -- True <=> in a constructor argument; must be atomic
-> CoreExpr -> Bool
......@@ -2479,7 +2480,9 @@ rhsIsStatic platform is_dynamic_name cvt_integer rhs = is_static False rhs
&& is_static in_arg e
is_static in_arg (Cast e _) = is_static in_arg e
is_static _ (Coercion {}) = True -- Behaves just like a literal
is_static in_arg (Lit (LitInteger i _)) = is_static in_arg (cvt_integer i)
is_static in_arg (Lit (LitNumber nt i _)) = case cvt_literal nt i of
Just e -> is_static in_arg e
Nothing -> True
is_static _ (Lit (MachLabel {})) = False
is_static _ (Lit _) = True
-- A MachLabel (foreign import "&foo") in an argument
......
......@@ -260,13 +260,9 @@ mkIntegerExpr i = do t <- lookupTyCon integerTyConName
return (Lit (mkLitInteger i (mkTyConTy t)))
-- | Create a 'CoreExpr' which will evaluate to the given @Natural@
--
-- TODO: should we add LitNatural to Core?
mkNaturalExpr :: MonadThings m => Integer -> m CoreExpr -- Result :: Natural
mkNaturalExpr i = do iExpr <- mkIntegerExpr i
fiExpr <- lookupId naturalFromIntegerName
return (mkCoreApps (Var fiExpr) [iExpr])
mkNaturalExpr :: MonadThings m => Integer -> m CoreExpr
mkNaturalExpr i = do t <- lookupTyCon naturalTyConName
return (Lit (mkLitNatural i (mkTyConTy t)))
-- | Create a 'CoreExpr' which will evaluate to the given @Float@
mkFloatExpr :: Float -> CoreExpr
......
......@@ -77,32 +77,32 @@ See also below where we look for @DictApps@ for \tr{plusInt}, etc.
-}
dsLit :: HsLit GhcRn -> DsM CoreExpr
dsLit (HsStringPrim _ s) = return (Lit (MachStr s))
dsLit (HsCharPrim _ c) = return (Lit (MachChar c))
dsLit (HsIntPrim _ i) = return (Lit (MachInt i))
dsLit (HsWordPrim _ w) = return (Lit (MachWord w))
dsLit (HsInt64Prim _ i) = return (Lit (MachInt64 i))
dsLit (HsWord64Prim _ w) = return (Lit (MachWord64 w))
dsLit (HsFloatPrim _ f) = return (Lit (MachFloat (fl_value f)))
dsLit (HsDoublePrim _ d) = return (Lit (MachDouble (fl_value d)))
dsLit (HsChar _ c) = return (mkCharExpr c)
dsLit (HsString _ str) = mkStringExprFS str
dsLit (HsInteger _ i _) = mkIntegerExpr i
dsLit (HsInt _ i) = do dflags <- getDynFlags
return (mkIntExpr dflags (il_value i))
dsLit (HsRat _ (FL _ _ val) ty) = do
num <- mkIntegerExpr (numerator val)
denom <- mkIntegerExpr (denominator val)
return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])
where
(ratio_data_con, integer_ty)
= case tcSplitTyConApp ty of
(tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
(head (tyConDataCons tycon), i_ty)
x -> pprPanic "dsLit" (ppr x)
dsLit (XLit x) = pprPanic "dsLit" (ppr x)
dsLit l = do
dflags <- getDynFlags
case l of
HsStringPrim _ s -> return (Lit (MachStr s))
HsCharPrim _ c -> return (Lit (MachChar c))
HsIntPrim _ i -> return (Lit (mkMachIntWrap dflags i))
HsWordPrim _ w -> return (Lit (mkMachWordWrap dflags w))
HsInt64Prim _ i -> return (Lit (mkMachInt64Wrap dflags i))
HsWord64Prim _ w -> return (Lit (mkMachWord64Wrap dflags w))
HsFloatPrim _ f -> return (Lit (MachFloat (fl_value f)))
HsDoublePrim _ d -> return (Lit (MachDouble (fl_value d)))
HsChar _ c -> return (mkCharExpr c)
HsString _ str -> mkStringExprFS str
HsInteger _ i _ -> mkIntegerExpr i
HsInt _ i -> return (mkIntExpr dflags (il_value i))
XLit x -> pprPanic "dsLit" (ppr x)
HsRat _ (FL _ _ val) ty -> do
num <- mkIntegerExpr (numerator val)
denom <- mkIntegerExpr (denominator val)
return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])
where
(ratio_data_con, integer_ty)
= case tcSplitTyConApp ty of
(tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
(head (tyConDataCons tycon), i_ty)
x -> pprPanic "dsLit" (ppr x)
dsOverLit :: HsOverLit GhcTc -> DsM CoreExpr
dsOverLit lit = do { dflags <- getDynFlags
......@@ -161,20 +161,30 @@ warnAboutOverflowedLiterals :: DynFlags -> HsOverLit GhcTc -> DsM ()
warnAboutOverflowedLiterals dflags lit
| wopt Opt_WarnOverflowedLiterals dflags
, Just (i, tc) <- getIntegralLit lit
= if tc == intTyConName then check i tc (Proxy :: Proxy Int)
else if tc == int8TyConName then check i tc (Proxy :: Proxy Int8)
else if tc == int16TyConName then check i tc (Proxy :: Proxy Int16)
else if tc == int32TyConName then check i tc (Proxy :: Proxy Int32)
else if tc == int64TyConName then check i tc (Proxy :: Proxy Int64)
else if tc == wordTyConName then check i tc (Proxy :: Proxy Word)
else if tc == word8TyConName then check i tc (Proxy :: Proxy Word8)
else if tc == word16TyConName then check i tc (Proxy :: Proxy Word16)
else if tc == word32TyConName then check i tc (Proxy :: Proxy Word32)
else if tc == word64TyConName then check i tc (Proxy :: Proxy Word64)
= if tc == intTyConName then check i tc (Proxy :: Proxy Int)
else if tc == int8TyConName then check i tc (Proxy :: Proxy Int8)
else if tc == int16TyConName then check i tc (Proxy :: Proxy Int16)
else if tc == int32TyConName then check i tc (Proxy :: Proxy Int32)
else if tc == int64TyConName then check i tc (Proxy :: Proxy Int64)
else if tc == wordTyConName then check i tc (Proxy :: Proxy Word)
else if tc == word8TyConName then check i tc (Proxy :: Proxy Word8)
else if tc == word16TyConName then check i tc (Proxy :: Proxy Word16)
else if tc == word32TyConName then check i tc (Proxy :: Proxy Word32)
else if tc == word64TyConName then check i tc (Proxy :: Proxy Word64)
else if tc == naturalTyConName then checkPositive i tc
else return ()
| otherwise = return ()
where
checkPositive :: Integer -> Name -> DsM ()
checkPositive i tc
= when (i < 0) $ do
warnDs (Reason Opt_WarnOverflowedLiterals)
(vcat [ text "Literal" <+> integer i
<+> text "is negative but" <+> ppr tc
<+> ptext (sLit "only supports positive numbers")
])
check :: forall a. (Bounded a, Integral a) => Integer -> Name -> Proxy a -> DsM ()
check i tc _proxy
= when (i < minB || i > maxB) $ do
......@@ -389,8 +399,8 @@ hsLitKey :: DynFlags -> HsLit GhcTc -> Literal
-- HsLit does not.
hsLitKey dflags (HsIntPrim _ i) = mkMachIntWrap dflags i
hsLitKey dflags (HsWordPrim _ w) = mkMachWordWrap dflags w
hsLitKey _ (HsInt64Prim _ i) = mkMachInt64Wrap i
hsLitKey _ (HsWord64Prim _ w) = mkMachWord64Wrap w
hsLitKey dflags (HsInt64Prim _ i) = mkMachInt64Wrap dflags i
hsLitKey dflags (HsWord64Prim _ w) = mkMachWord64Wrap dflags w
hsLitKey _ (HsCharPrim _ c) = mkMachChar c
hsLitKey _ (HsFloatPrim _ f) = mkMachFloat (fl_value f)
hsLitKey _ (HsDoublePrim _ d) = mkMachDouble (fl_value d)
......
......@@ -444,17 +444,19 @@ assembleI dflags i = case i of
-- On Windows, stdcall labels have a suffix indicating the no. of
-- arg words, e.g. foo@8. testcase: ffi012(ghci)
literal (MachLabel fs _ _) = litlabel fs
literal (MachWord w) = int (fromIntegral w)
literal (MachInt j) = int (fromIntegral j)
literal MachNullAddr = int 0
literal (MachFloat r) = float (fromRational r)
literal (MachDouble r) = double (fromRational r)
literal (MachChar c) = int (ord c)
literal (MachInt64 ii) = int64 (fromIntegral ii)
literal (MachWord64 ii) = int64 (fromIntegral ii)
literal (MachStr bs) = lit [BCONPtrStr bs]
-- MachStr requires a zero-terminator when emitted
literal LitInteger{} = panic "ByteCodeAsm.literal: LitInteger"
literal (LitNumber nt i _) = case nt of
LitNumInt -> int (fromIntegral i)
LitNumWord -> int (fromIntegral i)
LitNumInt64 -> int64 (fromIntegral i)
LitNumWord64 -> int64 (fromIntegral i)
LitNumInteger -> panic "ByteCodeAsm.literal: LitNumInteger"
LitNumNatural -> panic "ByteCodeAsm.literal: LitNumNatural"
litlabel fs = lit [BCONPtrLbl fs]
addr (RemotePtr a) = words [fromIntegral a]
......
......@@ -996,8 +996,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 MachInt i -> DiscrI (fromInteger i)
MachWord w -> DiscrW (fromInteger w)
= case l of LitNumber LitNumInt i _ -> DiscrI (fromInteger i)
LitNumber LitNumWord w _ -> DiscrW (fromInteger w)
MachFloat r -> DiscrF (fromRational r)
MachDouble r -> DiscrD (fromRational r)
MachChar i -> DiscrI (ord i)
......@@ -1233,7 +1233,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
push_r =
if returns_void
then nilOL
else unitOL (PUSH_UBX (mkDummyLiteral r_rep) (trunc16W r_sizeW))
else unitOL (PUSH_UBX (mkDummyLiteral dflags r_rep) (trunc16W r_sizeW))
-- generate the marshalling code we're going to call
......@@ -1297,16 +1297,16 @@ primRepToFFIType dflags r
-- Make a dummy literal, to be used as a placeholder for FFI return
-- values on the stack.
mkDummyLiteral :: PrimRep -> Literal
mkDummyLiteral pr
mkDummyLiteral :: DynFlags -> PrimRep -> Literal
mkDummyLiteral dflags pr
= case pr of
IntRep -> MachInt 0
WordRep -> MachWord 0
IntRep -> mkMachInt dflags 0
WordRep -> mkMachWord dflags 0
Int64Rep -> mkMachInt64 0
Word64Rep -> mkMachWord64 0
AddrRep -> MachNullAddr
DoubleRep -> MachDouble 0
FloatRep -> MachFloat 0
Int64Rep -> MachInt64 0
Word64Rep -> MachWord64 0
_ -> pprPanic "mkDummyLiteral" (ppr pr)
......@@ -1505,11 +1505,11 @@ pushAtom d p (AnnVar var)
| otherwise -- var must be a global variable
= do topStrings <- getTopStrings
dflags <- getDynFlags
case lookupVarEnv topStrings var of
Just ptr -> pushAtom d p $ AnnLit $ MachWord $ fromIntegral $
ptrToWordPtr $ fromRemotePtr ptr
Just ptr -> pushAtom d p $ AnnLit $ mkMachWord dflags $
fromIntegral $ ptrToWordPtr $ fromRemotePtr ptr
Nothing -> do
dflags <- getDynFlags
let sz = idSizeCon dflags var
MASSERT( sz == wordSize dflags )
return (unitOL (PUSH_G (getName var)), sz)
......@@ -1524,19 +1524,21 @@ pushAtom _ _ (AnnLit lit) = do
case lit of
MachLabel _ _ _ -> code N
MachWord _ -> code N
MachInt _ -> code N
MachWord64 _ -> code L
MachInt64 _ -> code L
MachFloat _ -> code F
MachDouble _ -> code D
MachChar _ -> code N
MachNullAddr -> code N
MachStr _ -> code N
-- No LitInteger's should be left by the time this is called.
-- CorePrep should have converted them all to a real core
-- representation.
LitInteger {} -> panic "pushAtom: LitInteger"
LitNumber nt _ _ -> case nt of
LitNumInt -> code N
LitNumWord -> code N
LitNumInt64 -> code L
LitNumWord64 -> code L
-- 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.
LitNumInteger -> panic "pushAtom: LitInteger"
LitNumNatural -> panic "pushAtom: LitNatural"
pushAtom _ _ expr
= pprPanic "ByteCodeGen.pushAtom"
......
......@@ -1367,9 +1367,15 @@ tcIfaceLit :: Literal -> IfL Literal
-- Integer literals deserialise to (LitInteger i <error thunk>)
-- so tcIfaceLit just fills in the type.
-- See Note [Integer literals] in Literal
tcIfaceLit (LitInteger i _)
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 Literal
tcIfaceLit (LitNumber LitNumNatural i _)
= do t <- tcIfaceTyConByName naturalTyConName
return (mkLitNatural i (mkTyConTy t))
tcIfaceLit lit = return lit
-------------------------
......
......@@ -1093,9 +1093,14 @@ tidyTopBinds :: HscEnv
tidyTopBinds hsc_env this_mod unfold_env init_occ_env binds
= do mkIntegerId <- lookupMkIntegerName dflags hsc_env
mkNaturalId <- lookupMkNaturalName dflags hsc_env
integerSDataCon <- lookupIntegerSDataConName dflags hsc_env
let cvt_integer = cvtLitInteger dflags mkIntegerId integerSDataCon
result = tidy cvt_integer init_env binds
naturalSDataCon <- lookupNaturalSDataConName dflags hsc_env
let cvt_literal nt i = case nt of
LitNumInteger -> Just (cvtLitInteger dflags mkIntegerId integerSDataCon i)
LitNumNatural -> Just (cvtLitNatural dflags mkNaturalId naturalSDataCon i)
_ -> Nothing
result = tidy cvt_literal init_env binds
seqBinds (snd result) `seq` return result
-- This seqBinds avoids a spike in space usage (see #13564)
where
......@@ -1104,34 +1109,35 @@ tidyTopBinds hsc_env this_mod unfold_env init_occ_env binds
init_env = (init_occ_env, emptyVarEnv)
tidy _ env [] = (env, [])
tidy cvt_integer env (b:bs)
= let (env1, b') = tidyTopBind dflags this_mod
cvt_integer unfold_env env b
(env2, bs') = tidy cvt_integer env1 bs
tidy cvt_literal env (b:bs)
= let (env1, b') = tidyTopBind dflags this_mod cvt_literal unfold_env
env b
(env2, bs') = tidy cvt_literal env1 bs
in (env2, b':bs')
------------------------
tidyTopBind :: DynFlags
-> Module
-> (Integer -> CoreExpr)
-> (LitNumType -> Integer -> Maybe CoreExpr)
-> UnfoldEnv
-> TidyEnv
-> CoreBind
-> (TidyEnv, CoreBind)
tidyTopBind dflags this_mod cvt_integer unfold_env
tidyTopBind dflags this_mod cvt_literal 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_mod (subst1, cvt_integer)
caf_info = hasCafRefs dflags this_mod
(subst1, cvt_literal)
(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_mod cvt_integer unfold_env
tidyTopBind dflags this_mod cvt_literal unfold_env
(occ_env, subst1) (Rec prs)
= (tidy_env2, Rec prs')
where
......@@ -1150,7 +1156,7 @@ tidyTopBind dflags this_mod cvt_integer unfold_env
-- the group may refer indirectly to a CAF (because then, they all do).
caf_info
| or [ mayHaveCafRefs (hasCafRefs dflags this_mod
(subst1, cvt_integer)
(subst1, cvt_literal)
(idArity bndr) rhs)
| (bndr,rhs) <- prs ] = MayHaveCafRefs
| otherwise = NoCafRefs
......@@ -1296,25 +1302,28 @@ We compute hasCafRefs here, because IdInfo is supposed to be finalised
after TidyPgm. But CorePrep does some transformations that affect CAF-hood.
So we have to *predict* the result here, which is revolting.