PrelRules.hs 56.1 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 16
{-# LANGUAGE CPP, RankNTypes #-}
{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
17

18
module PrelRules ( primOpRules, builtinRules ) where
19 20

#include "HsVersions.h"
pcapriotti's avatar
pcapriotti committed
21
#include "../includes/MachDeps.h"
22

23
import {-# SOURCE #-} MkId ( mkPrimOpId, magicDictId )
24

25
import CoreSyn
26
import MkCore
27 28
import Id
import Literal
29
import CoreSubst   ( exprIsLiteral_maybe )
30
import PrimOp      ( PrimOp(..), tagToEnumKey )
31
import TysWiredIn
32
import TysPrim
33
import TyCon       ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon, unwrapNewTyCon_maybe )
34
import DataCon     ( dataConTag, dataConTyCon, dataConWorkId )
35
import CoreUtils   ( cheapEqExpr, exprIsHNF )
36
import CoreUnfold  ( exprIsConApp_maybe )
37
import Type
38
import TypeRep
39
import OccName     ( occNameFS )
40
import PrelNames
41 42
import Maybes      ( orElse )
import Name        ( Name, nameOccName )
43
import Outputable
44
import FastString
45
import BasicTypes
46
import DynFlags
47
import Platform
48
import Util
49
import Coercion     (mkUnbranchedAxInstCo,mkSymCo,Role(..))
50

51 52 53
#if __GLASGOW_HASKELL__ >= 709
import Control.Applicative ( Alternative(..) )
#else
Austin Seipp's avatar
Austin Seipp committed
54
import Control.Applicative ( Applicative(..), Alternative(..) )
55 56
#endif

57
import Control.Monad
58
import Data.Bits as Bits
59
import qualified Data.ByteString as BS
60
import Data.Int
61
import Data.Ratio
62
import Data.Word
63

Austin Seipp's avatar
Austin Seipp committed
64
{-
65 66
Note [Constant folding]
~~~~~~~~~~~~~~~~~~~~~~~
67
primOpRules generates a rewrite rule for each primop
68 69
These rules do what is often called "constant folding"
E.g. the rules for +# might say
70 71
        4 +# 5 = 9
Well, of course you'd need a lot of rules if you did it
72 73 74
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
75
        (Lit x) +# (Lit y) = Lit (x+#y)
76 77
where the (+#) on the rhs is done at compile time

78
That is why these rules are built in here.
Austin Seipp's avatar
Austin Seipp committed
79
-}
80

81
primOpRules :: Name -> PrimOp -> Maybe CoreRule
82 83
    -- ToDo: something for integer-shift ops?
    --       NotOp
84 85 86 87 88
primOpRules nm TagToEnumOp = mkPrimOpRule nm 2 [ tagToEnumRule ]
primOpRules nm DataToTagOp = mkPrimOpRule nm 2 [ dataToTagRule ]

-- Int operations
primOpRules nm IntAddOp    = mkPrimOpRule nm 2 [ binaryLit (intOp2 (+))
89
                                               , identityDynFlags zeroi ]
90
primOpRules nm IntSubOp    = mkPrimOpRule nm 2 [ binaryLit (intOp2 (-))
91 92
                                               , rightIdentityDynFlags zeroi
                                               , equalArgs >> retLit zeroi ]
93 94
primOpRules nm IntMulOp    = mkPrimOpRule nm 2 [ binaryLit (intOp2 (*))
                                               , zeroElem zeroi
95
                                               , identityDynFlags onei ]
96 97
primOpRules nm IntQuotOp   = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 quot)
                                               , leftZero zeroi
98 99
                                               , rightIdentityDynFlags onei
                                               , equalArgs >> retLit onei ]
100 101 102
primOpRules nm IntRemOp    = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 rem)
                                               , leftZero zeroi
                                               , do l <- getLiteral 1
103 104 105 106 107
                                                    dflags <- getDynFlags
                                                    guard (l == onei dflags)
                                                    retLit zeroi
                                               , equalArgs >> retLit zeroi
                                               , equalArgs >> retLit zeroi ]
108 109 110 111 112 113 114 115 116
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 ]
117 118
primOpRules nm NotIOp      = mkPrimOpRule nm 1 [ unaryLit complementOp
                                               , inversePrimOp NotIOp ]
119 120
primOpRules nm IntNegOp    = mkPrimOpRule nm 1 [ unaryLit negOp
                                               , inversePrimOp IntNegOp ]
121
primOpRules nm ISllOp      = mkPrimOpRule nm 2 [ binaryLit (intOp2 Bits.shiftL)
122
                                               , rightIdentityDynFlags zeroi ]
123
primOpRules nm ISraOp      = mkPrimOpRule nm 2 [ binaryLit (intOp2 Bits.shiftR)
124
                                               , rightIdentityDynFlags zeroi ]
125
primOpRules nm ISrlOp      = mkPrimOpRule nm 2 [ binaryLit (intOp2' shiftRightLogical)
126
                                               , rightIdentityDynFlags zeroi ]
127 128 129

-- Word operations
primOpRules nm WordAddOp   = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (+))
130
                                               , identityDynFlags zerow ]
131
primOpRules nm WordSubOp   = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (-))
132 133
                                               , rightIdentityDynFlags zerow
                                               , equalArgs >> retLit zerow ]
134
primOpRules nm WordMulOp   = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (*))
135
                                               , identityDynFlags onew ]
136
primOpRules nm WordQuotOp  = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 quot)
137
                                               , rightIdentityDynFlags onew ]
138
primOpRules nm WordRemOp   = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 rem)
139
                                               , rightIdentityDynFlags onew ]
140
primOpRules nm AndOp       = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.&.))
141
                                               , idempotent
142 143
                                               , zeroElem zerow ]
primOpRules nm OrOp        = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.|.))
144
                                               , idempotent
145
                                               , identityDynFlags zerow ]
146
primOpRules nm XorOp       = mkPrimOpRule nm 2 [ binaryLit (wordOp2 xor)
147 148
                                               , identityDynFlags zerow
                                               , equalArgs >> retLit zerow ]
149 150
primOpRules nm NotOp       = mkPrimOpRule nm 1 [ unaryLit complementOp
                                               , inversePrimOp NotOp ]
151
primOpRules nm SllOp       = mkPrimOpRule nm 2 [ wordShiftRule (const Bits.shiftL) ]
152
primOpRules nm SrlOp       = mkPrimOpRule nm 2 [ wordShiftRule shiftRightLogical ]
153 154

-- coercions
155
primOpRules nm Word2IntOp     = mkPrimOpRule nm 1 [ liftLitDynFlags word2IntLit
pcapriotti's avatar
pcapriotti committed
156
                                                  , inversePrimOp Int2WordOp ]
157
primOpRules nm Int2WordOp     = mkPrimOpRule nm 1 [ liftLitDynFlags int2WordLit
pcapriotti's avatar
pcapriotti committed
158
                                                  , inversePrimOp Word2IntOp ]
159 160
primOpRules nm Narrow8IntOp   = mkPrimOpRule nm 1 [ liftLit narrow8IntLit
                                                  , subsumedByPrimOp Narrow8IntOp
161 162
                                                  , Narrow8IntOp `subsumesPrimOp` Narrow16IntOp
                                                  , Narrow8IntOp `subsumesPrimOp` Narrow32IntOp ]
163
primOpRules nm Narrow16IntOp  = mkPrimOpRule nm 1 [ liftLit narrow16IntLit
164
                                                  , subsumedByPrimOp Narrow8IntOp
165
                                                  , subsumedByPrimOp Narrow16IntOp
166
                                                  , Narrow16IntOp `subsumesPrimOp` Narrow32IntOp ]
pcapriotti's avatar
pcapriotti committed
167
primOpRules nm Narrow32IntOp  = mkPrimOpRule nm 1 [ liftLit narrow32IntLit
168 169
                                                  , subsumedByPrimOp Narrow8IntOp
                                                  , subsumedByPrimOp Narrow16IntOp
170
                                                  , subsumedByPrimOp Narrow32IntOp
pcapriotti's avatar
pcapriotti committed
171
                                                  , removeOp32 ]
172 173
primOpRules nm Narrow8WordOp  = mkPrimOpRule nm 1 [ liftLit narrow8WordLit
                                                  , subsumedByPrimOp Narrow8WordOp
174 175
                                                  , Narrow8WordOp `subsumesPrimOp` Narrow16WordOp
                                                  , Narrow8WordOp `subsumesPrimOp` Narrow32WordOp ]
176
primOpRules nm Narrow16WordOp = mkPrimOpRule nm 1 [ liftLit narrow16WordLit
177
                                                  , subsumedByPrimOp Narrow8WordOp
178
                                                  , subsumedByPrimOp Narrow16WordOp
179
                                                  , Narrow16WordOp `subsumesPrimOp` Narrow32WordOp ]
pcapriotti's avatar
pcapriotti committed
180
primOpRules nm Narrow32WordOp = mkPrimOpRule nm 1 [ liftLit narrow32WordLit
181 182
                                                  , subsumedByPrimOp Narrow8WordOp
                                                  , subsumedByPrimOp Narrow16WordOp
183
                                                  , subsumedByPrimOp Narrow32WordOp
pcapriotti's avatar
pcapriotti committed
184
                                                  , removeOp32 ]
185 186 187 188 189 190
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 ]
191 192 193 194 195 196 197 198 199 200 201 202 203 204
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 (*))
205 206
                                                , identity onef
                                                , strengthReduction twof FloatAddOp  ]
207 208 209
                         -- zeroElem zerof doesn't hold because of NaN
primOpRules nm FloatDivOp   = mkPrimOpRule nm 2 [ guardFloatDiv >> binaryLit (floatOp2 (/))
                                                , rightIdentity onef ]
210 211
primOpRules nm FloatNegOp   = mkPrimOpRule nm 1 [ unaryLit negOp
                                                , inversePrimOp FloatNegOp ]
212 213 214 215 216 217 218

-- 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 (*))
219 220
                                                 , identity oned
                                                 , strengthReduction twod DoubleAddOp  ]
221 222 223
                          -- zeroElem zerod doesn't hold because of NaN
primOpRules nm DoubleDivOp   = mkPrimOpRule nm 2 [ guardDoubleDiv >> binaryLit (doubleOp2 (/))
                                                 , rightIdentity oned ]
224 225
primOpRules nm DoubleNegOp   = mkPrimOpRule nm 1 [ unaryLit negOp
                                                 , inversePrimOp DoubleNegOp ]
226 227

-- Relational operators
228

229 230 231 232 233 234 235 236 237 238 239 240 241 242 243
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 ]

244 245 246 247 248 249
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 ]
250

251 252 253 254 255 256
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 ]
257 258 259 260 261 262

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
263
primOpRules nm WordNeOp   = mkRelOpRule nm (/=) [ litEq False ]
264

265 266
primOpRules nm AddrAddOp  = mkPrimOpRule nm 2 [ rightIdentityDynFlags zeroi ]

267 268 269
primOpRules nm SeqOp      = mkPrimOpRule nm 4 [ seqRule ]
primOpRules nm SparkOp    = mkPrimOpRule nm 4 [ sparkRule ]

270
primOpRules _  _          = Nothing
271

Austin Seipp's avatar
Austin Seipp committed
272 273 274
{-
************************************************************************
*                                                                      *
275
\subsection{Doing the business}
Austin Seipp's avatar
Austin Seipp committed
276 277 278
*                                                                      *
************************************************************************
-}
279

280
-- useful shorthands
281 282 283 284 285 286 287 288
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
  = mkPrimOpRule nm 2 $ rules ++ extra
  where
289 290
    rules = [ binaryCmpLit cmp
            , do equalArgs
291 292 293
              -- x `cmp` x does not depend on x, so
              -- compute it for the arbitrary value 'True'
              -- and use that result
294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309
                 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
310 311

-- common constants
312 313 314 315 316 317
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

318
zerof, onef, twof, zerod, oned, twod :: Literal
319 320
zerof = mkMachFloat 0.0
onef  = mkMachFloat 1.0
321
twof  = mkMachFloat 2.0
322 323
zerod = mkMachDouble 0.0
oned  = mkMachDouble 1.0
324
twod  = mkMachDouble 2.0
325

326
cmpOp :: DynFlags -> (forall a . Ord a => a -> a -> Bool)
327
      -> Literal -> Literal -> Maybe CoreExpr
328
cmpOp dflags cmp = go
329
  where
330 331
    done True  = Just $ trueValInt  dflags
    done False = Just $ falseValInt dflags
332

333
    -- These compares are at different types
334 335 336 337 338 339 340
    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
341
    go _               _               = Nothing
342 343

--------------------------
344

345 346
negOp :: DynFlags -> Literal -> Maybe CoreExpr  -- Negate
negOp _      (MachFloat 0.0)  = Nothing  -- can't represent -0.0 as a Rational
347
negOp dflags (MachFloat f)    = Just (mkFloatVal dflags (-f))
348
negOp _      (MachDouble 0.0) = Nothing
349
negOp dflags (MachDouble d)   = Just (mkDoubleVal dflags (-d))
350 351
negOp dflags (MachInt i)      = intResult dflags (-i)
negOp _      _                = Nothing
352

353 354 355 356 357
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

358
--------------------------
359 360
intOp2 :: (Integral a, Integral b)
       => (a -> b -> Integer)
361
       -> DynFlags -> Literal -> Literal -> Maybe CoreExpr
362
intOp2 = intOp2' . const
363

364 365 366 367 368 369 370 371 372
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

shiftRightLogical :: DynFlags -> Integer -> Int -> Integer
373
-- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do
374
-- Do this by converting to Word and back.  Obviously this won't work for big
375
-- values, but its ok as we use it here
376 377 378 379
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"
380

381
--------------------------
382 383 384 385
retLit :: (DynFlags -> Literal) -> RuleM CoreExpr
retLit l = do dflags <- getDynFlags
              return $ Lit $ l dflags

386 387
wordOp2 :: (Integral a, Integral b)
        => (a -> b -> Integer)
388 389 390 391 392
        -> DynFlags -> Literal -> Literal -> Maybe CoreExpr
wordOp2 op dflags (MachWord w1) (MachWord w2)
    = wordResult dflags (fromInteger w1 `op` fromInteger w2)
wordOp2 _ _ _ _ = Nothing  -- Could find LitLit

393 394
wordShiftRule :: (DynFlags -> Integer -> Int -> Integer) -> RuleM CoreExpr
                 -- Shifts take an Int; hence third arg of op is Int
395 396 397 398 399
-- See Note [Guarding against silly shifts]
wordShiftRule shift_op
  = do { dflags <- getDynFlags
       ; [e1, Lit (MachInt shift_len)] <- getArgs
       ; case e1 of
Austin Seipp's avatar
Austin Seipp committed
400
           _ | shift_len == 0
401 402
             -> return e1
             | shift_len < 0 || wordSizeInBits dflags < shift_len
Austin Seipp's avatar
Austin Seipp committed
403
             -> return (mkRuntimeErrorApp rUNTIME_ERROR_ID wordPrimTy
404 405
                                        ("Bad shift length" ++ show shift_len))
           Lit (MachWord x)
406 407
             -> let op = shift_op dflags
                in  liftMaybe $ wordResult dflags (x `op` fromInteger shift_len)
408 409 410 411 412
                    -- Do the shift at type Integer, but shift length is Int
           _ -> mzero }

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

414
--------------------------
415 416
floatOp2 :: (Rational -> Rational -> Rational)
         -> DynFlags -> Literal -> Literal
Ian Lynagh's avatar
Ian Lynagh committed
417
         -> Maybe (Expr CoreBndr)
418 419
floatOp2 op dflags (MachFloat f1) (MachFloat f2)
  = Just (mkFloatVal dflags (f1 `op` f2))
420
floatOp2 _ _ _ _ = Nothing
421 422

--------------------------
423 424
doubleOp2 :: (Rational -> Rational -> Rational)
          -> DynFlags -> Literal -> Literal
Ian Lynagh's avatar
Ian Lynagh committed
425
          -> Maybe (Expr CoreBndr)
426 427
doubleOp2 op dflags (MachDouble f1) (MachDouble f2)
  = Just (mkDoubleVal dflags (f1 `op` f2))
428
doubleOp2 _ _ _ _ = Nothing
429 430

--------------------------
431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449
-- 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)

450 451 452 453
litEq :: Bool  -- True <=> equality, False <=> inequality
      -> RuleM CoreExpr
litEq is_eq = msum
  [ do [Lit lit, expr] <- getArgs
454 455
       dflags <- getDynFlags
       do_lit_eq dflags lit expr
456
  , do [expr, Lit lit] <- getArgs
457 458
       dflags <- getDynFlags
       do_lit_eq dflags lit expr ]
459
  where
460
    do_lit_eq dflags lit expr = do
461
      guard (not (litIsLifted lit))
462
      return (mkWildCase expr (literalType lit) intPrimTy
463 464
                    [(DEFAULT,    [], val_if_neq),
                     (LitAlt lit, [], val_if_eq)])
465 466 467 468 469
      where
        val_if_eq  | is_eq     = trueValInt  dflags
                   | otherwise = falseValInt dflags
        val_if_neq | is_eq     = falseValInt dflags
                   | otherwise = trueValInt  dflags
470

471 472 473 474

-- | 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.
475 476
boundsCmp :: Comparison -> RuleM CoreExpr
boundsCmp op = do
477
  dflags <- getDynFlags
478
  [a, b] <- getArgs
479
  liftMaybe $ mkRuleFn dflags op a b
480 481 482

data Comparison = Gt | Ge | Lt | Le

483
mkRuleFn :: DynFlags -> Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr
484 485 486 487 488 489 490 491
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
492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508
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
509 510


511 512 513 514
-- Note that we *don't* warn the user about overflow. It's not done at
-- runtime either, and compilation of completely harmless things like
--    ((124076834 :: Word32) + (2147483647 :: Word32))
-- would yield a warning. Instead we simply squash the value into the
515
-- *target* Int/Word range.
516
intResult :: DynFlags -> Integer -> Maybe CoreExpr
517 518 519 520 521
intResult dflags result = Just (mkIntVal dflags result')
    where result' = case platformWordSize (targetPlatform dflags) of
                    4 -> toInteger (fromInteger result :: Int32)
                    8 -> toInteger (fromInteger result :: Int64)
                    w -> panic ("intResult: Unknown platformWordSize: " ++ show w)
522

523
wordResult :: DynFlags -> Integer -> Maybe CoreExpr
524 525 526 527 528
wordResult dflags result = Just (mkWordVal dflags result')
    where result' = case platformWordSize (targetPlatform dflags) of
                    4 -> toInteger (fromInteger result :: Word32)
                    8 -> toInteger (fromInteger result :: Word64)
                    w -> panic ("wordResult: Unknown platformWordSize: " ++ show w)
529

pcapriotti's avatar
pcapriotti committed
530 531 532 533 534 535
inversePrimOp :: PrimOp -> RuleM CoreExpr
inversePrimOp primop = do
  [Var primop_id `App` e] <- getArgs
  matchPrimOpId primop primop_id
  return e

536 537 538 539 540 541 542 543 544 545 546
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
547 548 549 550 551

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

Austin Seipp's avatar
Austin Seipp committed
553
{-
554 555 556 557 558 559 560 561 562 563 564
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 _ {
565
      [] -> 0##;
566 567 568 569 570
      : 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;
571
              9223372036854775807 -> 0## };
572 573 574 575 576 577 578
          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#
579
                                      (GHC.Prim.uncheckedShiftL# 1## wild3_Xh))
580 581 582 583
                                   ww_sCW
                     };
                  9223372036854775807 ->
                    GHC.Prim.narrow32Word#
584
!!!!-->                  (GHC.Prim.uncheckedShiftL# 1## 9223372036854775807)
585 586 587 588
                };
              GHC.Types.True ->
                case w_sCS of wild3_Xh {
                  __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX;
589
                  9223372036854775807 -> 0##
590 591
                } } } }

Austin Seipp's avatar
Austin Seipp committed
592
Note the massive shift on line "!!!!".  It can't happen, because we've checked
593 594 595 596 597 598 599 600
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
601 602
************************************************************************
*                                                                      *
603
\subsection{Vaguely generic functions}
Austin Seipp's avatar
Austin Seipp committed
604 605 606
*                                                                      *
************************************************************************
-}
607

608
mkBasicRule :: Name -> Int -> RuleM CoreExpr -> CoreRule
609
-- Gives the Rule the same name as the primop itself
610
mkBasicRule op_name n_args rm
611 612 613
  = BuiltinRule { ru_name = occNameFS (nameOccName op_name),
                  ru_fn = op_name,
                  ru_nargs = n_args,
614
                  ru_try = \ dflags in_scope _ -> runRuleM rm dflags in_scope }
615 616

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

Austin Seipp's avatar
Austin Seipp committed
619 620 621 622 623 624 625
instance Functor RuleM where
    fmap = liftM

instance Applicative RuleM where
    pure = return
    (<*>) = ap

626
instance Monad RuleM where
627 628
  return x = RuleM $ \_ _ _ -> Just x
  RuleM f >>= g = RuleM $ \dflags iu e -> case f dflags iu e of
629
    Nothing -> Nothing
630
    Just r -> runRuleM (g r) dflags iu e
631 632
  fail _ = mzero

Austin Seipp's avatar
Austin Seipp committed
633 634 635 636
instance Alternative RuleM where
    empty = mzero
    (<|>) = mplus

637
instance MonadPlus RuleM where
638 639 640 641 642 643
  mzero = RuleM $ \_ _ _ -> Nothing
  mplus (RuleM f1) (RuleM f2) = RuleM $ \dflags iu args ->
    f1 dflags iu args `mplus` f2 dflags iu args

instance HasDynFlags RuleM where
    getDynFlags = RuleM $ \dflags _ _ -> Just dflags
644 645 646 647 648 649

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

liftLit :: (Literal -> Literal) -> RuleM CoreExpr
650 651 652 653 654
liftLit f = liftLitDynFlags (const f)

liftLitDynFlags :: (DynFlags -> Literal -> Literal) -> RuleM CoreExpr
liftLitDynFlags f = do
  dflags <- getDynFlags
655
  [Lit lit] <- getArgs
656
  return $ Lit (f dflags lit)
657

pcapriotti's avatar
pcapriotti committed
658
removeOp32 :: RuleM CoreExpr
pcapriotti's avatar
pcapriotti committed
659
removeOp32 = do
660 661 662 663 664 665
  dflags <- getDynFlags
  if wordSizeInBits dflags == 32
  then do
    [e] <- getArgs
    return e
  else mzero
pcapriotti's avatar
pcapriotti committed
666

667
getArgs :: RuleM [CoreExpr]
668
getArgs = RuleM $ \_ _ args -> Just args
669

670 671
getInScopeEnv :: RuleM InScopeEnv
getInScopeEnv = RuleM $ \_ iu _ -> Just iu
672 673 674 675

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

680
unaryLit :: (DynFlags -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
681
unaryLit op = do
682
  dflags <- getDynFlags
683
  [Lit l] <- getArgs
684
  liftMaybe $ op dflags (convFloating dflags l)
685

686
binaryLit :: (DynFlags -> Literal -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
687
binaryLit op = do
688
  dflags <- getDynFlags
689
  [Lit l1, Lit l2] <- getArgs
690
  liftMaybe $ op dflags (convFloating dflags l1) (convFloating dflags l2)
691

692 693 694 695 696
binaryCmpLit :: (forall a . Ord a => a -> a -> Bool) -> RuleM CoreExpr
binaryCmpLit op = do
  dflags <- getDynFlags
  binaryLit (\_ -> cmpOp dflags op)

697
leftIdentity :: Literal -> RuleM CoreExpr
698 699 700 701 702 703 704 705 706 707 708
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
709
  [Lit l1, e2] <- getArgs
710
  guard $ l1 == id_lit dflags
711 712
  return e2

713 714 715
rightIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
rightIdentityDynFlags id_lit = do
  dflags <- getDynFlags
716
  [e1, Lit l2] <- getArgs
717
  guard $ l2 == id_lit dflags
718 719
  return e1

720 721
identityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
identityDynFlags lit = leftIdentityDynFlags lit `mplus` rightIdentityDynFlags lit
722

723
leftZero :: (DynFlags -> Literal) -> RuleM CoreExpr
724
leftZero zero = do
725
  dflags <- getDynFlags
726
  [Lit l1, _] <- getArgs
727 728
  guard $ l1 == zero dflags
  return $ Lit l1
729

730
rightZero :: (DynFlags -> Literal) -> RuleM CoreExpr
731
rightZero zero = do
732
  dflags <- getDynFlags
733
  [_, Lit l2] <- getArgs
734 735
  guard $ l2 == zero dflags
  return $ Lit l2
736

737
zeroElem :: (DynFlags -> Literal) -> RuleM CoreExpr
738 739 740 741 742 743 744 745 746
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
747

748 749 750
-- 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 :-).
751
convFloating :: DynFlags -> Literal -> Literal
ian@well-typed.com's avatar
ian@well-typed.com committed
752
convFloating dflags (MachFloat  f) | not (gopt Opt_ExcessPrecision dflags) =
753
   MachFloat  (toRational (fromRational f :: Float ))
ian@well-typed.com's avatar
ian@well-typed.com committed
754
convFloating dflags (MachDouble d) | not (gopt Opt_ExcessPrecision dflags) =
755
   MachDouble (toRational (fromRational d :: Double))
756
convFloating _ l = l
757

758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773
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?

774 775 776 777 778 779 780 781 782 783
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
784 785 786 787 788 789
-- 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
790

791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807
-- 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
808 809 810 811 812 813

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

814 815 816 817
mkIntVal :: DynFlags -> Integer -> Expr CoreBndr
mkIntVal dflags i = Lit (mkMachInt dflags i)
mkWordVal :: DynFlags -> Integer -> Expr CoreBndr
mkWordVal dflags w = Lit (mkMachWord dflags w)
818 819 820 821
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))
822

pcapriotti's avatar
pcapriotti committed
823 824 825 826 827
matchPrimOpId :: PrimOp -> Id -> RuleM ()
matchPrimOpId op id = do
  op' <- liftMaybe $ isPrimOpId_maybe id
  guard $ op == op'

Austin Seipp's avatar
Austin Seipp committed
828 829 830
{-
************************************************************************
*                                                                      *
831
\subsection{Special rules for seq, tagToEnum, dataToTag}
Austin Seipp's avatar
Austin Seipp committed
832 833
*                                                                      *
************************************************************************
834

835 836 837 838 839 840 841
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
842 843
        f :: forall a. a
        f = tagToEnum# 0        -- Can't do tagToEnum# at a type variable
844

845 846
        g :: Int
        g = tagToEnum# 0        -- Int is not an enumeration
847 848 849 850 851 852 853 854

We used to make this check in the type inference engine, but it's quite
ugly to do so, because the delayed constraint solving means that we don't
really know what's going on until the end. It's very much a corner case
because we don't expect the user to call tagToEnum# at all; we merely
generate calls in derived instances of Enum.  So we compromise: a
rewrite rule rewrites a bad instance of tagToEnum# to an error call,
and emits a warning.
Austin Seipp's avatar
Austin Seipp committed
855
-}
856

857
tagToEnumRule :: RuleM CoreExpr
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
858 859
-- If     data T a = A | B | C
-- then   tag2Enum# (T ty) 2# -->  B ty
860 861 862 863 864 865 866
tagToEnumRule = do
  [Type ty, Lit (MachInt i)] <- getArgs
  case splitTyConApp_maybe ty of
    Just (tycon, tc_args) | isEnumerationTyCon tycon -> do
      let tag = fromInteger i
          correct_tag dc = (dataConTag dc - fIRST_TAG) == tag
      (dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` [])
867
      ASSERT(null rest) return ()
868 869 870 871 872
      return $ mkTyApps (Var (dataConWorkId dc)) tc_args

    -- See Note [tagToEnum#]
    _ -> WARN( True, ptext (sLit "tagToEnum# on non-enumeration type") <+> ppr ty )
         return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type"
873

Austin Seipp's avatar
Austin Seipp committed
874
{-
875 876 877 878
For dataToTag#, we can reduce if either

        (a) the argument is a constructor
        (b) the argument is a variable whose unfolding is a known constructor
Austin Seipp's avatar
Austin Seipp committed
879
-}
880

881 882 883 884 885 886 887 888 889
dataToTagRule :: RuleM CoreExpr
dataToTagRule = a `mplus` b
  where
    a = do
      [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] <- getArgs
      guard $ tag_to_enum `hasKey` tagToEnumKey
      guard $ ty1 `eqType` ty2
      return tag -- dataToTag (tagToEnum x)   ==>   x
    b = do
890
      dflags <- getDynFlags
891
      [_, val_arg] <- getArgs
892 893 <