PrelRules.hs 70.8 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3
{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

4 5
\section[ConFold]{Constant Folder}

6 7 8 9
Conceptually, constant folding should be parameterized with the kind
of target machine to get identical behaviour during compilation time
and runtime. We cheat a little bit here...

10 11
ToDo:
   check boundaries before folding, e.g. we can fold the Float addition
12
   (i1 + i2) only if it results in a valid Float.
Austin Seipp's avatar
Austin Seipp committed
13
-}
14

15
{-# LANGUAGE CPP, RankNTypes #-}
16
{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
17

Sylvain Henry's avatar
Sylvain Henry committed
18 19 20 21 22 23
module PrelRules
   ( primOpRules
   , builtinRules
   , caseRules
   )
where
24 25

#include "HsVersions.h"
pcapriotti's avatar
pcapriotti committed
26
#include "../includes/MachDeps.h"
27

28 29
import GhcPrelude

30
import {-# SOURCE #-} MkId ( mkPrimOpId, magicDictId )
31

32
import CoreSyn
33
import MkCore
34 35
import Id
import Literal
36
import CoreOpt     ( exprIsLiteral_maybe )
37
import PrimOp      ( PrimOp(..), tagToEnumKey )
38
import TysWiredIn
39
import TysPrim
40 41
import TyCon       ( tyConDataCons_maybe, isAlgTyCon, isEnumerationTyCon
                   , isNewTyCon, unwrapNewTyCon_maybe, tyConDataCons )
42
import DataCon     ( DataCon, dataConTagZ, dataConTyCon, dataConWorkId )
43
import CoreUtils   ( cheapEqExpr, exprIsHNF, exprType )
44
import CoreUnfold  ( exprIsConApp_maybe )
45
import Type
46
import OccName     ( occNameFS )
47
import PrelNames
48 49
import Maybes      ( orElse )
import Name        ( Name, nameOccName )
50
import Outputable
51
import FastString
52
import BasicTypes
53
import DynFlags
54
import Platform
55
import Util
56
import Coercion     (mkUnbranchedAxInstCo,mkSymCo,Role(..))
57

58
import Control.Applicative ( Alternative(..) )
59

60
import Control.Monad
quchen's avatar
quchen committed
61
import qualified Control.Monad.Fail as MonadFail
62
import Data.Bits as Bits
63
import qualified Data.ByteString as BS
64
import Data.Int
65
import Data.Ratio
66
import Data.Word
67

Austin Seipp's avatar
Austin Seipp committed
68
{-
69 70
Note [Constant folding]
~~~~~~~~~~~~~~~~~~~~~~~
71
primOpRules generates a rewrite rule for each primop
72 73
These rules do what is often called "constant folding"
E.g. the rules for +# might say
74 75
        4 +# 5 = 9
Well, of course you'd need a lot of rules if you did it
76 77 78
like that, so we use a BuiltinRule instead, so that we
can match in any two literal values.  So the rule is really
more like
dterei's avatar
dterei committed
79
        (Lit x) +# (Lit y) = Lit (x+#y)
80 81
where the (+#) on the rhs is done at compile time

82
That is why these rules are built in here.
Austin Seipp's avatar
Austin Seipp committed
83
-}
84

85
primOpRules :: Name -> PrimOp -> Maybe CoreRule
86 87
    -- ToDo: something for integer-shift ops?
    --       NotOp
88 89 90 91 92
primOpRules nm TagToEnumOp = mkPrimOpRule nm 2 [ tagToEnumRule ]
primOpRules nm DataToTagOp = mkPrimOpRule nm 2 [ dataToTagRule ]

-- Int operations
primOpRules nm IntAddOp    = mkPrimOpRule nm 2 [ binaryLit (intOp2 (+))
93
                                               , identityDynFlags zeroi ]
94
primOpRules nm IntSubOp    = mkPrimOpRule nm 2 [ binaryLit (intOp2 (-))
95
                                               , rightIdentityDynFlags zeroi
96
                                               , equalArgs >> retLit zeroi ]
97 98 99 100 101
primOpRules nm IntAddCOp   = mkPrimOpRule nm 2 [ binaryLit (intOpC2 (+))
                                               , identityCDynFlags zeroi ]
primOpRules nm IntSubCOp   = mkPrimOpRule nm 2 [ binaryLit (intOpC2 (-))
                                               , rightIdentityCDynFlags zeroi
                                               , equalArgs >> retLitNoC zeroi ]
102 103
primOpRules nm IntMulOp    = mkPrimOpRule nm 2 [ binaryLit (intOp2 (*))
                                               , zeroElem zeroi
104
                                               , identityDynFlags onei ]
105 106
primOpRules nm IntQuotOp   = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 quot)
                                               , leftZero zeroi
107 108
                                               , rightIdentityDynFlags onei
                                               , equalArgs >> retLit onei ]
109 110 111
primOpRules nm IntRemOp    = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 rem)
                                               , leftZero zeroi
                                               , do l <- getLiteral 1
112 113 114 115 116
                                                    dflags <- getDynFlags
                                                    guard (l == onei dflags)
                                                    retLit zeroi
                                               , equalArgs >> retLit zeroi
                                               , equalArgs >> retLit zeroi ]
117 118 119 120 121 122 123 124 125
primOpRules nm AndIOp      = mkPrimOpRule nm 2 [ binaryLit (intOp2 (.&.))
                                               , idempotent
                                               , zeroElem zeroi ]
primOpRules nm OrIOp       = mkPrimOpRule nm 2 [ binaryLit (intOp2 (.|.))
                                               , idempotent
                                               , identityDynFlags zeroi ]
primOpRules nm XorIOp      = mkPrimOpRule nm 2 [ binaryLit (intOp2 xor)
                                               , identityDynFlags zeroi
                                               , equalArgs >> retLit zeroi ]
126 127
primOpRules nm NotIOp      = mkPrimOpRule nm 1 [ unaryLit complementOp
                                               , inversePrimOp NotIOp ]
128 129
primOpRules nm IntNegOp    = mkPrimOpRule nm 1 [ unaryLit negOp
                                               , inversePrimOp IntNegOp ]
130
primOpRules nm ISllOp      = mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftL)
131
                                               , rightIdentityDynFlags zeroi ]
132
primOpRules nm ISraOp      = mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftR)
133
                                               , rightIdentityDynFlags zeroi ]
134
primOpRules nm ISrlOp      = mkPrimOpRule nm 2 [ shiftRule shiftRightLogical
135
                                               , rightIdentityDynFlags zeroi ]
136 137 138

-- Word operations
primOpRules nm WordAddOp   = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (+))
139
                                               , identityDynFlags zerow ]
140
primOpRules nm WordSubOp   = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (-))
141
                                               , rightIdentityDynFlags zerow
142
                                               , equalArgs >> retLit zerow ]
143 144 145 146 147
primOpRules nm WordAddCOp  = mkPrimOpRule nm 2 [ binaryLit (wordOpC2 (+))
                                               , identityCDynFlags zerow ]
primOpRules nm WordSubCOp  = mkPrimOpRule nm 2 [ binaryLit (wordOpC2 (-))
                                               , rightIdentityCDynFlags zerow
                                               , equalArgs >> retLitNoC zerow ]
148
primOpRules nm WordMulOp   = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (*))
149
                                               , identityDynFlags onew ]
150
primOpRules nm WordQuotOp  = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 quot)
151
                                               , rightIdentityDynFlags onew ]
152
primOpRules nm WordRemOp   = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 rem)
153 154 155 156 157 158
                                               , leftZero zerow
                                               , do l <- getLiteral 1
                                                    dflags <- getDynFlags
                                                    guard (l == onew dflags)
                                                    retLit zerow
                                               , equalArgs >> retLit zerow ]
159
primOpRules nm AndOp       = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.&.))
160
                                               , idempotent
161 162
                                               , zeroElem zerow ]
primOpRules nm OrOp        = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.|.))
163
                                               , idempotent
164
                                               , identityDynFlags zerow ]
165
primOpRules nm XorOp       = mkPrimOpRule nm 2 [ binaryLit (wordOp2 xor)
166 167
                                               , identityDynFlags zerow
                                               , equalArgs >> retLit zerow ]
168 169
primOpRules nm NotOp       = mkPrimOpRule nm 1 [ unaryLit complementOp
                                               , inversePrimOp NotOp ]
170 171
primOpRules nm SllOp       = mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftL) ]
primOpRules nm SrlOp       = mkPrimOpRule nm 2 [ shiftRule shiftRightLogical ]
172 173

-- coercions
174
primOpRules nm Word2IntOp     = mkPrimOpRule nm 1 [ liftLitDynFlags word2IntLit
pcapriotti's avatar
pcapriotti committed
175
                                                  , inversePrimOp Int2WordOp ]
176
primOpRules nm Int2WordOp     = mkPrimOpRule nm 1 [ liftLitDynFlags int2WordLit
pcapriotti's avatar
pcapriotti committed
177
                                                  , inversePrimOp Word2IntOp ]
178 179
primOpRules nm Narrow8IntOp   = mkPrimOpRule nm 1 [ liftLit narrow8IntLit
                                                  , subsumedByPrimOp Narrow8IntOp
180 181
                                                  , Narrow8IntOp `subsumesPrimOp` Narrow16IntOp
                                                  , Narrow8IntOp `subsumesPrimOp` Narrow32IntOp ]
182
primOpRules nm Narrow16IntOp  = mkPrimOpRule nm 1 [ liftLit narrow16IntLit
183
                                                  , subsumedByPrimOp Narrow8IntOp
184
                                                  , subsumedByPrimOp Narrow16IntOp
185
                                                  , Narrow16IntOp `subsumesPrimOp` Narrow32IntOp ]
pcapriotti's avatar
pcapriotti committed
186
primOpRules nm Narrow32IntOp  = mkPrimOpRule nm 1 [ liftLit narrow32IntLit
187 188
                                                  , subsumedByPrimOp Narrow8IntOp
                                                  , subsumedByPrimOp Narrow16IntOp
189
                                                  , subsumedByPrimOp Narrow32IntOp
pcapriotti's avatar
pcapriotti committed
190
                                                  , removeOp32 ]
191 192
primOpRules nm Narrow8WordOp  = mkPrimOpRule nm 1 [ liftLit narrow8WordLit
                                                  , subsumedByPrimOp Narrow8WordOp
193 194
                                                  , Narrow8WordOp `subsumesPrimOp` Narrow16WordOp
                                                  , Narrow8WordOp `subsumesPrimOp` Narrow32WordOp ]
195
primOpRules nm Narrow16WordOp = mkPrimOpRule nm 1 [ liftLit narrow16WordLit
196
                                                  , subsumedByPrimOp Narrow8WordOp
197
                                                  , subsumedByPrimOp Narrow16WordOp
198
                                                  , Narrow16WordOp `subsumesPrimOp` Narrow32WordOp ]
pcapriotti's avatar
pcapriotti committed
199
primOpRules nm Narrow32WordOp = mkPrimOpRule nm 1 [ liftLit narrow32WordLit
200 201
                                                  , subsumedByPrimOp Narrow8WordOp
                                                  , subsumedByPrimOp Narrow16WordOp
202
                                                  , subsumedByPrimOp Narrow32WordOp
pcapriotti's avatar
pcapriotti committed
203
                                                  , removeOp32 ]
204 205 206 207 208 209
primOpRules nm OrdOp          = mkPrimOpRule nm 1 [ liftLit char2IntLit
                                                  , inversePrimOp ChrOp ]
primOpRules nm ChrOp          = mkPrimOpRule nm 1 [ do [Lit lit] <- getArgs
                                                       guard (litFitsInChar lit)
                                                       liftLit int2CharLit
                                                  , inversePrimOp OrdOp ]
210 211 212 213 214 215 216 217 218 219 220 221 222 223
primOpRules nm Float2IntOp    = mkPrimOpRule nm 1 [ liftLit float2IntLit ]
primOpRules nm Int2FloatOp    = mkPrimOpRule nm 1 [ liftLit int2FloatLit ]
primOpRules nm Double2IntOp   = mkPrimOpRule nm 1 [ liftLit double2IntLit ]
primOpRules nm Int2DoubleOp   = mkPrimOpRule nm 1 [ liftLit int2DoubleLit ]
-- SUP: Not sure what the standard says about precision in the following 2 cases
primOpRules nm Float2DoubleOp = mkPrimOpRule nm 1 [ liftLit float2DoubleLit ]
primOpRules nm Double2FloatOp = mkPrimOpRule nm 1 [ liftLit double2FloatLit ]

-- Float
primOpRules nm FloatAddOp   = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (+))
                                                , identity zerof ]
primOpRules nm FloatSubOp   = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (-))
                                                , rightIdentity zerof ]
primOpRules nm FloatMulOp   = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (*))
224 225
                                                , identity onef
                                                , strengthReduction twof FloatAddOp  ]
226 227 228
                         -- zeroElem zerof doesn't hold because of NaN
primOpRules nm FloatDivOp   = mkPrimOpRule nm 2 [ guardFloatDiv >> binaryLit (floatOp2 (/))
                                                , rightIdentity onef ]
229 230
primOpRules nm FloatNegOp   = mkPrimOpRule nm 1 [ unaryLit negOp
                                                , inversePrimOp FloatNegOp ]
231 232 233 234 235 236 237

-- Double
primOpRules nm DoubleAddOp   = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (+))
                                                 , identity zerod ]
primOpRules nm DoubleSubOp   = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (-))
                                                 , rightIdentity zerod ]
primOpRules nm DoubleMulOp   = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (*))
238 239
                                                 , identity oned
                                                 , strengthReduction twod DoubleAddOp  ]
240 241 242
                          -- zeroElem zerod doesn't hold because of NaN
primOpRules nm DoubleDivOp   = mkPrimOpRule nm 2 [ guardDoubleDiv >> binaryLit (doubleOp2 (/))
                                                 , rightIdentity oned ]
243 244
primOpRules nm DoubleNegOp   = mkPrimOpRule nm 1 [ unaryLit negOp
                                                 , inversePrimOp DoubleNegOp ]
245 246

-- Relational operators
247

248 249 250 251 252 253 254 255 256 257 258 259 260 261 262
primOpRules nm IntEqOp    = mkRelOpRule nm (==) [ litEq True ]
primOpRules nm IntNeOp    = mkRelOpRule nm (/=) [ litEq False ]
primOpRules nm CharEqOp   = mkRelOpRule nm (==) [ litEq True ]
primOpRules nm CharNeOp   = mkRelOpRule nm (/=) [ litEq False ]

primOpRules nm IntGtOp    = mkRelOpRule nm (>)  [ boundsCmp Gt ]
primOpRules nm IntGeOp    = mkRelOpRule nm (>=) [ boundsCmp Ge ]
primOpRules nm IntLeOp    = mkRelOpRule nm (<=) [ boundsCmp Le ]
primOpRules nm IntLtOp    = mkRelOpRule nm (<)  [ boundsCmp Lt ]

primOpRules nm CharGtOp   = mkRelOpRule nm (>)  [ boundsCmp Gt ]
primOpRules nm CharGeOp   = mkRelOpRule nm (>=) [ boundsCmp Ge ]
primOpRules nm CharLeOp   = mkRelOpRule nm (<=) [ boundsCmp Le ]
primOpRules nm CharLtOp   = mkRelOpRule nm (<)  [ boundsCmp Lt ]

Ben Gamari's avatar
Ben Gamari committed
263 264 265 266 267 268 269 270 271 272 273 274 275
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 (==)
primOpRules nm FloatNeOp  = mkFloatingRelOpRule nm (/=)

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 (==)
primOpRules nm DoubleNeOp = mkFloatingRelOpRule nm (/=)
276 277 278 279 280 281

primOpRules nm WordGtOp   = mkRelOpRule nm (>)  [ boundsCmp Gt ]
primOpRules nm WordGeOp   = mkRelOpRule nm (>=) [ boundsCmp Ge ]
primOpRules nm WordLeOp   = mkRelOpRule nm (<=) [ boundsCmp Le ]
primOpRules nm WordLtOp   = mkRelOpRule nm (<)  [ boundsCmp Lt ]
primOpRules nm WordEqOp   = mkRelOpRule nm (==) [ litEq True ]
pcapriotti's avatar
pcapriotti committed
282
primOpRules nm WordNeOp   = mkRelOpRule nm (/=) [ litEq False ]
283

284 285
primOpRules nm AddrAddOp  = mkPrimOpRule nm 2 [ rightIdentityDynFlags zeroi ]

286 287 288
primOpRules nm SeqOp      = mkPrimOpRule nm 4 [ seqRule ]
primOpRules nm SparkOp    = mkPrimOpRule nm 4 [ sparkRule ]

289
primOpRules _  _          = Nothing
290

Austin Seipp's avatar
Austin Seipp committed
291 292 293
{-
************************************************************************
*                                                                      *
294
\subsection{Doing the business}
Austin Seipp's avatar
Austin Seipp committed
295 296 297
*                                                                      *
************************************************************************
-}
298

299
-- useful shorthands
300 301 302 303 304 305
mkPrimOpRule :: Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule nm arity rules = Just $ mkBasicRule nm arity (msum rules)

mkRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)
            -> [RuleM CoreExpr] -> Maybe CoreRule
mkRelOpRule nm cmp extra
Ben Gamari's avatar
Ben Gamari committed
306 307
  = mkPrimOpRule nm 2 $
    binaryCmpLit cmp : equal_rule : extra
308
  where
Ben Gamari's avatar
Ben Gamari committed
309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342
        -- x `cmp` x does not depend on x, so
        -- compute it for the arbitrary value 'True'
        -- and use that result
    equal_rule = do { equalArgs
                    ; 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 (for NaNs); so we do not want the equal_rule
rule that mkRelOpRule uses.

Note also that, in the case of equality/inequality, we do /not/
want to switch to a case-expression.  For example, we do not want
to convert
   case (eqFloat# x 3.8#) of
     True -> this
     False -> that
to
  case x of
    3.8#::Float# -> this
    _            -> that
See Trac #9238.  Reason: comparing floating-point values for equality
delicate, and we don't want to implement that delicacy in the code for
case expressions.  So we make it an invariant of Core that a case
expression never scrutinises a Float# or Double#.

This transformation is what the litEq rule does;
see Note [The litEq rule: converting equality to case].
So we /refrain/ from using litEq for mkFloatingRelOpRule.
-}
343 344

mkFloatingRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)
Ben Gamari's avatar
Ben Gamari committed
345 346 347 348
                    -> Maybe CoreRule
-- See Note [Rules for floating-point comparisons]
mkFloatingRelOpRule nm cmp
  = mkPrimOpRule nm 2 [binaryCmpLit cmp]
349 350

-- common constants
351 352 353 354 355 356
zeroi, onei, zerow, onew :: DynFlags -> Literal
zeroi dflags = mkMachInt  dflags 0
onei  dflags = mkMachInt  dflags 1
zerow dflags = mkMachWord dflags 0
onew  dflags = mkMachWord dflags 1

357
zerof, onef, twof, zerod, oned, twod :: Literal
358 359
zerof = mkMachFloat 0.0
onef  = mkMachFloat 1.0
360
twof  = mkMachFloat 2.0
361 362
zerod = mkMachDouble 0.0
oned  = mkMachDouble 1.0
363
twod  = mkMachDouble 2.0
364

365
cmpOp :: DynFlags -> (forall a . Ord a => a -> a -> Bool)
366
      -> Literal -> Literal -> Maybe CoreExpr
367
cmpOp dflags cmp = go
368
  where
369 370
    done True  = Just $ trueValInt  dflags
    done False = Just $ falseValInt dflags
371

372
    -- These compares are at different types
373 374 375 376 377 378 379
    go (MachChar i1)   (MachChar i2)   = done (i1 `cmp` i2)
    go (MachInt i1)    (MachInt i2)    = done (i1 `cmp` i2)
    go (MachInt64 i1)  (MachInt64 i2)  = done (i1 `cmp` i2)
    go (MachWord i1)   (MachWord i2)   = done (i1 `cmp` i2)
    go (MachWord64 i1) (MachWord64 i2) = done (i1 `cmp` i2)
    go (MachFloat i1)  (MachFloat i2)  = done (i1 `cmp` i2)
    go (MachDouble i1) (MachDouble i2) = done (i1 `cmp` i2)
Ian Lynagh's avatar
Ian Lynagh committed
380
    go _               _               = Nothing
381 382

--------------------------
383

384 385
negOp :: DynFlags -> Literal -> Maybe CoreExpr  -- Negate
negOp _      (MachFloat 0.0)  = Nothing  -- can't represent -0.0 as a Rational
386
negOp dflags (MachFloat f)    = Just (mkFloatVal dflags (-f))
387
negOp _      (MachDouble 0.0) = Nothing
388
negOp dflags (MachDouble d)   = Just (mkDoubleVal dflags (-d))
389 390
negOp dflags (MachInt i)      = intResult dflags (-i)
negOp _      _                = Nothing
391

392 393 394 395 396
complementOp :: DynFlags -> Literal -> Maybe CoreExpr  -- Binary complement
complementOp dflags (MachWord i) = wordResult dflags (complement i)
complementOp dflags (MachInt i)  = intResult  dflags (complement i)
complementOp _      _            = Nothing

397
--------------------------
398 399
intOp2 :: (Integral a, Integral b)
       => (a -> b -> Integer)
400
       -> DynFlags -> Literal -> Literal -> Maybe CoreExpr
401
intOp2 = intOp2' . const
402

403 404 405 406 407 408 409 410
intOp2' :: (Integral a, Integral b)
        => (DynFlags -> a -> b -> Integer)
        -> DynFlags -> Literal -> Literal -> Maybe CoreExpr
intOp2' op dflags (MachInt i1) (MachInt i2) =
  let o = op dflags
  in  intResult dflags (fromInteger i1 `o` fromInteger i2)
intOp2' _  _      _            _            = Nothing  -- Could find LitLit

411 412 413 414 415 416 417
intOpC2 :: (Integral a, Integral b)
        => (a -> b -> Integer)
        -> DynFlags -> Literal -> Literal -> Maybe CoreExpr
intOpC2 op dflags (MachInt i1) (MachInt i2) = do
  intCResult dflags (fromInteger i1 `op` fromInteger i2)
intOpC2 _  _      _            _            = Nothing  -- Could find LitLit

418
shiftRightLogical :: DynFlags -> Integer -> Int -> Integer
419
-- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do
420
-- Do this by converting to Word and back.  Obviously this won't work for big
421
-- values, but its ok as we use it here
422 423 424 425
shiftRightLogical dflags x n
  | wordSizeInBits dflags == 32 = fromIntegral (fromInteger x `shiftR` n :: Word32)
  | wordSizeInBits dflags == 64 = fromIntegral (fromInteger x `shiftR` n :: Word64)
  | otherwise = panic "shiftRightLogical: unsupported word size"
426

427
--------------------------
428 429 430 431
retLit :: (DynFlags -> Literal) -> RuleM CoreExpr
retLit l = do dflags <- getDynFlags
              return $ Lit $ l dflags

432 433 434 435 436 437
retLitNoC :: (DynFlags -> Literal) -> RuleM CoreExpr
retLitNoC l = do dflags <- getDynFlags
                 let lit = l dflags
                 let ty = literalType lit
                 return $ mkCoreUbxTup [ty, ty] [Lit lit, Lit (zeroi dflags)]

438 439
wordOp2 :: (Integral a, Integral b)
        => (a -> b -> Integer)
440 441 442 443 444
        -> DynFlags -> Literal -> Literal -> Maybe CoreExpr
wordOp2 op dflags (MachWord w1) (MachWord w2)
    = wordResult dflags (fromInteger w1 `op` fromInteger w2)
wordOp2 _ _ _ _ = Nothing  -- Could find LitLit

445 446 447 448 449 450 451
wordOpC2 :: (Integral a, Integral b)
        => (a -> b -> Integer)
        -> DynFlags -> Literal -> Literal -> Maybe CoreExpr
wordOpC2 op dflags (MachWord w1) (MachWord w2) =
  wordCResult dflags (fromInteger w1 `op` fromInteger w2)
wordOpC2 _ _ _ _ = Nothing  -- Could find LitLit

452
shiftRule :: (DynFlags -> Integer -> Int -> Integer) -> RuleM CoreExpr
453
                 -- Shifts take an Int; hence third arg of op is Int
454
-- See Note [Guarding against silly shifts]
455
shiftRule shift_op
456 457 458
  = do { dflags <- getDynFlags
       ; [e1, Lit (MachInt shift_len)] <- getArgs
       ; case e1 of
Austin Seipp's avatar
Austin Seipp committed
459
           _ | shift_len == 0
460 461
             -> return e1
             | shift_len < 0 || wordSizeInBits dflags < shift_len
Austin Seipp's avatar
Austin Seipp committed
462
             -> return (mkRuntimeErrorApp rUNTIME_ERROR_ID wordPrimTy
463
                                        ("Bad shift length" ++ show shift_len))
464 465 466 467 468 469

           -- Do the shift at type Integer, but shift length is Int
           Lit (MachInt x)
             -> let op = shift_op dflags
                in  liftMaybe $ intResult dflags (x `op` fromInteger shift_len)

470
           Lit (MachWord x)
471 472
             -> let op = shift_op dflags
                in  liftMaybe $ wordResult dflags (x `op` fromInteger shift_len)
473

474 475 476 477
           _ -> mzero }

wordSizeInBits :: DynFlags -> Integer
wordSizeInBits dflags = toInteger (platformWordSize (targetPlatform dflags) `shiftL` 3)
478

479
--------------------------
480 481
floatOp2 :: (Rational -> Rational -> Rational)
         -> DynFlags -> Literal -> Literal
Ian Lynagh's avatar
Ian Lynagh committed
482
         -> Maybe (Expr CoreBndr)
483 484
floatOp2 op dflags (MachFloat f1) (MachFloat f2)
  = Just (mkFloatVal dflags (f1 `op` f2))
485
floatOp2 _ _ _ _ = Nothing
486 487

--------------------------
488 489
doubleOp2 :: (Rational -> Rational -> Rational)
          -> DynFlags -> Literal -> Literal
Ian Lynagh's avatar
Ian Lynagh committed
490
          -> Maybe (Expr CoreBndr)
491 492
doubleOp2 op dflags (MachDouble f1) (MachDouble f2)
  = Just (mkDoubleVal dflags (f1 `op` f2))
493
doubleOp2 _ _ _ _ = Nothing
494 495

--------------------------
Ben Gamari's avatar
Ben Gamari committed
496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516
{- Note [The litEq rule: converting equality to case]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
This stuff turns
     n ==# 3#
into
     case n of
       3# -> True
       m  -> False

This is a Good Thing, because it allows case-of case things
to happen, and case-default absorption to happen.  For
example:

     if (n ==# 3#) || (n ==# 4#) then e1 else e2
will transform to
     case n of
       3# -> e1
       4# -> e1
       m  -> e2
(modulo the usual precautions to avoid duplicating e1)
-}
517

518 519 520 521
litEq :: Bool  -- True <=> equality, False <=> inequality
      -> RuleM CoreExpr
litEq is_eq = msum
  [ do [Lit lit, expr] <- getArgs
522 523
       dflags <- getDynFlags
       do_lit_eq dflags lit expr
524
  , do [expr, Lit lit] <- getArgs
525 526
       dflags <- getDynFlags
       do_lit_eq dflags lit expr ]
527
  where
528
    do_lit_eq dflags lit expr = do
529
      guard (not (litIsLifted lit))
530
      return (mkWildCase expr (literalType lit) intPrimTy
531 532
                    [(DEFAULT,    [], val_if_neq),
                     (LitAlt lit, [], val_if_eq)])
533 534 535 536 537
      where
        val_if_eq  | is_eq     = trueValInt  dflags
                   | otherwise = falseValInt dflags
        val_if_neq | is_eq     = falseValInt dflags
                   | otherwise = trueValInt  dflags
538

539 540 541 542

-- | Check if there is comparison with minBound or maxBound, that is
-- always true or false. For instance, an Int cannot be smaller than its
-- minBound, so we can replace such comparison with False.
543 544
boundsCmp :: Comparison -> RuleM CoreExpr
boundsCmp op = do
545
  dflags <- getDynFlags
546
  [a, b] <- getArgs
547
  liftMaybe $ mkRuleFn dflags op a b
548 549 550

data Comparison = Gt | Ge | Lt | Le

551
mkRuleFn :: DynFlags -> Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr
552 553 554 555 556 557 558 559
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
560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576
mkRuleFn _ _ _ _                                       = Nothing

isMinBound :: DynFlags -> Literal -> Bool
isMinBound _      (MachChar c)   = c == minBound
isMinBound dflags (MachInt i)    = i == tARGET_MIN_INT dflags
isMinBound _      (MachInt64 i)  = i == toInteger (minBound :: Int64)
isMinBound _      (MachWord i)   = i == 0
isMinBound _      (MachWord64 i) = i == 0
isMinBound _      _              = False

isMaxBound :: DynFlags -> Literal -> Bool
isMaxBound _      (MachChar c)   = c == maxBound
isMaxBound dflags (MachInt i)    = i == tARGET_MAX_INT dflags
isMaxBound _      (MachInt64 i)  = i == toInteger (maxBound :: Int64)
isMaxBound dflags (MachWord i)   = i == tARGET_MAX_WORD dflags
isMaxBound _      (MachWord64 i) = i == toInteger (maxBound :: Word64)
isMaxBound _      _              = False
577

578 579
-- | Create an Int literal expression while ensuring the given Integer is in the
-- target Int range
580
intResult :: DynFlags -> Integer -> Maybe CoreExpr
581
intResult dflags result = Just (Lit (mkMachIntWrap dflags result))
582

583 584 585 586 587 588 589 590 591 592
-- | Create an unboxed pair of an Int literal expression, ensuring the given
-- Integer is in the target Int range and the corresponding overflow flag
-- (@0#@/@1#@) if it wasn't.
intCResult :: DynFlags -> Integer -> Maybe CoreExpr
intCResult dflags result = Just (mkPair [Lit lit, Lit c])
  where
    mkPair = mkCoreUbxTup [intPrimTy, intPrimTy]
    (lit, b) = mkMachIntWrapC dflags result
    c = if b then onei dflags else zeroi dflags

593 594
-- | Create a Word literal expression while ensuring the given Integer is in the
-- target Word range
595
wordResult :: DynFlags -> Integer -> Maybe CoreExpr
596
wordResult dflags result = Just (Lit (mkMachWordWrap dflags result))
597

598 599 600 601 602 603 604 605 606 607
-- | Create an unboxed pair of a Word literal expression, ensuring the given
-- Integer is in the target Word range and the corresponding carry flag
-- (@0#@/@1#@) if it wasn't.
wordCResult :: DynFlags -> Integer -> Maybe CoreExpr
wordCResult dflags result = Just (mkPair [Lit lit, Lit c])
  where
    mkPair = mkCoreUbxTup [wordPrimTy, intPrimTy]
    (lit, b) = mkMachWordWrapC dflags result
    c = if b then onei dflags else zeroi dflags

pcapriotti's avatar
pcapriotti committed
608 609 610 611 612 613
inversePrimOp :: PrimOp -> RuleM CoreExpr
inversePrimOp primop = do
  [Var primop_id `App` e] <- getArgs
  matchPrimOpId primop primop_id
  return e

614 615 616 617 618 619 620 621 622 623 624
subsumesPrimOp :: PrimOp -> PrimOp -> RuleM CoreExpr
this `subsumesPrimOp` that = do
  [Var primop_id `App` e] <- getArgs
  matchPrimOpId that primop_id
  return (Var (mkPrimOpId this) `App` e)

subsumedByPrimOp :: PrimOp -> RuleM CoreExpr
subsumedByPrimOp primop = do
  [e@(Var primop_id `App` _)] <- getArgs
  matchPrimOpId primop primop_id
  return e
625 626 627 628 629

idempotent :: RuleM CoreExpr
idempotent = do [e1, e2] <- getArgs
                guard $ cheapEqExpr e1 e2
                return e1
630

Austin Seipp's avatar
Austin Seipp committed
631
{-
632 633 634 635 636 637 638 639 640 641 642
Note [Guarding against silly shifts]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this code:

  import Data.Bits( (.|.), shiftL )
  chunkToBitmap :: [Bool] -> Word32
  chunkToBitmap chunk = foldr (.|.) 0 [ 1 `shiftL` n | (True,n) <- zip chunk [0..] ]

This optimises to:
Shift.$wgo = \ (w_sCS :: GHC.Prim.Int#) (w1_sCT :: [GHC.Types.Bool]) ->
    case w1_sCT of _ {
643
      [] -> 0##;
644 645 646 647 648
      : x_aAW xs_aAX ->
        case x_aAW of _ {
          GHC.Types.False ->
            case w_sCS of wild2_Xh {
              __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild2_Xh 1) xs_aAX;
649
              9223372036854775807 -> 0## };
650 651 652 653 654 655 656
          GHC.Types.True ->
            case GHC.Prim.>=# w_sCS 64 of _ {
              GHC.Types.False ->
                case w_sCS of wild3_Xh {
                  __DEFAULT ->
                    case Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX of ww_sCW { __DEFAULT ->
                      GHC.Prim.or# (GHC.Prim.narrow32Word#
657
                                      (GHC.Prim.uncheckedShiftL# 1## wild3_Xh))
658 659 660 661
                                   ww_sCW
                     };
                  9223372036854775807 ->
                    GHC.Prim.narrow32Word#
662
!!!!-->                  (GHC.Prim.uncheckedShiftL# 1## 9223372036854775807)
663 664 665 666
                };
              GHC.Types.True ->
                case w_sCS of wild3_Xh {
                  __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX;
667
                  9223372036854775807 -> 0##
668 669
                } } } }

Austin Seipp's avatar
Austin Seipp committed
670
Note the massive shift on line "!!!!".  It can't happen, because we've checked
671 672 673 674 675 676 677 678
that w < 64, but the optimiser didn't spot that. We DO NO want to constant-fold this!
Moreover, if the programmer writes (n `uncheckedShiftL` 9223372036854775807), we
can't constant fold it, but if it gets to the assember we get
     Error: operand type mismatch for `shl'

So the best thing to do is to rewrite the shift with a call to error,
when the second arg is stupid.

Austin Seipp's avatar
Austin Seipp committed
679 680
************************************************************************
*                                                                      *
681
\subsection{Vaguely generic functions}
Austin Seipp's avatar
Austin Seipp committed
682 683 684
*                                                                      *
************************************************************************
-}
685

686
mkBasicRule :: Name -> Int -> RuleM CoreExpr -> CoreRule
687
-- Gives the Rule the same name as the primop itself
688
mkBasicRule op_name n_args rm
689 690 691
  = BuiltinRule { ru_name = occNameFS (nameOccName op_name),
                  ru_fn = op_name,
                  ru_nargs = n_args,
692
                  ru_try = \ dflags in_scope _ -> runRuleM rm dflags in_scope }
693 694

newtype RuleM r = RuleM
695
  { runRuleM :: DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe r }
696

Austin Seipp's avatar
Austin Seipp committed
697 698 699 700
instance Functor RuleM where
    fmap = liftM

instance Applicative RuleM where
701
    pure x = RuleM $ \_ _ _ -> Just x
Austin Seipp's avatar
Austin Seipp committed
702 703
    (<*>) = ap

704
instance Monad RuleM where
705
  RuleM f >>= g = RuleM $ \dflags iu e -> case f dflags iu e of
706
    Nothing -> Nothing
707
    Just r -> runRuleM (g r) dflags iu e
708
  fail = MonadFail.fail
709

quchen's avatar
quchen committed
710 711 712
instance MonadFail.MonadFail RuleM where
    fail _ = mzero

Austin Seipp's avatar
Austin Seipp committed
713
instance Alternative RuleM where
714 715 716
  empty = RuleM $ \_ _ _ -> Nothing
  RuleM f1 <|> RuleM f2 = RuleM $ \dflags iu args ->
    f1 dflags iu args <|> f2 dflags iu args
Austin Seipp's avatar
Austin Seipp committed
717

718
instance MonadPlus RuleM
719 720 721

instance HasDynFlags RuleM where
    getDynFlags = RuleM $ \dflags _ _ -> Just dflags
722 723 724 725 726 727

liftMaybe :: Maybe a -> RuleM a
liftMaybe Nothing = mzero
liftMaybe (Just x) = return x

liftLit :: (Literal -> Literal) -> RuleM CoreExpr
728 729 730 731 732
liftLit f = liftLitDynFlags (const f)

liftLitDynFlags :: (DynFlags -> Literal -> Literal) -> RuleM CoreExpr
liftLitDynFlags f = do
  dflags <- getDynFlags
733
  [Lit lit] <- getArgs
734
  return $ Lit (f dflags lit)
735

pcapriotti's avatar
pcapriotti committed
736
removeOp32 :: RuleM CoreExpr
pcapriotti's avatar
pcapriotti committed
737
removeOp32 = do
738 739 740 741 742 743
  dflags <- getDynFlags
  if wordSizeInBits dflags == 32
  then do
    [e] <- getArgs
    return e
  else mzero
pcapriotti's avatar
pcapriotti committed
744

745
getArgs :: RuleM [CoreExpr]
746
getArgs = RuleM $ \_ _ args -> Just args
747

748 749
getInScopeEnv :: RuleM InScopeEnv
getInScopeEnv = RuleM $ \_ iu _ -> Just iu
750 751 752 753

-- return the n-th argument of this rule, if it is a literal
-- argument indices start from 0
getLiteral :: Int -> RuleM Literal
754
getLiteral n = RuleM $ \_ _ exprs -> case drop n exprs of
755 756 757
  (Lit l:_) -> Just l
  _ -> Nothing

758
unaryLit :: (DynFlags -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
759
unaryLit op = do
760
  dflags <- getDynFlags
761
  [Lit l] <- getArgs
762
  liftMaybe $ op dflags (convFloating dflags l)
763

764
binaryLit :: (DynFlags -> Literal -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
765
binaryLit op = do
766
  dflags <- getDynFlags
767
  [Lit l1, Lit l2] <- getArgs
768
  liftMaybe $ op dflags (convFloating dflags l1) (convFloating dflags l2)
769

770 771 772 773 774
binaryCmpLit :: (forall a . Ord a => a -> a -> Bool) -> RuleM CoreExpr
binaryCmpLit op = do
  dflags <- getDynFlags
  binaryLit (\_ -> cmpOp dflags op)

775
leftIdentity :: Literal -> RuleM CoreExpr
776 777 778 779 780 781 782 783 784 785 786
leftIdentity id_lit = leftIdentityDynFlags (const id_lit)

rightIdentity :: Literal -> RuleM CoreExpr
rightIdentity id_lit = rightIdentityDynFlags (const id_lit)

identity :: Literal -> RuleM CoreExpr
identity lit = leftIdentity lit `mplus` rightIdentity lit

leftIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
leftIdentityDynFlags id_lit = do
  dflags <- getDynFlags
787
  [Lit l1, e2] <- getArgs
788
  guard $ l1 == id_lit dflags
789 790
  return e2

791 792 793 794 795 796 797 798 799 800
-- | Left identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in
-- addition to the result, we have to indicate that no carry/overflow occured.
leftIdentityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
leftIdentityCDynFlags id_lit = do
  dflags <- getDynFlags
  [Lit l1, e2] <- getArgs
  guard $ l1 == id_lit dflags
  let no_c = Lit (zeroi dflags)
  return (mkCoreUbxTup [exprType e2, intPrimTy] [e2, no_c])

801 802 803
rightIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
rightIdentityDynFlags id_lit = do
  dflags <- getDynFlags
804
  [e1, Lit l2] <- getArgs
805
  guard $ l2 == id_lit dflags
806 807
  return e1

808 809 810 811 812 813 814 815 816 817
-- | Right identity rule for PrimOps like 'IntSubC' and 'WordSubC', where, in
-- addition to the result, we have to indicate that no carry/overflow occured.
rightIdentityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
rightIdentityCDynFlags id_lit = do
  dflags <- getDynFlags
  [e1, Lit l2] <- getArgs
  guard $ l2 == id_lit dflags
  let no_c = Lit (zeroi dflags)
  return (mkCoreUbxTup [exprType e1, intPrimTy] [e1, no_c])

818
identityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
819 820 821 822 823 824 825 826
identityDynFlags lit =
  leftIdentityDynFlags lit `mplus` rightIdentityDynFlags lit

-- | Identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in addition
-- to the result, we have to indicate that no carry/overflow occured.
identityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
identityCDynFlags lit =
  leftIdentityCDynFlags lit `mplus` rightIdentityCDynFlags lit
827

828
leftZero :: (DynFlags -> Literal) -> RuleM CoreExpr
829
leftZero zero = do
830
  dflags <- getDynFlags
831
  [Lit l1, _] <- getArgs
832 833
  guard $ l1 == zero dflags
  return $ Lit l1
834

835
rightZero :: (DynFlags -> Literal) -> RuleM CoreExpr
836
rightZero zero = do
837
  dflags <- getDynFlags
838
  [_, Lit l2] <- getArgs
839 840
  guard $ l2 == zero dflags
  return $ Lit l2
841

842
zeroElem :: (DynFlags -> Literal) -> RuleM CoreExpr
843 844 845 846 847 848 849 850 851
zeroElem lit = leftZero lit `mplus` rightZero lit

equalArgs :: RuleM ()
equalArgs = do
  [e1, e2] <- getArgs
  guard $ e1 `cheapEqExpr` e2

nonZeroLit :: Int -> RuleM ()
nonZeroLit n = getLiteral n >>= guard . not . isZeroLit
852

853 854 855
-- When excess precision is not requested, cut down the precision of the
-- Rational value to that of Float/Double. We confuse host architecture
-- and target architecture here, but it's convenient (and wrong :-).
856
convFloating :: DynFlags -> Literal -> Literal
ian@well-typed.com's avatar
ian@well-typed.com committed
857
convFloating dflags (MachFloat  f) | not (gopt Opt_ExcessPrecision dflags) =
858
   MachFloat  (toRational (fromRational f :: Float ))
ian@well-typed.com's avatar
ian@well-typed.com committed
859
convFloating dflags (MachDouble d) | not (gopt Opt_ExcessPrecision dflags) =
860
   MachDouble (toRational (fromRational d :: Double))
861
convFloating _ l = l
862

863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878
guardFloatDiv :: RuleM ()
guardFloatDiv = do
  [Lit (MachFloat f1), Lit (MachFloat f2)] <- getArgs
  guard $ (f1 /=0 || f2 > 0) -- see Note [negative zero]
       && f2 /= 0            -- avoid NaN and Infinity/-Infinity

guardDoubleDiv :: RuleM ()
guardDoubleDiv = do
  [Lit (MachDouble d1), Lit (MachDouble d2)] <- getArgs
  guard $ (d1 /=0 || d2 > 0) -- see Note [negative zero]
       && d2 /= 0            -- avoid NaN and Infinity/-Infinity
-- Note [negative zero] Avoid (0 / -d), otherwise 0/(-1) reduces to
-- zero, but we might want to preserve the negative zero here which
-- is representable in Float/Double but not in (normalised)
-- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead?

879 880 881 882 883 884 885 886 887 888
strengthReduction :: Literal -> PrimOp -> RuleM CoreExpr
strengthReduction two_lit add_op = do -- Note [Strength reduction]
  arg <- msum [ do [arg, Lit mult_lit] <- getArgs
                   guard (mult_lit == two_lit)
                   return arg
              , do [Lit mult_lit, arg] <- getArgs
                   guard (mult_lit == two_lit)
                   return arg ]
  return $ Var (mkPrimOpId add_op) `App` arg `App` arg

Jan Stolarek's avatar
Jan Stolarek committed
889 890 891 892 893 894
-- Note [Strength reduction]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- This rule turns floating point multiplications of the form 2.0 * x and
-- x * 2.0 into x + x addition, because addition costs less than multiplication.
-- See #7116
895

896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912
-- 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
913 914 915 916 917 918

ltVal, eqVal, gtVal :: Expr CoreBndr
ltVal = Var ltDataConId
eqVal = Var eqDataConId
gtVal = Var gtDataConId

919 920
mkIntVal :: DynFlags -> Integer -> Expr CoreBndr
mkIntVal dflags i = Lit (mkMachInt dflags i)
921 922 923 924
mkFloatVal :: DynFlags -> Rational -> Expr CoreBndr
mkFloatVal dflags f = Lit (convFloating dflags (MachFloat  f))
mkDoubleVal :: DynFlags -> Rational -> Expr CoreBndr
mkDoubleVal dflags d = Lit (convFloating dflags (MachDouble d))
925

pcapriotti's avatar
pcapriotti committed
926 927 928 929 930
matchPrimOpId :: PrimOp -> Id -> RuleM ()
matchPrimOpId op id = do
  op' <- liftMaybe $ isPrimOpId_maybe id
  guard $ op == op'

Austin Seipp's avatar
Austin Seipp committed
931 932 933
{-
************************************************************************
*                                                                      *
934
\subsection{Special rules for seq, tagToEnum, dataToTag}
Austin Seipp's avatar
Austin Seipp committed
935 936
*                                                                      *
************************************************************************
937

938 939 940 941 942 943 944
Note [tagToEnum#]
~~~~~~~~~~~~~~~~~
Nasty check to ensure that tagToEnum# is applied to a type that is an
enumeration TyCon.  Unification may refine the type later, but this
check won't see that, alas.  It's crude but it works.

Here's are two cases that should fail
945 946
        f :: forall a. a
        f = tagToEnum# 0        -- Can't do tagToEnum# at a type variable