Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Alex D
GHC
Commits
10cc4224
Commit
10cc4224
authored
Sep 17, 2012
by
ian@well-typed.com
Browse files
Move tARGET_* out of HaskellConstants
parent
79ee264a
Changes
24
Hide whitespace changes
Inline
Side-by-side
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 ]
, identity
DynFlags
zeroi ]
primOpRules nm IntSubOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (-))
, rightIdentity zeroi
, equalArgs >> ret
urn (
Lit zeroi
)
]
, rightIdentity
DynFlags
zeroi
, equalArgs >> retLit zeroi ]