Commit 6579a6c7 authored by Jan Stolarek's avatar Jan Stolarek

Comparison primops return Int# (Fixes #6135)

This patch modifies all comparison primops for Char#, Int#, Word#, Double#,
Float# and Addr# to return Int# instead of Bool. A value of 1# represents True
and 0# represents False. For a more detailed description of motivation for this
change, discussion of implementation details and benchmarking results please
visit the wiki page: http://hackage.haskell.org/trac/ghc/wiki/PrimBool

There's also some cleanup: whitespace fixes in files that were extensively edited
in this patch and constant folding rules for Integer div and mod operators (which
for some reason have been left out up till now).
parent 33327379
......@@ -141,9 +141,9 @@ cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _bi _ _upd _ args body)
= cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body
cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args)
= cgLetNoEscapeClosure bndr local_cc cc [] (StgConApp con args)
-- For a constructor RHS we want to generate a single chunk of
-- code which can be jumped to from many places, which will
-- return the constructor. It's easy; just behave as if it
-- For a constructor RHS we want to generate a single chunk of
-- code which can be jumped to from many places, which will
-- return the constructor. It's easy; just behave as if it
-- was an StgRhsClosure with a ConApp inside!
-------------------------
......@@ -193,9 +193,9 @@ heapcheck will take their worst case into account.
In favour of omitting !Q!, !R!:
- *May* save a heap overflow test,
if ...P... allocates anything.
if ...P... allocates anything.
- We can use relative addressing from a single Hp to
- We can use relative addressing from a single Hp to
get at all the closures so allocated.
- No need to save volatile vars etc across heap checks
......@@ -203,7 +203,7 @@ In favour of omitting !Q!, !R!:
Against omitting !Q!, !R!
- May put a heap-check into the inner loop. Suppose
- May put a heap-check into the inner loop. Suppose
the main loop is P -> R -> P -> R...
Q is the loop exit, and only it does allocation.
This only hurts us if P does no allocation. If P allocates,
......@@ -212,7 +212,7 @@ Against omitting !Q!, !R!
- May do more allocation than reqd. This sometimes bites us
badly. For example, nfib (ha!) allocates about 30\% more space if the
worst-casing is done, because many many calls to nfib are leaf calls
which don't need to allocate anything.
which don't need to allocate anything.
We can un-allocate, but that costs an instruction
......@@ -248,7 +248,7 @@ Hence: two basic plans for
...save current cost centre...
...code for e,
...code for e,
with sequel (SetLocals r)
...restore current cost centre...
......@@ -338,8 +338,12 @@ So we add a special case to generate
and later optimisations will further improve this.
We should really change all these primops to return Int# instead, that
would make this special case go away.
Now that #6135 has been resolved it should be possible to remove that
special case. The idea behind this special case and pre-6135 implementation
of Bool-returning primops was that tagToEnum# was added implicitly in the
codegen and then optimized away. Now the call to tagToEnum# is explicit
in the source code, which allows to optimize it away at the earlier stages
of compilation (i.e. at the Core level).
-}
......@@ -498,7 +502,7 @@ cgAlts gc_plan bndr (PrimAlt _) alts
-- PrimAlts always have a DEFAULT case
-- and it always comes first
tagged_cmms' = [(lit,code)
tagged_cmms' = [(lit,code)
| (LitAlt lit, code) <- tagged_cmms]
; emitCmmLitSwitch (CmmReg bndr_reg) tagged_cmms' deflt
; return AssignedDirectly }
......@@ -637,7 +641,7 @@ cgLneJump blk_id lne_regs args -- Join point; discard sequel
; emitMultiAssign lne_regs cmm_args
; emit (mkBranch blk_id)
; return AssignedDirectly }
cgTailCall :: Id -> CgIdInfo -> [StgArg] -> FCode ReturnKind
cgTailCall fun_id fun_info args = do
dflags <- getDynFlags
......@@ -645,7 +649,7 @@ cgTailCall fun_id fun_info args = do
-- A value in WHNF, so we can just return it.
ReturnIt -> emitReturn [fun] -- ToDo: does ReturnIt guarantee tagged?
EnterIt -> ASSERT( null args ) -- Discarding arguments
emitEnter fun
......@@ -653,7 +657,7 @@ cgTailCall fun_id fun_info args = do
{ tickySlowCall lf_info args
; emitComment $ mkFastString "slowCall"
; slowCall fun args }
-- A direct function call (possibly with some left-over arguments)
DirectEntry lbl arity -> do
{ tickyDirectCall arity args
......
......@@ -107,15 +107,6 @@ cgOpApp (StgPrimOp primop) args res_ty
cgPrimOp regs primop args
emitReturn (map (CmmReg . CmmLocal) regs)
| ReturnsAlg tycon <- result_info
, isEnumerationTyCon tycon
-- c.f. cgExpr (...TagToEnumOp...)
= do dflags <- getDynFlags
tag_reg <- newTemp (bWord dflags)
cgPrimOp [tag_reg] primop args
emitReturn [tagToClosure dflags tycon
(CmmReg (CmmLocal tag_reg))]
| otherwise = panic "cgPrimop"
where
result_info = getPrimOpResultInfo primop
......
......@@ -233,13 +233,13 @@ basicKnownKeyNames
-- Strings and lists
unpackCStringName,
unpackCStringFoldrName, unpackCStringUtf8Name,
-- Overloaded lists
isListClassName,
fromListName,
fromListNName,
toListName,
-- List operations
concatName, filterName, mapName,
zipName, foldrName, buildName, augmentName, appendName,
......@@ -265,11 +265,11 @@ basicKnownKeyNames
plusIntegerName, timesIntegerName, smallIntegerName,
wordToIntegerName,
integerToWordName, integerToIntName, minusIntegerName,
negateIntegerName, eqIntegerName, neqIntegerName,
negateIntegerName, eqIntegerPrimName, neqIntegerPrimName,
absIntegerName, signumIntegerName,
leIntegerName, gtIntegerName, ltIntegerName, geIntegerName,
leIntegerPrimName, gtIntegerPrimName, ltIntegerPrimName, geIntegerPrimName,
compareIntegerName, quotRemIntegerName, divModIntegerName,
quotIntegerName, remIntegerName,
quotIntegerName, remIntegerName, divIntegerName, modIntegerName,
floatFromIntegerName, doubleFromIntegerName,
encodeFloatIntegerName, encodeDoubleIntegerName,
decodeDoubleIntegerName,
......@@ -350,8 +350,7 @@ genericTyConNames = [
pRELUDE :: Module
pRELUDE = mkBaseModule_ pRELUDE_NAME
gHC_PRIM, gHC_TYPES, gHC_GENERICS,
gHC_MAGIC,
gHC_PRIM, gHC_PRIMWRAPPERS, gHC_TYPES, gHC_GENERICS, gHC_MAGIC,
gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_GHCI, gHC_CSTRING,
gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER_TYPE, gHC_LIST,
gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE, dATA_MONOID,
......@@ -364,6 +363,7 @@ gHC_PRIM, gHC_TYPES, gHC_GENERICS,
cONTROL_EXCEPTION_BASE, gHC_TYPELITS, gHC_IP :: Module
gHC_PRIM = mkPrimModule (fsLit "GHC.Prim") -- Primitive types and values
gHC_PRIMWRAPPERS = mkPrimModule (fsLit "GHC.PrimWrappers")
gHC_TYPES = mkPrimModule (fsLit "GHC.Types")
gHC_MAGIC = mkPrimModule (fsLit "GHC.Magic")
gHC_CSTRING = mkPrimModule (fsLit "GHC.CString")
......@@ -558,9 +558,8 @@ unpackCString_RDR = nameRdrName unpackCStringName
unpackCStringFoldr_RDR = nameRdrName unpackCStringFoldrName
unpackCStringUtf8_RDR = nameRdrName unpackCStringUtf8Name
newStablePtr_RDR, wordDataCon_RDR :: RdrName
newStablePtr_RDR :: RdrName
newStablePtr_RDR = nameRdrName newStablePtrName
wordDataCon_RDR = dataQual_RDR gHC_TYPES (fsLit "W#")
bindIO_RDR, returnIO_RDR :: RdrName
bindIO_RDR = nameRdrName bindIOName
......@@ -882,11 +881,11 @@ integerTyConName, mkIntegerName,
plusIntegerName, timesIntegerName, smallIntegerName,
wordToIntegerName,
integerToWordName, integerToIntName, minusIntegerName,
negateIntegerName, eqIntegerName, neqIntegerName,
negateIntegerName, eqIntegerPrimName, neqIntegerPrimName,
absIntegerName, signumIntegerName,
leIntegerName, gtIntegerName, ltIntegerName, geIntegerName,
leIntegerPrimName, gtIntegerPrimName, ltIntegerPrimName, geIntegerPrimName,
compareIntegerName, quotRemIntegerName, divModIntegerName,
quotIntegerName, remIntegerName,
quotIntegerName, remIntegerName, divIntegerName, modIntegerName,
floatFromIntegerName, doubleFromIntegerName,
encodeFloatIntegerName, encodeDoubleIntegerName,
decodeDoubleIntegerName,
......@@ -907,19 +906,21 @@ integerToWordName = varQual gHC_INTEGER_TYPE (fsLit "integerToWord") int
integerToIntName = varQual gHC_INTEGER_TYPE (fsLit "integerToInt") integerToIntIdKey
minusIntegerName = varQual gHC_INTEGER_TYPE (fsLit "minusInteger") minusIntegerIdKey
negateIntegerName = varQual gHC_INTEGER_TYPE (fsLit "negateInteger") negateIntegerIdKey
eqIntegerName = varQual gHC_INTEGER_TYPE (fsLit "eqInteger") eqIntegerIdKey
neqIntegerName = varQual gHC_INTEGER_TYPE (fsLit "neqInteger") neqIntegerIdKey
eqIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "eqInteger#") eqIntegerPrimIdKey
neqIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "neqInteger#") neqIntegerPrimIdKey
absIntegerName = varQual gHC_INTEGER_TYPE (fsLit "absInteger") absIntegerIdKey
signumIntegerName = varQual gHC_INTEGER_TYPE (fsLit "signumInteger") signumIntegerIdKey
leIntegerName = varQual gHC_INTEGER_TYPE (fsLit "leInteger") leIntegerIdKey
gtIntegerName = varQual gHC_INTEGER_TYPE (fsLit "gtInteger") gtIntegerIdKey
ltIntegerName = varQual gHC_INTEGER_TYPE (fsLit "ltInteger") ltIntegerIdKey
geIntegerName = varQual gHC_INTEGER_TYPE (fsLit "geInteger") geIntegerIdKey
leIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "leInteger#") leIntegerPrimIdKey
gtIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "gtInteger#") gtIntegerPrimIdKey
ltIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "ltInteger#") ltIntegerPrimIdKey
geIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "geInteger#") geIntegerPrimIdKey
compareIntegerName = varQual gHC_INTEGER_TYPE (fsLit "compareInteger") compareIntegerIdKey
quotRemIntegerName = varQual gHC_INTEGER_TYPE (fsLit "quotRemInteger") quotRemIntegerIdKey
divModIntegerName = varQual gHC_INTEGER_TYPE (fsLit "divModInteger") divModIntegerIdKey
quotIntegerName = varQual gHC_INTEGER_TYPE (fsLit "quotInteger") quotIntegerIdKey
remIntegerName = varQual gHC_INTEGER_TYPE (fsLit "remInteger") remIntegerIdKey
divIntegerName = varQual gHC_INTEGER_TYPE (fsLit "divInteger") divIntegerIdKey
modIntegerName = varQual gHC_INTEGER_TYPE (fsLit "modInteger") modIntegerIdKey
floatFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "floatFromInteger") floatFromIntegerIdKey
doubleFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "doubleFromInteger") doubleFromIntegerIdKey
encodeFloatIntegerName = varQual gHC_INTEGER_TYPE (fsLit "encodeFloatInteger") encodeFloatIntegerIdKey
......@@ -1593,10 +1594,10 @@ mkIntegerIdKey, smallIntegerIdKey, wordToIntegerIdKey,
word64ToIntegerIdKey, int64ToIntegerIdKey,
plusIntegerIdKey, timesIntegerIdKey, minusIntegerIdKey,
negateIntegerIdKey,
eqIntegerIdKey, neqIntegerIdKey, absIntegerIdKey, signumIntegerIdKey,
leIntegerIdKey, gtIntegerIdKey, ltIntegerIdKey, geIntegerIdKey,
eqIntegerPrimIdKey, neqIntegerPrimIdKey, absIntegerIdKey, signumIntegerIdKey,
leIntegerPrimIdKey, gtIntegerPrimIdKey, ltIntegerPrimIdKey, geIntegerPrimIdKey,
compareIntegerIdKey, quotRemIntegerIdKey, divModIntegerIdKey,
quotIntegerIdKey, remIntegerIdKey,
quotIntegerIdKey, remIntegerIdKey, divIntegerIdKey, modIntegerIdKey,
floatFromIntegerIdKey, doubleFromIntegerIdKey,
encodeFloatIntegerIdKey, encodeDoubleIntegerIdKey,
decodeDoubleIntegerIdKey,
......@@ -1613,44 +1614,46 @@ plusIntegerIdKey = mkPreludeMiscIdUnique 66
timesIntegerIdKey = mkPreludeMiscIdUnique 67
minusIntegerIdKey = mkPreludeMiscIdUnique 68
negateIntegerIdKey = mkPreludeMiscIdUnique 69
eqIntegerIdKey = mkPreludeMiscIdUnique 70
neqIntegerIdKey = mkPreludeMiscIdUnique 71
eqIntegerPrimIdKey = mkPreludeMiscIdUnique 70
neqIntegerPrimIdKey = mkPreludeMiscIdUnique 71
absIntegerIdKey = mkPreludeMiscIdUnique 72
signumIntegerIdKey = mkPreludeMiscIdUnique 73
leIntegerIdKey = mkPreludeMiscIdUnique 74
gtIntegerIdKey = mkPreludeMiscIdUnique 75
ltIntegerIdKey = mkPreludeMiscIdUnique 76
geIntegerIdKey = mkPreludeMiscIdUnique 77
leIntegerPrimIdKey = mkPreludeMiscIdUnique 74
gtIntegerPrimIdKey = mkPreludeMiscIdUnique 75
ltIntegerPrimIdKey = mkPreludeMiscIdUnique 76
geIntegerPrimIdKey = mkPreludeMiscIdUnique 77
compareIntegerIdKey = mkPreludeMiscIdUnique 78
quotRemIntegerIdKey = mkPreludeMiscIdUnique 79
divModIntegerIdKey = mkPreludeMiscIdUnique 80
quotIntegerIdKey = mkPreludeMiscIdUnique 81
remIntegerIdKey = mkPreludeMiscIdUnique 82
floatFromIntegerIdKey = mkPreludeMiscIdUnique 83
doubleFromIntegerIdKey = mkPreludeMiscIdUnique 84
encodeFloatIntegerIdKey = mkPreludeMiscIdUnique 85
encodeDoubleIntegerIdKey = mkPreludeMiscIdUnique 86
gcdIntegerIdKey = mkPreludeMiscIdUnique 87
lcmIntegerIdKey = mkPreludeMiscIdUnique 88
andIntegerIdKey = mkPreludeMiscIdUnique 89
orIntegerIdKey = mkPreludeMiscIdUnique 90
xorIntegerIdKey = mkPreludeMiscIdUnique 91
complementIntegerIdKey = mkPreludeMiscIdUnique 92
shiftLIntegerIdKey = mkPreludeMiscIdUnique 93
shiftRIntegerIdKey = mkPreludeMiscIdUnique 94
wordToIntegerIdKey = mkPreludeMiscIdUnique 95
word64ToIntegerIdKey = mkPreludeMiscIdUnique 96
int64ToIntegerIdKey = mkPreludeMiscIdUnique 97
decodeDoubleIntegerIdKey = mkPreludeMiscIdUnique 98
quotIntegerIdKey = mkPreludeMiscIdUnique 79
remIntegerIdKey = mkPreludeMiscIdUnique 80
divIntegerIdKey = mkPreludeMiscIdUnique 81
modIntegerIdKey = mkPreludeMiscIdUnique 82
divModIntegerIdKey = mkPreludeMiscIdUnique 83
quotRemIntegerIdKey = mkPreludeMiscIdUnique 84
floatFromIntegerIdKey = mkPreludeMiscIdUnique 85
doubleFromIntegerIdKey = mkPreludeMiscIdUnique 86
encodeFloatIntegerIdKey = mkPreludeMiscIdUnique 87
encodeDoubleIntegerIdKey = mkPreludeMiscIdUnique 88
gcdIntegerIdKey = mkPreludeMiscIdUnique 89
lcmIntegerIdKey = mkPreludeMiscIdUnique 90
andIntegerIdKey = mkPreludeMiscIdUnique 91
orIntegerIdKey = mkPreludeMiscIdUnique 92
xorIntegerIdKey = mkPreludeMiscIdUnique 93
complementIntegerIdKey = mkPreludeMiscIdUnique 94
shiftLIntegerIdKey = mkPreludeMiscIdUnique 95
shiftRIntegerIdKey = mkPreludeMiscIdUnique 96
wordToIntegerIdKey = mkPreludeMiscIdUnique 97
word64ToIntegerIdKey = mkPreludeMiscIdUnique 98
int64ToIntegerIdKey = mkPreludeMiscIdUnique 99
decodeDoubleIntegerIdKey = mkPreludeMiscIdUnique 100
rootMainKey, runMainKey :: Unique
rootMainKey = mkPreludeMiscIdUnique 100
runMainKey = mkPreludeMiscIdUnique 101
rootMainKey = mkPreludeMiscIdUnique 101
runMainKey = mkPreludeMiscIdUnique 102
thenIOIdKey, lazyIdKey, assertErrorIdKey :: Unique
thenIOIdKey = mkPreludeMiscIdUnique 102
lazyIdKey = mkPreludeMiscIdUnique 103
assertErrorIdKey = mkPreludeMiscIdUnique 104
thenIOIdKey = mkPreludeMiscIdUnique 103
lazyIdKey = mkPreludeMiscIdUnique 104
assertErrorIdKey = mkPreludeMiscIdUnique 105
breakpointIdKey, breakpointCondIdKey, breakpointAutoIdKey,
breakpointJumpIdKey, breakpointCondJumpIdKey,
......
......@@ -220,6 +220,7 @@ primOpRules nm DoubleNegOp = mkPrimOpRule nm 1 [ unaryLit negOp
, inversePrimOp DoubleNegOp ]
-- Relational operators
primOpRules nm IntEqOp = mkRelOpRule nm (==) [ litEq True ]
primOpRules nm IntNeOp = mkRelOpRule nm (/=) [ litEq False ]
primOpRules nm CharEqOp = mkRelOpRule nm (==) [ litEq True ]
......@@ -235,19 +236,19 @@ primOpRules nm CharGeOp = mkRelOpRule nm (>=) [ boundsCmp Ge ]
primOpRules nm CharLeOp = mkRelOpRule nm (<=) [ boundsCmp Le ]
primOpRules nm CharLtOp = mkRelOpRule nm (<) [ boundsCmp Lt ]
primOpRules nm FloatGtOp = mkRelOpRule nm (>) []
primOpRules nm FloatGeOp = mkRelOpRule nm (>=) []
primOpRules nm FloatLeOp = mkRelOpRule nm (<=) []
primOpRules nm FloatLtOp = mkRelOpRule nm (<) []
primOpRules nm FloatEqOp = mkRelOpRule nm (==) [ litEq True ]
primOpRules nm FloatNeOp = mkRelOpRule nm (/=) [ litEq False ]
primOpRules nm FloatGtOp = mkFloatingRelOpRule nm (>) []
primOpRules nm FloatGeOp = mkFloatingRelOpRule nm (>=) []
primOpRules nm FloatLeOp = mkFloatingRelOpRule nm (<=) []
primOpRules nm FloatLtOp = mkFloatingRelOpRule nm (<) []
primOpRules nm FloatEqOp = mkFloatingRelOpRule nm (==) [ litEq True ]
primOpRules nm FloatNeOp = mkFloatingRelOpRule nm (/=) [ litEq False ]
primOpRules nm DoubleGtOp = mkRelOpRule nm (>) []
primOpRules nm DoubleGeOp = mkRelOpRule nm (>=) []
primOpRules nm DoubleLeOp = mkRelOpRule nm (<=) []
primOpRules nm DoubleLtOp = mkRelOpRule nm (<) []
primOpRules nm DoubleEqOp = mkRelOpRule nm (==) [ litEq True ]
primOpRules nm DoubleNeOp = mkRelOpRule nm (/=) [ litEq False ]
primOpRules nm DoubleGtOp = mkFloatingRelOpRule nm (>) []
primOpRules nm DoubleGeOp = mkFloatingRelOpRule nm (>=) []
primOpRules nm DoubleLeOp = mkFloatingRelOpRule nm (<=) []
primOpRules nm DoubleLtOp = mkFloatingRelOpRule nm (<) []
primOpRules nm DoubleEqOp = mkFloatingRelOpRule nm (==) [ litEq True ]
primOpRules nm DoubleNeOp = mkFloatingRelOpRule nm (/=) [ litEq False ]
primOpRules nm WordGtOp = mkRelOpRule nm (>) [ boundsCmp Gt ]
primOpRules nm WordGeOp = mkRelOpRule nm (>=) [ boundsCmp Ge ]
......@@ -282,14 +283,27 @@ mkRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)
mkRelOpRule nm cmp extra
= mkPrimOpRule nm 2 $ rules ++ extra
where
rules = [ binaryLit (\_ -> cmpOp cmp)
, equalArgs >>
rules = [ binaryCmpLit cmp
, do equalArgs
-- x `cmp` x does not depend on x, so
-- compute it for the arbitrary value 'True'
-- and use that result
return (if cmp True True
then trueVal
else falseVal) ]
dflags <- getDynFlags
return (if cmp True True
then trueValInt dflags
else falseValInt dflags) ]
-- Note [Rules for floating-point comparisons]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- We need different rules for floating-point values because for floats
-- it is not true that x = x. The special case when this does not occur
-- are NaNs.
mkFloatingRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)
-> [RuleM CoreExpr] -> Maybe CoreRule
mkFloatingRelOpRule nm cmp extra -- See Note [Rules for floating-point comparisons]
= mkPrimOpRule nm 2 $ binaryCmpLit cmp : extra
-- common constants
zeroi, onei, zerow, onew :: DynFlags -> Literal
......@@ -306,12 +320,12 @@ zerod = mkMachDouble 0.0
oned = mkMachDouble 1.0
twod = mkMachDouble 2.0
cmpOp :: (forall a . Ord a => a -> a -> Bool)
cmpOp :: DynFlags -> (forall a . Ord a => a -> a -> Bool)
-> Literal -> Literal -> Maybe CoreExpr
cmpOp cmp = go
cmpOp dflags cmp = go
where
done True = Just trueVal
done False = Just falseVal
done True = Just $ trueValInt dflags
done False = Just $ falseValInt dflags
-- These compares are at different types
go (MachChar i1) (MachChar i2) = done (i1 `cmp` i2)
......@@ -408,19 +422,22 @@ litEq :: Bool -- True <=> equality, False <=> inequality
-> RuleM CoreExpr
litEq is_eq = msum
[ do [Lit lit, expr] <- getArgs
do_lit_eq lit expr
dflags <- getDynFlags
do_lit_eq dflags lit expr
, do [expr, Lit lit] <- getArgs
do_lit_eq lit expr ]
dflags <- getDynFlags
do_lit_eq dflags lit expr ]
where
do_lit_eq lit expr = do
do_lit_eq dflags lit expr = do
guard (not (litIsLifted lit))
return (mkWildCase expr (literalType lit) boolTy
return (mkWildCase expr (literalType lit) intPrimTy
[(DEFAULT, [], val_if_neq),
(LitAlt lit, [], val_if_eq)])
val_if_eq | is_eq = trueVal
| otherwise = falseVal
val_if_neq | is_eq = falseVal
| otherwise = trueVal
where
val_if_eq | is_eq = trueValInt dflags
| otherwise = falseValInt dflags
val_if_neq | is_eq = falseValInt dflags
| otherwise = trueValInt dflags
-- | Check if there is comparison with minBound or maxBound, that is
......@@ -435,14 +452,14 @@ boundsCmp op = do
data Comparison = Gt | Ge | Lt | Le
mkRuleFn :: DynFlags -> Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr
mkRuleFn dflags Gt (Lit lit) _ | isMinBound dflags lit = Just falseVal
mkRuleFn dflags Le (Lit lit) _ | isMinBound dflags lit = Just trueVal
mkRuleFn dflags Ge _ (Lit lit) | isMinBound dflags lit = Just trueVal
mkRuleFn dflags Lt _ (Lit lit) | isMinBound dflags lit = Just falseVal
mkRuleFn dflags Ge (Lit lit) _ | isMaxBound dflags lit = Just trueVal
mkRuleFn dflags Lt (Lit lit) _ | isMaxBound dflags lit = Just falseVal
mkRuleFn dflags Gt _ (Lit lit) | isMaxBound dflags lit = Just falseVal
mkRuleFn dflags Le _ (Lit lit) | isMaxBound dflags lit = Just trueVal
mkRuleFn dflags Gt (Lit lit) _ | isMinBound dflags lit = Just $ falseValInt dflags
mkRuleFn dflags Le (Lit lit) _ | isMinBound dflags lit = Just $ trueValInt dflags
mkRuleFn dflags Ge _ (Lit lit) | isMinBound dflags lit = Just $ trueValInt dflags
mkRuleFn dflags Lt _ (Lit lit) | isMinBound dflags lit = Just $ falseValInt dflags
mkRuleFn dflags Ge (Lit lit) _ | isMaxBound dflags lit = Just $ trueValInt dflags
mkRuleFn dflags Lt (Lit lit) _ | isMaxBound dflags lit = Just $ falseValInt dflags
mkRuleFn dflags Gt _ (Lit lit) | isMaxBound dflags lit = Just $ falseValInt dflags
mkRuleFn dflags Le _ (Lit lit) | isMaxBound dflags lit = Just $ trueValInt dflags
mkRuleFn _ _ _ _ = Nothing
isMinBound :: DynFlags -> Literal -> Bool
......@@ -585,6 +602,11 @@ binaryLit op = do
[Lit l1, Lit l2] <- getArgs
liftMaybe $ op dflags (convFloating dflags l1) (convFloating dflags l2)
binaryCmpLit :: (forall a . Ord a => a -> a -> Bool) -> RuleM CoreExpr
binaryCmpLit op = do
dflags <- getDynFlags
binaryLit (\_ -> cmpOp dflags op)
leftIdentity :: Literal -> RuleM CoreExpr
leftIdentity id_lit = leftIdentityDynFlags (const id_lit)
......@@ -679,9 +701,23 @@ strengthReduction two_lit add_op = do -- Note [Strength reduction]
-- x * 2.0 into x + x addition, because addition costs less than multiplication.
-- See #7116
trueVal, falseVal :: Expr CoreBndr
trueVal = Var trueDataConId
falseVal = Var falseDataConId
-- Note [What's true and false]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- trueValInt and falseValInt represent true and false values returned by
-- comparison primops for Char, Int, Word, Integer, Double, Float and Addr.
-- True is represented as an unboxed 1# literal, while false is represented
-- as 0# literal.
-- We still need Bool data constructors (True and False) to use in a rule
-- for constant folding of equal Strings
trueValInt, falseValInt :: DynFlags -> Expr CoreBndr
trueValInt dflags = Lit $ onei dflags -- see Note [What's true and false]
falseValInt dflags = Lit $ zeroi dflags
trueValBool, falseValBool :: Expr CoreBndr
trueValBool = Var trueDataConId -- see Note [What's true and false]
falseValBool = Var falseDataConId
ltVal, eqVal, gtVal :: Expr CoreBndr
ltVal = Var ltDataConId
......@@ -837,7 +873,7 @@ builtinRules
ru_fn = unpackCStringFoldrName,
ru_nargs = 4, ru_try = \_ _ _ -> match_append_lit },
BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,
ru_nargs = 2, ru_try = \_ _ _ -> match_eq_string },
ru_nargs = 2, ru_try = \dflags _ _ -> match_eq_string dflags },
BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,
ru_nargs = 2, ru_try = \_ _ _ -> match_inline },
BuiltinRule { ru_name = fsLit "MagicSingI", ru_fn = idName magicSingIId,
......@@ -859,19 +895,15 @@ builtinIntegerRules =
rule_binop "minusInteger" minusIntegerName (-),
rule_binop "timesInteger" timesIntegerName (*),
rule_unop "negateInteger" negateIntegerName negate,
rule_binop_Bool "eqInteger" eqIntegerName (==),
rule_binop_Bool "neqInteger" neqIntegerName (/=),
rule_binop_Prim "eqInteger#" eqIntegerPrimName (==),
rule_binop_Prim "neqInteger#" neqIntegerPrimName (/=),
rule_unop "absInteger" absIntegerName abs,
rule_unop "signumInteger" signumIntegerName signum,
rule_binop_Bool "leInteger" leIntegerName (<=),
rule_binop_Bool "gtInteger" gtIntegerName (>),
rule_binop_Bool "ltInteger" ltIntegerName (<),
rule_binop_Bool "geInteger" geIntegerName (>=),
rule_binop_Prim "leInteger#" leIntegerPrimName (<=),
rule_binop_Prim "gtInteger#" gtIntegerPrimName (>),
rule_binop_Prim "ltInteger#" ltIntegerPrimName (<),
rule_binop_Prim "geInteger#" geIntegerPrimName (>=),
rule_binop_Ordering "compareInteger" compareIntegerName compare,
rule_divop_both "divModInteger" divModIntegerName divMod,
rule_divop_both "quotRemInteger" quotRemIntegerName quotRem,
rule_divop_one "quotInteger" quotIntegerName quot,
rule_divop_one "remInteger" remIntegerName rem,
rule_encodeFloat "encodeFloatInteger" encodeFloatIntegerName mkFloatLitFloat,
rule_convert "floatFromInteger" floatFromIntegerName (\_ -> mkFloatLitFloat),
rule_encodeFloat "encodeDoubleInteger" encodeDoubleIntegerName mkDoubleLitDouble,
......@@ -887,6 +919,12 @@ builtinIntegerRules =
rule_unop "complementInteger" complementIntegerName complement,
rule_Int_binop "shiftLInteger" shiftLIntegerName shiftL,
rule_Int_binop "shiftRInteger" shiftRIntegerName shiftR,
rule_divop_one "quotInteger" quotIntegerName quot,
rule_divop_one "remInteger" remIntegerName rem,
rule_divop_one "divInteger" divIntegerName div,
rule_divop_one "modInteger" modIntegerName mod,
rule_divop_both "divModInteger" divModIntegerName divMod,
rule_divop_both "quotRemInteger" quotRemIntegerName quotRem,
-- These rules below don't actually have to be built in, but if we
-- put them in the Haskell source then we'd have to duplicate them
-- between all Integer implementations
......@@ -928,9 +966,9 @@ builtinIntegerRules =
rule_Int_binop str name op
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
ru_try = match_Integer_Int_binop op }
rule_binop_Bool str name op
rule_binop_Prim str name op
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
ru_try = match_Integer_binop_Bool op }
ru_try = match_Integer_binop_Prim op }
rule_binop_Ordering str name op
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
ru_try = match_Integer_binop_Ordering op }
......@@ -978,14 +1016,14 @@ match_append_lit _ = Nothing
-- The rule is this:
-- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2
match_eq_string :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
match_eq_string [Var unpk1 `App` Lit (MachStr s1),
Var unpk2 `App` Lit (MachStr s2)]
match_eq_string :: DynFlags -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
match_eq_string _ [Var unpk1 `App` Lit (MachStr s1),
Var unpk2 `App` Lit (MachStr s2)]
| unpk1 `hasKey` unpackCStringIdKey,
unpk2 `hasKey` unpackCStringIdKey
= Just (if s1 == s2 then trueVal else falseVal)
= Just (if s1 == s2 then trueValBool else falseValBool)
match_eq_string _ = Nothing
match_eq_string _ _ = Nothing
---------------------------------------------------
......@@ -1107,7 +1145,7 @@ match_Integer_divop_both divop _ id_unf _ [xl,yl]
Lit (LitInteger s t)]
match_Integer_divop_both _ _ _ _ _ = Nothing
-- This helper is used for the quotRem and divMod functions
-- This helper is used for the quot and rem functions
match_Integer_divop_one :: (Integer -> Integer -> Integer) -> RuleFun
match_Integer_divop_one divop _ id_unf _ [xl,yl]
| Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
......@@ -1123,12 +1161,12 @@ match_Integer_Int_binop binop _ id_unf _ [xl,yl]
= Just (Lit (LitInteger (x `binop` fromIntegral y) i))
match_Integer_Int_binop _ _ _ _ _ = Nothing
match_Integer_binop_Bool :: (Integer -> Integer -> Bool) -> RuleFun
match_Integer_binop_Bool binop _ id_unf _ [xl, yl]
match_Integer_binop_Prim :: (Integer -> Integer -> Bool) -> RuleFun
match_Integer_binop_Prim binop dflags id_unf _ [xl, yl]
| Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
, Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
= Just (if x `binop` y then trueVal else falseVal)
match_Integer_binop_Bool _ _ _ _ _ = Nothing
= Just (if x `binop` y then trueValInt dflags else falseValInt dflags)
match_Integer_binop_Prim _ _ _ _ _ = Nothing
match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering) -> RuleFun
match_Integer_binop_Ordering binop _ id_unf _ [xl, yl]
......
......@@ -118,9 +118,8 @@ data PrimOpInfo
Type
| Monadic OccName -- string :: T -> T
Type
| Compare OccName -- string :: T -> T -> Bool
| Compare OccName -- string :: T -> T -> Int#
Type
| GenPrimOp OccName -- string :: \/a1..an . T1 -> .. -> Tk -> T
[TyVar]
[Type]
......@@ -513,10 +512,10 @@ primOpSig op
arity = length arg_tys
(tyvars, arg_tys, res_ty)
= case (primOpInfo op) of
Monadic _occ ty -> ([], [ty], ty )
Dyadic _occ ty -> ([], [ty,ty], ty )
Compare _occ ty -> ([], [ty,ty], boolTy)
GenPrimOp _occ tyvars arg_tys res_ty -> (tyvars, arg_tys, res_ty)
Monadic _occ ty -> ([], [ty], ty )
Dyadic _occ ty -> ([], [ty,ty], ty )
Compare _occ ty -> ([], [ty,ty], intPrimTy)
GenPrimOp _occ tyvars arg_tys res_ty -> (tyvars, arg_tys, res_ty )
\end{code}
\begin{code}
......@@ -533,7 +532,7 @@ getPrimOpResultInfo op
= case (primOpInfo op) of
Dyadic _ ty -> ReturnsPrim (typePrimRep ty)
Monadic _ ty -> ReturnsPrim (typePrimRep ty)
Compare _ _ -> ReturnsAlg boolTyCon
Compare _ _ -> ReturnsPrim (tyConPrimRep intPrimTyCon)
GenPrimOp _ _ _ ty | isPrimTyCon tc -> ReturnsPrim (tyConPrimRep tc)
| otherwise -> ReturnsAlg tc
where
......@@ -560,7 +559,7 @@ Utils:
dyadic_fun_ty, monadic_fun_ty, compare_fun_ty :: Type -> Type
dyadic_fun_ty ty = mkFunTys [ty, ty] ty
monadic_fun_ty ty = mkFunTy ty ty
compare_fun_ty ty = mkFunTys [ty, ty] boolTy
compare_fun_ty ty = mkFunTys [ty, ty] intPrimTy
\end{code}
Output stuff:
......
......@@ -140,19 +140,19 @@ section "Char#"
primtype Char#
primop CharGtOp "gtChar#" Compare Char# -> Char# -> Bool
primop CharGeOp "geChar#" Compare Char# -> Char# -> Bool
primop CharGtOp "gtCharI#" Compare Char# -> Char# -> Int#
primop CharGeOp "geCharI#" Compare Char# -> Char# -> Int#
primop CharEqOp "eqChar#" Compare
Char# -> Char# -> Bool
primop CharEqOp "eqCharI#" Compare
Char# -> Char# -> Int#
with commutable = True
primop CharNeOp "neChar#" Compare
Char# -> Char# -> Bool
primop CharNeOp "neCharI#" Compare
Char# -> Char# -> Int#
with commutable = True
primop CharLtOp "ltChar#" Compare Char# -> Char# -> Bool
primop CharLeOp "leChar#" Compare Char# -> Char# -> Bool
primop CharLtOp "ltCharI#" Compare Char# -> Char# -> Int#
primop CharLeOp "leCharI#" Compare Char# -> Char# -> Int#
primop OrdOp "ord#" GenPrimOp Char# -> Int#
with code_size = 0
......@@ -239,26 +239,26 @@ primop IntSubCOp "subIntC#" GenPrimOp Int# -> Int# -> (# Int#, Int# #)
second member is 0 iff no overflow occured.}
with code_size = 2
primop IntGtOp ">#" Compare Int# -> Int# -> Bool
primop IntGtOp ">$#" Compare Int# -> Int# -> Int#