Skip to content

GitLab

GHC
GHC
Commit 10cc4224 authored by ian@well-typed.com's avatar ian@well-typed.com
Browse files
Options

Move tARGET_* out of HaskellConstants

parent 79ee264a
Hide whitespace changes
Inline Side-by-side
Showing with 399 additions and 306 deletions
compiler/basicTypes/Literal.lhs
View file @ 10cc4224
......@@ -52,6 +52,7 @@ import FastString
import BasicTypes
import Binary
import Constants
import DynFlags
import UniqFM
import Util
......@@ -216,14 +217,14 @@ instance Ord Literal where
~~~~~~~~~~~~
\begin{code}
-- | Creates a 'Literal' of type @Int#@
mkMachInt :: Integer -> Literal
mkMachInt x = ASSERT2( inIntRange x, integer x )
MachInt x
mkMachInt :: DynFlags -> Integer -> Literal
mkMachInt dflags x = ASSERT2( inIntRange dflags x, integer x )
MachInt x
-- | Creates a 'Literal' of type @Word#@
mkMachWord :: Integer -> Literal
mkMachWord x = ASSERT2( inWordRange x, integer x )
MachWord x
mkMachWord :: DynFlags -> Integer -> Literal
mkMachWord dflags x = ASSERT2( inWordRange dflags x, integer x )
MachWord x
-- | Creates a 'Literal' of type @Int64#@
mkMachInt64 :: Integer -> Literal
......@@ -254,9 +255,9 @@ mkMachString s = MachStr (fastStringToFastBytes $ mkFastString s)
mkLitInteger :: Integer -> Type -> Literal
mkLitInteger = LitInteger
inIntRange, inWordRange :: Integer -> Bool
inIntRange x = x >= tARGET_MIN_INT && x <= tARGET_MAX_INT
inWordRange x = x >= 0 && x <= tARGET_MAX_WORD
inIntRange, inWordRange :: DynFlags -> Integer -> Bool
inIntRange dflags x = x >= tARGET_MIN_INT dflags && x <= tARGET_MAX_INT dflags
inWordRange dflags x = x >= 0 && x <= tARGET_MAX_WORD dflags
inCharRange :: Char -> Bool
inCharRange c = c >= '\0' && c <= chr tARGET_MAX_CHAR
......@@ -275,23 +276,23 @@ isZeroLit _ = False
Coercions
~~~~~~~~~
\begin{code}
word2IntLit, int2WordLit,
narrow8IntLit, narrow16IntLit, narrow32IntLit,
narrow8IntLit, narrow16IntLit, narrow32IntLit,
narrow8WordLit, narrow16WordLit, narrow32WordLit,
char2IntLit, int2CharLit,
float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit,
float2DoubleLit, double2FloatLit
:: Literal -> Literal
word2IntLit (MachWord w)
| w > tARGET_MAX_INT = MachInt (w - tARGET_MAX_WORD - 1)
| otherwise = MachInt w
word2IntLit l = pprPanic "word2IntLit" (ppr l)
word2IntLit, int2WordLit :: DynFlags -> Literal -> Literal
word2IntLit dflags (MachWord w)
| w > tARGET_MAX_INT dflags = MachInt (w - tARGET_MAX_WORD dflags - 1)
| otherwise = MachInt w
word2IntLit _ l = pprPanic "word2IntLit" (ppr l)
int2WordLit (MachInt i)
| i < 0 = MachWord (1 + tARGET_MAX_WORD + i) -- (-1) ---> tARGET_MAX_WORD
int2WordLit dflags (MachInt i)
| i < 0 = MachWord (1 + tARGET_MAX_WORD dflags + i) -- (-1) ---> tARGET_MAX_WORD
| otherwise = MachWord i
int2WordLit l = pprPanic "int2WordLit" (ppr l)
int2WordLit _ l = pprPanic "int2WordLit" (ppr l)
narrow8IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int8))
narrow8IntLit l = pprPanic "narrow8IntLit" (ppr l)
......@@ -343,11 +344,11 @@ litIsTrivial _ = True
-- | True if code space does not go bad if we duplicate this literal
-- Currently we treat it just like 'litIsTrivial'
litIsDupable :: Literal -> Bool
litIsDupable :: DynFlags -> Literal -> Bool
-- c.f. CoreUtils.exprIsDupable
litIsDupable (MachStr _) = False
litIsDupable (LitInteger i _) = inIntRange i
litIsDupable _ = True
litIsDupable _ (MachStr _) = False
litIsDupable dflags (LitInteger i _) = inIntRange dflags i
litIsDupable _ _ = True
litFitsInChar :: Literal -> Bool
litFitsInChar (MachInt i)
......
compiler/coreSyn/CorePrep.lhs
View file @ 10cc4224
......@@ -471,7 +471,7 @@ 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 (getMkIntegerId env) i)
= cpeRhsE env (cvtLitInteger (cpe_dynFlags env) (getMkIntegerId env) i)
cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr)
cpeRhsE env expr@(Var {}) = cpeApp env expr
......@@ -521,16 +521,16 @@ cpeRhsE env (Case scrut bndr ty alts)
; rhs' <- cpeBodyNF env2 rhs
; return (con, bs', rhs') }
cvtLitInteger :: Id -> Integer -> CoreExpr
cvtLitInteger :: DynFlags -> Id -> 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 mk_integer i
cvtLitInteger dflags mk_integer i
| cIntegerLibraryType == IntegerGMP
, inIntRange i -- Special case for small integers in GMP
= mkConApp integerGmpSDataCon [Lit (mkMachInt i)]
, inIntRange dflags i -- Special case for small integers in GMP
= mkConApp integerGmpSDataCon [Lit (mkMachInt dflags i)]
| otherwise
= mkApps (Var mk_integer) [isNonNegative, ints]
......@@ -540,7 +540,7 @@ cvtLitInteger mk_integer i
f 0 = []
f x = let low = x .&. mask
high = x `shiftR` bits
in mkConApp intDataCon [Lit (mkMachInt low)] : f high
in mkConApp intDataCon [Lit (mkMachInt dflags low)] : f high
bits = 31
mask = 2 ^ bits - 1
......
compiler/coreSyn/CoreSyn.lhs
View file @ 10cc4224
......@@ -1118,23 +1118,23 @@ mkConApp con args = mkApps (Var (dataConWorkId con)) args
-- | Create a machine integer literal expression of type @Int#@ from an @Integer@.
-- If you want an expression of type @Int@ use 'MkCore.mkIntExpr'
mkIntLit :: Integer -> Expr b
mkIntLit :: DynFlags -> Integer -> Expr b
-- | Create a machine integer literal expression of type @Int#@ from an @Int@.
-- If you want an expression of type @Int@ use 'MkCore.mkIntExpr'
mkIntLitInt :: Int -> Expr b
mkIntLitInt :: DynFlags -> Int -> Expr b
mkIntLit n = Lit (mkMachInt n)
mkIntLitInt n = Lit (mkMachInt (toInteger n))
mkIntLit dflags n = Lit (mkMachInt dflags n)
mkIntLitInt dflags n = Lit (mkMachInt dflags (toInteger n))
-- | Create a machine word literal expression of type @Word#@ from an @Integer@.
-- If you want an expression of type @Word@ use 'MkCore.mkWordExpr'
mkWordLit :: Integer -> Expr b
mkWordLit :: DynFlags -> Integer -> Expr b
-- | Create a machine word literal expression of type @Word#@ from a @Word@.
-- If you want an expression of type @Word@ use 'MkCore.mkWordExpr'
mkWordLitWord :: Word -> Expr b
mkWordLitWord :: DynFlags -> Word -> Expr b
mkWordLit w = Lit (mkMachWord w)
mkWordLitWord w = Lit (mkMachWord (toInteger w))
mkWordLit dflags w = Lit (mkMachWord dflags w)
mkWordLitWord dflags w = Lit (mkMachWord dflags (toInteger w))
mkWord64LitWord64 :: Word64 -> Expr b
mkWord64LitWord64 w = Lit (mkMachWord64 (toInteger w))
......
compiler/coreSyn/CoreUtils.lhs
View file @ 10cc4224
......@@ -64,6 +64,7 @@ import TyCon
import Unique
import Outputable
import TysPrim
import DynFlags
import FastString
import Maybes
import Platform
......@@ -602,8 +603,8 @@ Note [exprIsDupable]
\begin{code}
exprIsDupable :: CoreExpr -> Bool
exprIsDupable e
exprIsDupable :: DynFlags -> CoreExpr -> Bool
exprIsDupable dflags e
= isJust (go dupAppSize e)
where
go :: Int -> CoreExpr -> Maybe Int
......@@ -613,7 +614,7 @@ exprIsDupable e
go n (Tick _ e) = go n e
go n (Cast e _) = go n e
go n (App f a) | Just n' <- go n a = go n' f
go n (Lit lit) | litIsDupable lit = decrement n
go n (Lit lit) | litIsDupable dflags lit = decrement n
go _ _ = Nothing
decrement :: Int -> Maybe Int
......
compiler/coreSyn/MkCore.lhs
View file @ 10cc4224
......@@ -84,6 +84,7 @@ import BasicTypes
import Util
import Pair
import Constants
import DynFlags
import Data.Char ( ord )
import Data.List
......@@ -233,20 +234,20 @@ mkCoreLams = mkLams
\begin{code}
-- | Create a 'CoreExpr' which will evaluate to the given @Int@
mkIntExpr :: Integer -> CoreExpr -- Result = I# i :: Int
mkIntExpr i = mkConApp intDataCon [mkIntLit i]
mkIntExpr :: DynFlags -> Integer -> CoreExpr -- Result = I# i :: Int
mkIntExpr dflags i = mkConApp intDataCon [mkIntLit dflags i]
-- | Create a 'CoreExpr' which will evaluate to the given @Int@
mkIntExprInt :: Int -> CoreExpr -- Result = I# i :: Int
mkIntExprInt i = mkConApp intDataCon [mkIntLitInt i]
mkIntExprInt :: DynFlags -> Int -> CoreExpr -- Result = I# i :: Int
mkIntExprInt dflags i = mkConApp intDataCon [mkIntLitInt dflags i]
-- | Create a 'CoreExpr' which will evaluate to the a @Word@ with the given value
mkWordExpr :: Integer -> CoreExpr
mkWordExpr w = mkConApp wordDataCon [mkWordLit w]
mkWordExpr :: DynFlags -> Integer -> CoreExpr
mkWordExpr dflags w = mkConApp wordDataCon [mkWordLit dflags w]
-- | Create a 'CoreExpr' which will evaluate to the given @Word@
mkWordExprWord :: Word -> CoreExpr
mkWordExprWord w = mkConApp wordDataCon [mkWordLitWord w]
mkWordExprWord :: DynFlags -> Word -> CoreExpr
mkWordExprWord dflags w = mkConApp wordDataCon [mkWordLitWord dflags w]
-- | Create a 'CoreExpr' which will evaluate to the given @Integer@
mkIntegerExpr :: MonadThings m => Integer -> m CoreExpr -- Result :: Integer
......
compiler/deSugar/DsCCall.lhs
View file @ 10cc4224
......@@ -149,11 +149,12 @@ unboxArg arg
-- Booleans
| Just tc <- tyConAppTyCon_maybe arg_ty,
tc `hasKey` boolTyConKey
= do prim_arg <- newSysLocalDs intPrimTy
= do dflags <- getDynFlags
prim_arg <- newSysLocalDs intPrimTy
return (Var prim_arg,
\ body -> Case (mkWildCase arg arg_ty intPrimTy
[(DataAlt falseDataCon,[],mkIntLit 0),
(DataAlt trueDataCon, [],mkIntLit 1)])
[(DataAlt falseDataCon,[],mkIntLit dflags 0),
(DataAlt trueDataCon, [],mkIntLit dflags 1)])
-- In increasing tag order!
prim_arg
(exprType body)
......@@ -335,11 +336,13 @@ resultWrapper result_ty
-- Base case 3: the boolean type
| Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey
= return
= do
dflags <- getDynFlags
return
(Just intPrimTy, \e -> mkWildCase e intPrimTy
boolTy
[(DEFAULT ,[],Var trueDataConId ),
(LitAlt (mkMachInt 0),[],Var falseDataConId)])
[(DEFAULT ,[],Var trueDataConId ),
(LitAlt (mkMachInt dflags 0),[],Var falseDataConId)])
-- Recursive newtypes
| Just (rep_ty, co) <- splitNewTypeRepCo_maybe result_ty
......
compiler/deSugar/DsForeign.lhs
View file @ 10cc4224
......@@ -430,7 +430,7 @@ dsFExportDynamic id co0 cconv = do
to be entered using an external calling convention
(stdcall, ccall).
-}
adj_args = [ mkIntLitInt (ccallConvToInt cconv)
adj_args = [ mkIntLitInt dflags (ccallConvToInt cconv)
, Var stbl_value
, Lit (MachLabel fe_nm mb_sz_args IsFunction)
, Lit (mkMachString typestring)
......
compiler/deSugar/DsMeta.hs
View file @ 10cc4224
......@@ -62,6 +62,7 @@ import Unique
import BasicTypes
import Outputable
import Bag
import DynFlags
import FastString
import ForeignCall
import MonadUtils
......@@ -798,7 +799,8 @@ repTy (HsTyLit lit) = do
repTy ty = notHandled "Exotic form of type" (ppr ty)
repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ)
repTyLit (HsNumTy i) = rep2 numTyLitName [mkIntExpr i]
repTyLit (HsNumTy i) = do dflags <- getDynFlags
rep2 numTyLitName [mkIntExpr dflags i]
repTyLit (HsStrTy s) = do { s' <- mkStringExprFS s
; rep2 strTyLitName [s']
}
......@@ -1730,11 +1732,13 @@ repNamedTyCon (MkC s) = rep2 conTName [s]
repTupleTyCon :: Int -> DsM (Core TH.TypeQ)
-- Note: not Core Int; it's easier to be direct here
repTupleTyCon i = rep2 tupleTName [mkIntExprInt i]
repTupleTyCon i = do dflags <- getDynFlags
rep2 tupleTName [mkIntExprInt dflags i]
repUnboxedTupleTyCon :: Int -> DsM (Core TH.TypeQ)
-- Note: not Core Int; it's easier to be direct here
repUnboxedTupleTyCon i = rep2 unboxedTupleTName [mkIntExprInt i]
repUnboxedTupleTyCon i = do dflags <- getDynFlags
rep2 unboxedTupleTName [mkIntExprInt dflags i]
repArrowTyCon :: DsM (Core TH.TypeQ)
repArrowTyCon = rep2 arrowTName []
......@@ -1746,7 +1750,8 @@ repPromotedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
repPromotedTyCon (MkC s) = rep2 promotedTName [s]
repPromotedTupleTyCon :: Int -> DsM (Core TH.TypeQ)
repPromotedTupleTyCon i = rep2 promotedTupleTName [mkIntExprInt i]
repPromotedTupleTyCon i = do dflags <- getDynFlags
rep2 promotedTupleTName [mkIntExprInt dflags i]
repPromotedNilTyCon :: DsM (Core TH.TypeQ)
repPromotedNilTyCon = rep2 promotedNilTName []
......@@ -1769,7 +1774,8 @@ repKCon :: Core TH.Name -> DsM (Core TH.Kind)
repKCon (MkC s) = rep2 conKName [s]
repKTuple :: Int -> DsM (Core TH.Kind)
repKTuple i = rep2 tupleKName [mkIntExprInt i]
repKTuple i = do dflags <- getDynFlags
rep2 tupleKName [mkIntExprInt dflags i]
repKArrow :: DsM (Core TH.Kind)
repKArrow = rep2 arrowKName []
......@@ -1878,7 +1884,8 @@ coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
------------ Literals & Variables -------------------
coreIntLit :: Int -> DsM (Core Int)
coreIntLit i = return (MkC (mkIntExprInt i))
coreIntLit i = do dflags <- getDynFlags
return (MkC (mkIntExprInt dflags i))
coreVar :: Id -> Core TH.Name -- The Id has type Name
coreVar id = MkC (Var id)
......
compiler/deSugar/DsUtils.lhs
View file @ 10cc4224
......@@ -308,11 +308,12 @@ mkCoPrimCaseMatchResult var ty match_alts
mkCoAlgCaseMatchResult
:: Id -- Scrutinee
:: DynFlags
-> Id -- Scrutinee
-> Type -- Type of exp
-> [(DataCon, [CoreBndr], MatchResult)] -- Alternatives (bndrs *include* tyvars, dicts)
-> MatchResult
mkCoAlgCaseMatchResult var ty match_alts
mkCoAlgCaseMatchResult dflags var ty match_alts
| isNewTyCon tycon -- Newtype case; use a let
= ASSERT( null (tail match_alts) && null (tail arg_ids1) )
mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1
......@@ -423,7 +424,7 @@ mkCoAlgCaseMatchResult var ty match_alts
lit = MachInt $ toInteger (dataConSourceArity con)
binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] args]
--
indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr i]
indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr dflags i]
\end{code}
%************************************************************************
......
compiler/deSugar/Match.lhs
View file @ 10cc4224
......@@ -292,12 +292,13 @@ match [] ty eqns
match vars@(v:_) ty eqns
= ASSERT( not (null eqns ) )
do { -- Tidy the first pattern, generating
do { dflags <- getDynFlags
; -- Tidy the first pattern, generating
-- auxiliary bindings if necessary
(aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns
-- Group the equations and match each group in turn
; let grouped = groupEquations tidy_eqns
; let grouped = groupEquations dflags tidy_eqns
-- print the view patterns that are commoned up to help debug
; ifDOptM Opt_D_dump_view_pattern_commoning (debug grouped)
......@@ -787,13 +788,13 @@ data PatGroup
-- the LHsExpr is the expression e
Type -- the Type is the type of p (equivalently, the result type of e)
groupEquations :: [EquationInfo] -> [[(PatGroup, EquationInfo)]]
groupEquations :: DynFlags -> [EquationInfo] -> [[(PatGroup, EquationInfo)]]
-- If the result is of form [g1, g2, g3],
-- (a) all the (pg,eq) pairs in g1 have the same pg
-- (b) none of the gi are empty
-- The ordering of equations is unchanged
groupEquations eqns
= runs same_gp [(patGroup (firstPat eqn), eqn) | eqn <- eqns]
groupEquations dflags eqns
= runs same_gp [(patGroup dflags (firstPat eqn), eqn) | eqn <- eqns]
where
same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool
(pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2
......@@ -948,16 +949,16 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
eq_co (TcTyConAppCo tc1 cos1) (TcTyConAppCo tc2 cos2) = tc1==tc2 && eq_list eq_co cos1 cos2
eq_co _ _ = False
patGroup :: Pat Id -> PatGroup
patGroup (WildPat {}) = PgAny
patGroup (BangPat {}) = PgBang
patGroup (ConPatOut { pat_con = dc }) = PgCon (unLoc dc)
patGroup (LitPat lit) = PgLit (hsLitKey lit)
patGroup (NPat olit mb_neg _) = PgN (hsOverLitKey olit (isJust mb_neg))
patGroup (NPlusKPat _ olit _ _) = PgNpK (hsOverLitKey olit False)
patGroup (CoPat _ p _) = PgCo (hsPatType p) -- Type of innelexp pattern
patGroup (ViewPat expr p _) = PgView expr (hsPatType (unLoc p))
patGroup pat = pprPanic "patGroup" (ppr pat)
patGroup :: DynFlags -> Pat Id -> PatGroup
patGroup _ (WildPat {}) = PgAny
patGroup _ (BangPat {}) = PgBang
patGroup _ (ConPatOut { pat_con = dc }) = PgCon (unLoc dc)
patGroup dflags (LitPat lit) = PgLit (hsLitKey dflags lit)
patGroup _ (NPat olit mb_neg _) = PgN (hsOverLitKey olit (isJust mb_neg))
patGroup _ (NPlusKPat _ olit _ _) = PgNpK (hsOverLitKey olit False)
patGroup _ (CoPat _ p _) = PgCo (hsPatType p) -- Type of innelexp pattern
patGroup _ (ViewPat expr p _) = PgView expr (hsPatType (unLoc p))
patGroup _ pat = pprPanic "patGroup" (ppr pat)
\end{code}
Note [Grouping overloaded literal patterns]
......
compiler/deSugar/MatchCon.lhs
View file @ 10cc4224
......@@ -31,6 +31,7 @@ import ListSetOps ( runs )
import Id
import NameEnv
import SrcLoc
import DynFlags
import Outputable
import Control.Monad(liftM)
\end{code}
......@@ -92,8 +93,9 @@ matchConFamily :: [Id]
-> DsM MatchResult
-- Each group of eqns is for a single constructor
matchConFamily (var:vars) ty groups
= do { alts <- mapM (matchOneCon vars ty) groups
; return (mkCoAlgCaseMatchResult var ty alts) }
= do dflags <- getDynFlags
alts <- mapM (matchOneCon vars ty) groups
return (mkCoAlgCaseMatchResult dflags var ty alts)
matchConFamily [] _ _ = panic "matchConFamily []"
type ConArgPats = HsConDetails (LPat Id) (HsRecFields Id (LPat Id))
......
compiler/deSugar/MatchLit.lhs
View file @ 10cc4224
......@@ -42,6 +42,7 @@ import Data.Ratio
import MonadUtils
import Outputable
import BasicTypes
import DynFlags
import Util
import FastString
\end{code}
......@@ -81,7 +82,8 @@ 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) = return (mkIntExpr i)
dsLit (HsInt i) = do dflags <- getDynFlags
return (mkIntExpr dflags i)
dsLit (HsRat r ty) = do
num <- mkIntegerExpr (numerator (fl_value r))
......@@ -95,12 +97,16 @@ dsLit (HsRat r ty) = do
x -> pprPanic "dsLit" (ppr x)
dsOverLit :: HsOverLit Id -> DsM CoreExpr
dsOverLit lit = do dflags <- getDynFlags
dsOverLit' dflags lit
dsOverLit' :: DynFlags -> HsOverLit Id -> DsM CoreExpr
-- Post-typechecker, the SyntaxExpr field of an OverLit contains
-- (an expression for) the literal value itself
dsOverLit (OverLit { ol_val = val, ol_rebindable = rebindable
, ol_witness = witness, ol_type = ty })
dsOverLit' dflags (OverLit { ol_val = val, ol_rebindable = rebindable
, ol_witness = witness, ol_type = ty })
| not rebindable
, Just expr <- shortCutLit val ty = dsExpr expr -- Note [Literal short cut]
, Just expr <- shortCutLit dflags val ty = dsExpr expr -- Note [Literal short cut]
| otherwise = dsExpr witness
\end{code}
......@@ -113,22 +119,22 @@ much better do do so.
\begin{code}
hsLitKey :: HsLit -> Literal
hsLitKey :: DynFlags -> HsLit -> Literal
-- Get a Core literal to use (only) a grouping key
-- Hence its type doesn't need to match the type of the original literal
-- (and doesn't for strings)
-- It only works for primitive types and strings;
-- others have been removed by tidy
hsLitKey (HsIntPrim i) = mkMachInt i
hsLitKey (HsWordPrim w) = mkMachWord w
hsLitKey (HsInt64Prim i) = mkMachInt64 i
hsLitKey (HsWord64Prim w) = mkMachWord64 w
hsLitKey (HsCharPrim c) = MachChar c
hsLitKey (HsStringPrim s) = MachStr s
hsLitKey (HsFloatPrim f) = MachFloat (fl_value f)
hsLitKey (HsDoublePrim d) = MachDouble (fl_value d)
hsLitKey (HsString s) = MachStr (fastStringToFastBytes s)
hsLitKey l = pprPanic "hsLitKey" (ppr l)
hsLitKey dflags (HsIntPrim i) = mkMachInt dflags i
hsLitKey dflags (HsWordPrim w) = mkMachWord dflags w
hsLitKey _ (HsInt64Prim i) = mkMachInt64 i
hsLitKey _ (HsWord64Prim w) = mkMachWord64 w
hsLitKey _ (HsCharPrim c) = MachChar c
hsLitKey _ (HsStringPrim s) = MachStr s
hsLitKey _ (HsFloatPrim f) = MachFloat (fl_value f)
hsLitKey _ (HsDoublePrim d) = MachDouble (fl_value d)
hsLitKey _ (HsString s) = MachStr (fastStringToFastBytes s)
hsLitKey _ l = pprPanic "hsLitKey" (ppr l)
hsOverLitKey :: OutputableBndr a => HsOverLit a -> Bool -> Literal
-- Ditto for HsOverLit; the boolean indicates to negate
......@@ -247,9 +253,10 @@ matchLiterals (var:vars) ty sub_groups
where
match_group :: [EquationInfo] -> DsM (Literal, MatchResult)
match_group eqns
= do { let LitPat hs_lit = firstPat (head eqns)
; match_result <- match vars ty (shiftEqns eqns)
; return (hsLitKey hs_lit, match_result) }
= do dflags <- getDynFlags
let LitPat hs_lit = firstPat (head eqns)
match_result <- match vars ty (shiftEqns eqns)
return (hsLitKey dflags hs_lit, match_result)
wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult
-- Equality check for string literals
......
compiler/main/DynFlags.hs
View file @ 10cc4224
......@@ -122,6 +122,7 @@ module DynFlags (
wORD_SIZE_IN_BITS,
tAG_MASK,
mAX_PTR_TAG,
tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD,
) where
#include "HsVersions.h"
......@@ -155,11 +156,13 @@ import Control.Monad
import Data.Bits
import Data.Char
import Data.Int
import Data.List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Word
import System.FilePath
import System.IO
......@@ -3162,3 +3165,21 @@ tAG_MASK dflags = (1 `shiftL` tAG_BITS dflags) - 1
mAX_PTR_TAG :: DynFlags -> Int
mAX_PTR_TAG = tAG_MASK
-- Might be worth caching these in targetPlatform?
tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD :: DynFlags -> Integer
tARGET_MIN_INT dflags
= case platformWordSize (targetPlatform dflags) of
4 -> toInteger (minBound :: Int32)
8 -> toInteger (minBound :: Int64)
w -> panic ("tARGET_MIN_INT: Unknown platformWordSize: " ++ show w)
tARGET_MAX_INT dflags
= case platformWordSize (targetPlatform dflags) of
4 -> toInteger (maxBound :: Int32)
8 -> toInteger (maxBound :: Int64)
w -> panic ("tARGET_MAX_INT: Unknown platformWordSize: " ++ show w)
tARGET_MAX_WORD dflags
= case platformWordSize (targetPlatform dflags) of
4 -> toInteger (maxBound :: Word32)
8 -> toInteger (maxBound :: Word64)
w -> panic ("tARGET_MAX_WORD: Unknown platformWordSize: " ++ show w)
compiler/main/TidyPgm.lhs
View file @ 10cc4224
......@@ -1238,7 +1238,7 @@ hasCafRefs dflags this_pkg p arity expr
| is_caf || mentions_cafs = MayHaveCafRefs
| otherwise = NoCafRefs
where
mentions_cafs = isFastTrue (cafRefsE p expr)
mentions_cafs = isFastTrue (cafRefsE dflags p expr)
is_dynamic_name = isDllName dflags this_pkg
is_caf = not (arity > 0 || rhsIsStatic (targetPlatform dflags) is_dynamic_name expr)
......@@ -1248,28 +1248,28 @@ hasCafRefs dflags this_pkg p arity expr
-- CorePrep later on, and we don't want to duplicate that
-- knowledge in rhsIsStatic below.
cafRefsE :: (Id, VarEnv Id) -> Expr a -> FastBool
cafRefsE p (Var id) = cafRefsV p id
cafRefsE p (Lit lit) = cafRefsL p lit
cafRefsE p (App f a) = fastOr (cafRefsE p f) (cafRefsE p) a
cafRefsE p (Lam _ e) = cafRefsE p e
cafRefsE p (Let b e) = fastOr (cafRefsEs p (rhssOfBind b)) (cafRefsE p) e
cafRefsE p (Case e _bndr _ alts) = fastOr (cafRefsE p e) (cafRefsEs p) (rhssOfAlts alts)
cafRefsE p (Tick _n e) = cafRefsE p e
cafRefsE p (Cast e _co) = cafRefsE p e
cafRefsE _ (Type _) = fastBool False
cafRefsE _ (Coercion _) = fastBool False
cafRefsEs :: (Id, VarEnv Id) -> [Expr a] -> FastBool
cafRefsEs _ [] = fastBool False
cafRefsEs p (e:es) = fastOr (cafRefsE p e) (cafRefsEs p) es
cafRefsL :: (Id, VarEnv Id) -> Literal -> FastBool
cafRefsE :: DynFlags -> (Id, 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
cafRefsE dflags p (Lam _ e) = cafRefsE dflags p e
cafRefsE dflags p (Let b e) = fastOr (cafRefsEs dflags p (rhssOfBind b)) (cafRefsE dflags p) e
cafRefsE dflags p (Case e _bndr _ alts) = fastOr (cafRefsE dflags p e) (cafRefsEs dflags p) (rhssOfAlts alts)
cafRefsE dflags p (Tick _n e) = cafRefsE dflags p e
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 _ _ [] = fastBool False
cafRefsEs dflags p (e:es) = fastOr (cafRefsE dflags p e) (cafRefsEs dflags p) es
cafRefsL :: DynFlags -> (Id, 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 p@(mk_integer, _) (LitInteger i _) = cafRefsE p (cvtLitInteger mk_integer i)
cafRefsL _ _ = fastBool False
cafRefsL dflags p@(mk_integer, _) (LitInteger i _) = cafRefsE dflags p (cvtLitInteger dflags mk_integer i)
cafRefsL _ _ _ = fastBool False
cafRefsV :: (Id, VarEnv Id) -> Id -> FastBool
cafRefsV (_, p) id
......
compiler/prelude/PrelRules.lhs
View file @ 10cc4224
......@@ -80,60 +80,61 @@ primOpRules nm DataToTagOp = mkPrimOpRule nm 2 [ dataToTagRule ]
-- Int operations
primOpRules nm IntAddOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (+))
, identity zeroi ]
, identityDynFlags zeroi ]
primOpRules nm IntSubOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (-))
, rightIdentity zeroi
, equalArgs >> return (Lit zeroi) ]
, rightIdentityDynFlags zeroi
, equalArgs >> retLit zeroi ]
primOpRules nm IntMulOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (*))
, zeroElem zeroi
, identity onei ]
, identityDynFlags onei ]
primOpRules nm IntQuotOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 quot)
, leftZero zeroi
, rightIdentity onei
, equalArgs >> return (Lit onei) ]
, rightIdentityDynFlags onei
, equalArgs >> retLit onei ]
primOpRules nm IntRemOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 rem)
, leftZero zeroi
, do l <- getLiteral 1
guard (l == onei)
return (Lit zeroi)
, equalArgs >> return (Lit zeroi)
, equalArgs >> return (Lit zeroi) ]
dflags <- getDynFlags
guard (l == onei dflags)
retLit zeroi
, equalArgs >> retLit zeroi
, equalArgs >> retLit zeroi ]
primOpRules nm IntNegOp = mkPrimOpRule nm 1 [ unaryLit negOp ]
primOpRules nm ISllOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 Bits.shiftL)
, rightIdentity zeroi ]
, rightIdentityDynFlags zeroi ]
primOpRules nm ISraOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 Bits.shiftR)
, rightIdentity zeroi ]
, rightIdentityDynFlags zeroi ]
primOpRules nm ISrlOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 shiftRightLogical)