never executed always true always false
1 {-
2 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3
4 Conceptually, constant folding should be parameterized with the kind
5 of target machine to get identical behaviour during compilation time
6 and runtime. We cheat a little bit here...
7
8 ToDo:
9 check boundaries before folding, e.g. we can fold the Float addition
10 (i1 + i2) only if it results in a valid Float.
11 -}
12
13 {-# LANGUAGE AllowAmbiguousTypes #-}
14 {-# LANGUAGE DeriveFunctor #-}
15 {-# LANGUAGE LambdaCase #-}
16 {-# LANGUAGE MultiWayIf #-}
17 {-# LANGUAGE PatternSynonyms #-}
18 {-# LANGUAGE RankNTypes #-}
19 {-# LANGUAGE ScopedTypeVariables #-}
20 {-# LANGUAGE TypeApplications #-}
21 {-# LANGUAGE ViewPatterns #-}
22
23 {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE -Wno-incomplete-uni-patterns #-}
24
25 -- | Constant Folder
26 module GHC.Core.Opt.ConstantFold
27 ( primOpRules
28 , builtinRules
29 , caseRules
30 )
31 where
32
33 import GHC.Prelude
34
35 import GHC.Platform
36
37 import {-# SOURCE #-} GHC.Types.Id.Make ( mkPrimOpId, voidPrimId )
38 import GHC.Types.Id
39 import GHC.Types.Literal
40 import GHC.Types.Var.Set
41 import GHC.Types.Var.Env
42 import GHC.Types.Name.Occurrence ( occNameFS )
43 import GHC.Types.Tickish
44 import GHC.Types.Name ( Name, nameOccName )
45 import GHC.Types.Basic
46
47 import GHC.Core
48 import GHC.Core.Make
49 import GHC.Core.SimpleOpt ( exprIsConApp_maybe, exprIsLiteral_maybe )
50 import GHC.Core.DataCon ( DataCon,dataConTagZ, dataConTyCon, dataConWrapId, dataConWorkId )
51 import GHC.Core.Utils ( eqExpr, cheapEqExpr, exprIsHNF, exprType
52 , stripTicksTop, stripTicksTopT, mkTicks )
53 import GHC.Core.Multiplicity
54 import GHC.Core.FVs
55 import GHC.Core.Type
56 import GHC.Core.TyCon
57 ( tyConDataCons_maybe, isAlgTyCon, isEnumerationTyCon
58 , isNewTyCon, tyConDataCons
59 , tyConFamilySize )
60
61 import GHC.Builtin.PrimOps ( PrimOp(..), tagToEnumKey )
62 import GHC.Builtin.Types
63 import GHC.Builtin.Types.Prim
64 import GHC.Builtin.Names
65
66 import GHC.Data.FastString
67 import GHC.Data.Maybe ( orElse )
68
69 import GHC.Utils.Outputable
70 import GHC.Utils.Misc
71 import GHC.Utils.Panic
72 import GHC.Utils.Panic.Plain
73 import GHC.Utils.Trace
74
75 import Control.Applicative ( Alternative(..) )
76 import Control.Monad
77 import Data.Functor (($>))
78 import qualified Data.ByteString as BS
79 import Data.Ratio
80 import Data.Word
81 import Data.Maybe (fromMaybe, fromJust)
82
83 {-
84 Note [Constant folding]
85 ~~~~~~~~~~~~~~~~~~~~~~~
86 primOpRules generates a rewrite rule for each primop
87 These rules do what is often called "constant folding"
88 E.g. the rules for +# might say
89 4 +# 5 = 9
90 Well, of course you'd need a lot of rules if you did it
91 like that, so we use a BuiltinRule instead, so that we
92 can match in any two literal values. So the rule is really
93 more like
94 (Lit x) +# (Lit y) = Lit (x+#y)
95 where the (+#) on the rhs is done at compile time
96
97 That is why these rules are built in here.
98 -}
99
100 primOpRules :: Name -> PrimOp -> Maybe CoreRule
101 primOpRules nm = \case
102 TagToEnumOp -> mkPrimOpRule nm 2 [ tagToEnumRule ]
103 DataToTagOp -> mkPrimOpRule nm 2 [ dataToTagRule ]
104
105 -- Int8 operations
106 Int8AddOp -> mkPrimOpRule nm 2 [ binaryLit (int8Op2 (+))
107 , identity zeroI8
108 , addFoldingRules Int8AddOp int8Ops
109 ]
110 Int8SubOp -> mkPrimOpRule nm 2 [ binaryLit (int8Op2 (-))
111 , rightIdentity zeroI8
112 , equalArgs $> Lit zeroI8
113 , subFoldingRules Int8SubOp int8Ops
114 ]
115 Int8MulOp -> mkPrimOpRule nm 2 [ binaryLit (int8Op2 (*))
116 , zeroElem
117 , identity oneI8
118 , mulFoldingRules Int8MulOp int8Ops
119 ]
120 Int8QuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int8Op2 quot)
121 , leftZero
122 , rightIdentity oneI8
123 , equalArgs $> Lit oneI8 ]
124 Int8RemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int8Op2 rem)
125 , leftZero
126 , oneLit 1 $> Lit zeroI8
127 , equalArgs $> Lit zeroI8 ]
128 Int8NegOp -> mkPrimOpRule nm 1 [ unaryLit negOp
129 , semiInversePrimOp Int8NegOp ]
130 Int8SllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumInt8 (const shiftL)
131 , rightIdentity zeroI8 ]
132 Int8SraOp -> mkPrimOpRule nm 2 [ shiftRule LitNumInt8 (const shiftR)
133 , rightIdentity zeroI8 ]
134 Int8SrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumInt8 $ const $ shiftRightLogical @Word8
135 , rightIdentity zeroI8 ]
136
137 -- Word8 operations
138 Word8AddOp -> mkPrimOpRule nm 2 [ binaryLit (word8Op2 (+))
139 , identity zeroW8
140 , addFoldingRules Word8AddOp word8Ops
141 ]
142 Word8SubOp -> mkPrimOpRule nm 2 [ binaryLit (word8Op2 (-))
143 , rightIdentity zeroW8
144 , equalArgs $> Lit zeroW8
145 , subFoldingRules Word8SubOp word8Ops
146 ]
147 Word8MulOp -> mkPrimOpRule nm 2 [ binaryLit (word8Op2 (*))
148 , identity oneW8
149 , mulFoldingRules Word8MulOp word8Ops
150 ]
151 Word8QuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word8Op2 quot)
152 , rightIdentity oneW8 ]
153 Word8RemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word8Op2 rem)
154 , leftZero
155 , oneLit 1 $> Lit zeroW8
156 , equalArgs $> Lit zeroW8 ]
157 Word8AndOp -> mkPrimOpRule nm 2 [ binaryLit (word8Op2 (.&.))
158 , idempotent
159 , zeroElem
160 , identity (mkLitWord8 0xFF)
161 , sameArgIdempotentCommut Word8AndOp
162 , andFoldingRules word8Ops
163 ]
164 Word8OrOp -> mkPrimOpRule nm 2 [ binaryLit (word8Op2 (.|.))
165 , idempotent
166 , identity zeroW8
167 , sameArgIdempotentCommut Word8OrOp
168 , orFoldingRules word8Ops
169 ]
170 Word8XorOp -> mkPrimOpRule nm 2 [ binaryLit (word8Op2 xor)
171 , identity zeroW8
172 , equalArgs $> Lit zeroW8 ]
173 Word8NotOp -> mkPrimOpRule nm 1 [ unaryLit complementOp
174 , semiInversePrimOp Word8NotOp ]
175 Word8SllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord8 (const shiftL) ]
176 Word8SrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord8 $ const $ shiftRightLogical @Word8 ]
177
178
179 -- Int16 operations
180 Int16AddOp -> mkPrimOpRule nm 2 [ binaryLit (int16Op2 (+))
181 , identity zeroI16
182 , addFoldingRules Int16AddOp int16Ops
183 ]
184 Int16SubOp -> mkPrimOpRule nm 2 [ binaryLit (int16Op2 (-))
185 , rightIdentity zeroI16
186 , equalArgs $> Lit zeroI16
187 , subFoldingRules Int16SubOp int16Ops
188 ]
189 Int16MulOp -> mkPrimOpRule nm 2 [ binaryLit (int16Op2 (*))
190 , zeroElem
191 , identity oneI16
192 , mulFoldingRules Int16MulOp int16Ops
193 ]
194 Int16QuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int16Op2 quot)
195 , leftZero
196 , rightIdentity oneI16
197 , equalArgs $> Lit oneI16 ]
198 Int16RemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int16Op2 rem)
199 , leftZero
200 , oneLit 1 $> Lit zeroI16
201 , equalArgs $> Lit zeroI16 ]
202 Int16NegOp -> mkPrimOpRule nm 1 [ unaryLit negOp
203 , semiInversePrimOp Int16NegOp ]
204 Int16SllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumInt16 (const shiftL)
205 , rightIdentity zeroI16 ]
206 Int16SraOp -> mkPrimOpRule nm 2 [ shiftRule LitNumInt16 (const shiftR)
207 , rightIdentity zeroI16 ]
208 Int16SrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumInt16 $ const $ shiftRightLogical @Word16
209 , rightIdentity zeroI16 ]
210
211 -- Word16 operations
212 Word16AddOp -> mkPrimOpRule nm 2 [ binaryLit (word16Op2 (+))
213 , identity zeroW16
214 , addFoldingRules Word16AddOp word16Ops
215 ]
216 Word16SubOp -> mkPrimOpRule nm 2 [ binaryLit (word16Op2 (-))
217 , rightIdentity zeroW16
218 , equalArgs $> Lit zeroW16
219 , subFoldingRules Word16SubOp word16Ops
220 ]
221 Word16MulOp -> mkPrimOpRule nm 2 [ binaryLit (word16Op2 (*))
222 , identity oneW16
223 , mulFoldingRules Word16MulOp word16Ops
224 ]
225 Word16QuotOp-> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word16Op2 quot)
226 , rightIdentity oneW16 ]
227 Word16RemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word16Op2 rem)
228 , leftZero
229 , oneLit 1 $> Lit zeroW16
230 , equalArgs $> Lit zeroW16 ]
231 Word16AndOp -> mkPrimOpRule nm 2 [ binaryLit (word16Op2 (.&.))
232 , idempotent
233 , zeroElem
234 , identity (mkLitWord16 0xFFFF)
235 , sameArgIdempotentCommut Word16AndOp
236 , andFoldingRules word16Ops
237 ]
238 Word16OrOp -> mkPrimOpRule nm 2 [ binaryLit (word16Op2 (.|.))
239 , idempotent
240 , identity zeroW16
241 , sameArgIdempotentCommut Word16OrOp
242 , orFoldingRules word16Ops
243 ]
244 Word16XorOp -> mkPrimOpRule nm 2 [ binaryLit (word16Op2 xor)
245 , identity zeroW16
246 , equalArgs $> Lit zeroW16 ]
247 Word16NotOp -> mkPrimOpRule nm 1 [ unaryLit complementOp
248 , semiInversePrimOp Word16NotOp ]
249 Word16SllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord16 (const shiftL) ]
250 Word16SrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord16 $ const $ shiftRightLogical @Word16 ]
251
252
253 -- Int32 operations
254 Int32AddOp -> mkPrimOpRule nm 2 [ binaryLit (int32Op2 (+))
255 , identity zeroI32
256 , addFoldingRules Int32AddOp int32Ops
257 ]
258 Int32SubOp -> mkPrimOpRule nm 2 [ binaryLit (int32Op2 (-))
259 , rightIdentity zeroI32
260 , equalArgs $> Lit zeroI32
261 , subFoldingRules Int32SubOp int32Ops
262 ]
263 Int32MulOp -> mkPrimOpRule nm 2 [ binaryLit (int32Op2 (*))
264 , zeroElem
265 , identity oneI32
266 , mulFoldingRules Int32MulOp int32Ops
267 ]
268 Int32QuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int32Op2 quot)
269 , leftZero
270 , rightIdentity oneI32
271 , equalArgs $> Lit oneI32 ]
272 Int32RemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int32Op2 rem)
273 , leftZero
274 , oneLit 1 $> Lit zeroI32
275 , equalArgs $> Lit zeroI32 ]
276 Int32NegOp -> mkPrimOpRule nm 1 [ unaryLit negOp
277 , semiInversePrimOp Int32NegOp ]
278 Int32SllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumInt32 (const shiftL)
279 , rightIdentity zeroI32 ]
280 Int32SraOp -> mkPrimOpRule nm 2 [ shiftRule LitNumInt32 (const shiftR)
281 , rightIdentity zeroI32 ]
282 Int32SrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumInt32 $ const $ shiftRightLogical @Word32
283 , rightIdentity zeroI32 ]
284
285 -- Word32 operations
286 Word32AddOp -> mkPrimOpRule nm 2 [ binaryLit (word32Op2 (+))
287 , identity zeroW32
288 , addFoldingRules Word32AddOp word32Ops
289 ]
290 Word32SubOp -> mkPrimOpRule nm 2 [ binaryLit (word32Op2 (-))
291 , rightIdentity zeroW32
292 , equalArgs $> Lit zeroW32
293 , subFoldingRules Word32SubOp word32Ops
294 ]
295 Word32MulOp -> mkPrimOpRule nm 2 [ binaryLit (word32Op2 (*))
296 , identity oneW32
297 , mulFoldingRules Word32MulOp word32Ops
298 ]
299 Word32QuotOp-> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word32Op2 quot)
300 , rightIdentity oneW32 ]
301 Word32RemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word32Op2 rem)
302 , leftZero
303 , oneLit 1 $> Lit zeroW32
304 , equalArgs $> Lit zeroW32 ]
305 Word32AndOp -> mkPrimOpRule nm 2 [ binaryLit (word32Op2 (.&.))
306 , idempotent
307 , zeroElem
308 , identity (mkLitWord32 0xFFFFFFFF)
309 , sameArgIdempotentCommut Word32AndOp
310 , andFoldingRules word32Ops
311 ]
312 Word32OrOp -> mkPrimOpRule nm 2 [ binaryLit (word32Op2 (.|.))
313 , idempotent
314 , identity zeroW32
315 , sameArgIdempotentCommut Word32OrOp
316 , orFoldingRules word32Ops
317 ]
318 Word32XorOp -> mkPrimOpRule nm 2 [ binaryLit (word32Op2 xor)
319 , identity zeroW32
320 , equalArgs $> Lit zeroW32 ]
321 Word32NotOp -> mkPrimOpRule nm 1 [ unaryLit complementOp
322 , semiInversePrimOp Word32NotOp ]
323 Word32SllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord32 (const shiftL) ]
324 Word32SrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord32 $ const $ shiftRightLogical @Word32 ]
325
326 -- Int64 operations
327 Int64AddOp -> mkPrimOpRule nm 2 [ binaryLit (int64Op2 (+))
328 , identity zeroI64
329 , addFoldingRules Int64AddOp int64Ops
330 ]
331 Int64SubOp -> mkPrimOpRule nm 2 [ binaryLit (int64Op2 (-))
332 , rightIdentity zeroI64
333 , equalArgs $> Lit zeroI64
334 , subFoldingRules Int64SubOp int64Ops
335 ]
336 Int64MulOp -> mkPrimOpRule nm 2 [ binaryLit (int64Op2 (*))
337 , zeroElem
338 , identity oneI64
339 , mulFoldingRules Int64MulOp int64Ops
340 ]
341 Int64QuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int64Op2 quot)
342 , leftZero
343 , rightIdentity oneI64
344 , equalArgs $> Lit oneI64 ]
345 Int64RemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int64Op2 rem)
346 , leftZero
347 , oneLit 1 $> Lit zeroI64
348 , equalArgs $> Lit zeroI64 ]
349 Int64NegOp -> mkPrimOpRule nm 1 [ unaryLit negOp
350 , semiInversePrimOp Int64NegOp ]
351 Int64SllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumInt64 (const shiftL)
352 , rightIdentity zeroI64 ]
353 Int64SraOp -> mkPrimOpRule nm 2 [ shiftRule LitNumInt64 (const shiftR)
354 , rightIdentity zeroI64 ]
355 Int64SrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumInt64 $ const $ shiftRightLogical @Word64
356 , rightIdentity zeroI64 ]
357
358 -- Word64 operations
359 Word64AddOp -> mkPrimOpRule nm 2 [ binaryLit (word64Op2 (+))
360 , identity zeroW64
361 , addFoldingRules Word64AddOp word64Ops
362 ]
363 Word64SubOp -> mkPrimOpRule nm 2 [ binaryLit (word64Op2 (-))
364 , rightIdentity zeroW64
365 , equalArgs $> Lit zeroW64
366 , subFoldingRules Word64SubOp word64Ops
367 ]
368 Word64MulOp -> mkPrimOpRule nm 2 [ binaryLit (word64Op2 (*))
369 , identity oneW64
370 , mulFoldingRules Word64MulOp word64Ops
371 ]
372 Word64QuotOp-> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word64Op2 quot)
373 , rightIdentity oneW64 ]
374 Word64RemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word64Op2 rem)
375 , leftZero
376 , oneLit 1 $> Lit zeroW64
377 , equalArgs $> Lit zeroW64 ]
378 Word64AndOp -> mkPrimOpRule nm 2 [ binaryLit (word64Op2 (.&.))
379 , idempotent
380 , zeroElem
381 , identity (mkLitWord64 0xFFFFFFFFFFFFFFFF)
382 , sameArgIdempotentCommut Word64AndOp
383 , andFoldingRules word64Ops
384 ]
385 Word64OrOp -> mkPrimOpRule nm 2 [ binaryLit (word64Op2 (.|.))
386 , idempotent
387 , identity zeroW64
388 , sameArgIdempotentCommut Word64OrOp
389 , orFoldingRules word64Ops
390 ]
391 Word64XorOp -> mkPrimOpRule nm 2 [ binaryLit (word64Op2 xor)
392 , identity zeroW64
393 , equalArgs $> Lit zeroW64 ]
394 Word64NotOp -> mkPrimOpRule nm 1 [ unaryLit complementOp
395 , semiInversePrimOp Word64NotOp ]
396 Word64SllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord64 (const shiftL) ]
397 Word64SrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord64 $ const $ shiftRightLogical @Word64 ]
398
399 -- Int operations
400 IntAddOp -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (+))
401 , identityPlatform zeroi
402 , addFoldingRules IntAddOp intOps
403 ]
404 IntSubOp -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (-))
405 , rightIdentityPlatform zeroi
406 , equalArgs >> retLit zeroi
407 , subFoldingRules IntSubOp intOps
408 ]
409 IntAddCOp -> mkPrimOpRule nm 2 [ binaryLit (intOpC2 (+))
410 , identityCPlatform zeroi ]
411 IntSubCOp -> mkPrimOpRule nm 2 [ binaryLit (intOpC2 (-))
412 , rightIdentityCPlatform zeroi
413 , equalArgs >> retLitNoC zeroi ]
414 IntMulOp -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (*))
415 , zeroElem
416 , identityPlatform onei
417 , mulFoldingRules IntMulOp intOps
418 ]
419 IntMul2Op -> mkPrimOpRule nm 2 [ do
420 [Lit (LitNumber _ l1), Lit (LitNumber _ l2)] <- getArgs
421 platform <- getPlatform
422 let r = l1 * l2
423 pure $ mkCoreUbxTup [intPrimTy,intPrimTy,intPrimTy]
424 [ Lit (if platformInIntRange platform r then zeroi platform else onei platform)
425 , mkIntLitWrap platform (r `shiftR` platformWordSizeInBits platform)
426 , mkIntLitWrap platform r
427 ]
428
429 , zeroElem >>= \z ->
430 pure (mkCoreUbxTup [intPrimTy,intPrimTy,intPrimTy]
431 [z,z,z])
432
433 -- timesInt2# 1# other
434 -- ~~~>
435 -- (# 0#, 0# -# (other >># (WORD_SIZE_IN_BITS-1)), other #)
436 -- The second element is the sign bit
437 -- repeated to fill a word.
438 , identityPlatform onei >>= \other -> do
439 platform <- getPlatform
440 pure $ mkCoreUbxTup [intPrimTy,intPrimTy,intPrimTy]
441 [ Lit (zeroi platform)
442 , mkCoreApps (Var (mkPrimOpId IntSubOp))
443 [ Lit (zeroi platform)
444 , mkCoreApps (Var (mkPrimOpId IntSrlOp))
445 [ other
446 , mkIntLit platform (fromIntegral (platformWordSizeInBits platform - 1))
447 ]
448 ]
449 , other
450 ]
451 ]
452 IntQuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 quot)
453 , leftZero
454 , rightIdentityPlatform onei
455 , equalArgs >> retLit onei ]
456 IntRemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 rem)
457 , leftZero
458 , oneLit 1 >> retLit zeroi
459 , equalArgs >> retLit zeroi ]
460 IntAndOp -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (.&.))
461 , idempotent
462 , zeroElem
463 , identityPlatform (\p -> mkLitInt p (-1))
464 , sameArgIdempotentCommut IntAndOp
465 , andFoldingRules intOps
466 ]
467 IntOrOp -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (.|.))
468 , idempotent
469 , identityPlatform zeroi
470 , sameArgIdempotentCommut IntOrOp
471 , orFoldingRules intOps
472 ]
473 IntXorOp -> mkPrimOpRule nm 2 [ binaryLit (intOp2 xor)
474 , identityPlatform zeroi
475 , equalArgs >> retLit zeroi ]
476 IntNotOp -> mkPrimOpRule nm 1 [ unaryLit complementOp
477 , semiInversePrimOp IntNotOp ]
478 IntNegOp -> mkPrimOpRule nm 1 [ unaryLit negOp
479 , semiInversePrimOp IntNegOp ]
480 IntSllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumInt (const shiftL)
481 , rightIdentityPlatform zeroi ]
482 IntSraOp -> mkPrimOpRule nm 2 [ shiftRule LitNumInt (const shiftR)
483 , rightIdentityPlatform zeroi ]
484 IntSrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumInt shiftRightLogicalNative
485 , rightIdentityPlatform zeroi ]
486
487 -- Word operations
488 WordAddOp -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (+))
489 , identityPlatform zerow
490 , addFoldingRules WordAddOp wordOps
491 ]
492 WordSubOp -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (-))
493 , rightIdentityPlatform zerow
494 , equalArgs >> retLit zerow
495 , subFoldingRules WordSubOp wordOps
496 ]
497 WordAddCOp -> mkPrimOpRule nm 2 [ binaryLit (wordOpC2 (+))
498 , identityCPlatform zerow ]
499 WordSubCOp -> mkPrimOpRule nm 2 [ binaryLit (wordOpC2 (-))
500 , rightIdentityCPlatform zerow
501 , equalArgs >> retLitNoC zerow ]
502 WordMulOp -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (*))
503 , identityPlatform onew
504 , mulFoldingRules WordMulOp wordOps
505 ]
506 WordQuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 quot)
507 , rightIdentityPlatform onew ]
508 WordRemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 rem)
509 , leftZero
510 , oneLit 1 >> retLit zerow
511 , equalArgs >> retLit zerow ]
512 WordAndOp -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.&.))
513 , idempotent
514 , zeroElem
515 , identityPlatform (\p -> mkLitWord p (platformMaxWord p))
516 , sameArgIdempotentCommut WordAndOp
517 , andFoldingRules wordOps
518 ]
519 WordOrOp -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.|.))
520 , idempotent
521 , identityPlatform zerow
522 , sameArgIdempotentCommut WordOrOp
523 , orFoldingRules wordOps
524 ]
525 WordXorOp -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 xor)
526 , identityPlatform zerow
527 , equalArgs >> retLit zerow ]
528 WordNotOp -> mkPrimOpRule nm 1 [ unaryLit complementOp
529 , semiInversePrimOp WordNotOp ]
530 WordSllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord (const shiftL) ]
531 WordSrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord shiftRightLogicalNative ]
532
533 PopCnt8Op -> mkPrimOpRule nm 1 [ pop_count @Word8 ]
534 PopCnt16Op -> mkPrimOpRule nm 1 [ pop_count @Word16 ]
535 PopCnt32Op -> mkPrimOpRule nm 1 [ pop_count @Word32 ]
536 PopCnt64Op -> mkPrimOpRule nm 1 [ pop_count @Word64 ]
537 PopCntOp -> mkPrimOpRule nm 1 [ getWordSize >>= \case
538 PW4 -> pop_count @Word32
539 PW8 -> pop_count @Word64
540 ]
541
542 Ctz8Op -> mkPrimOpRule nm 1 [ ctz @Word8 ]
543 Ctz16Op -> mkPrimOpRule nm 1 [ ctz @Word16 ]
544 Ctz32Op -> mkPrimOpRule nm 1 [ ctz @Word32 ]
545 Ctz64Op -> mkPrimOpRule nm 1 [ ctz @Word64 ]
546 CtzOp -> mkPrimOpRule nm 1 [ getWordSize >>= \case
547 PW4 -> ctz @Word32
548 PW8 -> ctz @Word64
549 ]
550
551 Clz8Op -> mkPrimOpRule nm 1 [ clz @Word8 ]
552 Clz16Op -> mkPrimOpRule nm 1 [ clz @Word16 ]
553 Clz32Op -> mkPrimOpRule nm 1 [ clz @Word32 ]
554 Clz64Op -> mkPrimOpRule nm 1 [ clz @Word64 ]
555 ClzOp -> mkPrimOpRule nm 1 [ getWordSize >>= \case
556 PW4 -> clz @Word32
557 PW8 -> clz @Word64
558 ]
559
560 -- coercions
561
562 Int8ToIntOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendIntLit ]
563 Int16ToIntOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendIntLit ]
564 Int32ToIntOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendIntLit ]
565 Int64ToIntOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendIntLit ]
566 IntToInt8Op -> mkPrimOpRule nm 1 [ liftLit narrowInt8Lit
567 , narrowSubsumesAnd IntAndOp IntToInt8Op 8 ]
568 IntToInt16Op -> mkPrimOpRule nm 1 [ liftLit narrowInt16Lit
569 , narrowSubsumesAnd IntAndOp IntToInt16Op 16 ]
570 IntToInt32Op -> mkPrimOpRule nm 1 [ liftLit narrowInt32Lit
571 , narrowSubsumesAnd IntAndOp IntToInt32Op 32 ]
572 IntToInt64Op -> mkPrimOpRule nm 1 [ liftLit narrowInt64Lit ]
573
574 Word8ToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendWordLit
575 , extendNarrowPassthrough WordToWord8Op 0xFF
576 ]
577 Word16ToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendWordLit
578 , extendNarrowPassthrough WordToWord16Op 0xFFFF
579 ]
580 Word32ToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendWordLit
581 , extendNarrowPassthrough WordToWord32Op 0xFFFFFFFF
582 ]
583 Word64ToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendWordLit ]
584
585 WordToWord8Op -> mkPrimOpRule nm 1 [ liftLit narrowWord8Lit
586 , narrowSubsumesAnd WordAndOp WordToWord8Op 8 ]
587 WordToWord16Op -> mkPrimOpRule nm 1 [ liftLit narrowWord16Lit
588 , narrowSubsumesAnd WordAndOp WordToWord16Op 16 ]
589 WordToWord32Op -> mkPrimOpRule nm 1 [ liftLit narrowWord32Lit
590 , narrowSubsumesAnd WordAndOp WordToWord32Op 32 ]
591 WordToWord64Op -> mkPrimOpRule nm 1 [ liftLit narrowWord64Lit ]
592
593 Word8ToInt8Op -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt8) ]
594 Int8ToWord8Op -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord8) ]
595 Word16ToInt16Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt16) ]
596 Int16ToWord16Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord16) ]
597 Word32ToInt32Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt32) ]
598 Int32ToWord32Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord32) ]
599 Word64ToInt64Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt64) ]
600 Int64ToWord64Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord64) ]
601
602 WordToIntOp -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt) ]
603 IntToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord) ]
604
605 Narrow8IntOp -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumNarrow LitNumInt8)
606 , subsumedByPrimOp Narrow8IntOp
607 , Narrow8IntOp `subsumesPrimOp` Narrow16IntOp
608 , Narrow8IntOp `subsumesPrimOp` Narrow32IntOp
609 , narrowSubsumesAnd IntAndOp Narrow8IntOp 8 ]
610 Narrow16IntOp -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumNarrow LitNumInt16)
611 , subsumedByPrimOp Narrow8IntOp
612 , subsumedByPrimOp Narrow16IntOp
613 , Narrow16IntOp `subsumesPrimOp` Narrow32IntOp
614 , narrowSubsumesAnd IntAndOp Narrow16IntOp 16 ]
615 Narrow32IntOp -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumNarrow LitNumInt32)
616 , subsumedByPrimOp Narrow8IntOp
617 , subsumedByPrimOp Narrow16IntOp
618 , subsumedByPrimOp Narrow32IntOp
619 , removeOp32
620 , narrowSubsumesAnd IntAndOp Narrow32IntOp 32 ]
621 Narrow8WordOp -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumNarrow LitNumWord8)
622 , subsumedByPrimOp Narrow8WordOp
623 , Narrow8WordOp `subsumesPrimOp` Narrow16WordOp
624 , Narrow8WordOp `subsumesPrimOp` Narrow32WordOp
625 , narrowSubsumesAnd WordAndOp Narrow8WordOp 8 ]
626 Narrow16WordOp -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumNarrow LitNumWord16)
627 , subsumedByPrimOp Narrow8WordOp
628 , subsumedByPrimOp Narrow16WordOp
629 , Narrow16WordOp `subsumesPrimOp` Narrow32WordOp
630 , narrowSubsumesAnd WordAndOp Narrow16WordOp 16 ]
631 Narrow32WordOp -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumNarrow LitNumWord32)
632 , subsumedByPrimOp Narrow8WordOp
633 , subsumedByPrimOp Narrow16WordOp
634 , subsumedByPrimOp Narrow32WordOp
635 , removeOp32
636 , narrowSubsumesAnd WordAndOp Narrow32WordOp 32 ]
637
638 OrdOp -> mkPrimOpRule nm 1 [ liftLit charToIntLit
639 , semiInversePrimOp ChrOp ]
640 ChrOp -> mkPrimOpRule nm 1 [ do [Lit lit] <- getArgs
641 guard (litFitsInChar lit)
642 liftLit intToCharLit
643 , semiInversePrimOp OrdOp ]
644 FloatToIntOp -> mkPrimOpRule nm 1 [ liftLit floatToIntLit ]
645 IntToFloatOp -> mkPrimOpRule nm 1 [ liftLit intToFloatLit ]
646 DoubleToIntOp -> mkPrimOpRule nm 1 [ liftLit doubleToIntLit ]
647 IntToDoubleOp -> mkPrimOpRule nm 1 [ liftLit intToDoubleLit ]
648 -- SUP: Not sure what the standard says about precision in the following 2 cases
649 FloatToDoubleOp -> mkPrimOpRule nm 1 [ liftLit floatToDoubleLit ]
650 DoubleToFloatOp -> mkPrimOpRule nm 1 [ liftLit doubleToFloatLit ]
651
652 -- Float
653 FloatAddOp -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (+))
654 , identity zerof ]
655 FloatSubOp -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (-))
656 , rightIdentity zerof ]
657 FloatMulOp -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (*))
658 , identity onef
659 , strengthReduction twof FloatAddOp ]
660 -- zeroElem zerof doesn't hold because of NaN
661 FloatDivOp -> mkPrimOpRule nm 2 [ guardFloatDiv >> binaryLit (floatOp2 (/))
662 , rightIdentity onef ]
663 FloatNegOp -> mkPrimOpRule nm 1 [ unaryLit negOp
664 , semiInversePrimOp FloatNegOp ]
665 FloatDecode_IntOp -> mkPrimOpRule nm 1 [ unaryLit floatDecodeOp ]
666
667 -- Double
668 DoubleAddOp -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (+))
669 , identity zerod ]
670 DoubleSubOp -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (-))
671 , rightIdentity zerod ]
672 DoubleMulOp -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (*))
673 , identity oned
674 , strengthReduction twod DoubleAddOp ]
675 -- zeroElem zerod doesn't hold because of NaN
676 DoubleDivOp -> mkPrimOpRule nm 2 [ guardDoubleDiv >> binaryLit (doubleOp2 (/))
677 , rightIdentity oned ]
678 DoubleNegOp -> mkPrimOpRule nm 1 [ unaryLit negOp
679 , semiInversePrimOp DoubleNegOp ]
680 DoubleDecode_Int64Op -> mkPrimOpRule nm 1 [ unaryLit doubleDecodeOp ]
681
682 -- Relational operators, equality
683
684 Int8EqOp -> mkRelOpRule nm (==) [ litEq True ]
685 Int8NeOp -> mkRelOpRule nm (/=) [ litEq False ]
686
687 Int16EqOp -> mkRelOpRule nm (==) [ litEq True ]
688 Int16NeOp -> mkRelOpRule nm (/=) [ litEq False ]
689
690 Int32EqOp -> mkRelOpRule nm (==) [ litEq True ]
691 Int32NeOp -> mkRelOpRule nm (/=) [ litEq False ]
692
693 IntEqOp -> mkRelOpRule nm (==) [ litEq True ]
694 IntNeOp -> mkRelOpRule nm (/=) [ litEq False ]
695
696 Word8EqOp -> mkRelOpRule nm (==) [ litEq True ]
697 Word8NeOp -> mkRelOpRule nm (/=) [ litEq False ]
698
699 Word16EqOp -> mkRelOpRule nm (==) [ litEq True ]
700 Word16NeOp -> mkRelOpRule nm (/=) [ litEq False ]
701
702 Word32EqOp -> mkRelOpRule nm (==) [ litEq True ]
703 Word32NeOp -> mkRelOpRule nm (/=) [ litEq False ]
704
705 WordEqOp -> mkRelOpRule nm (==) [ litEq True ]
706 WordNeOp -> mkRelOpRule nm (/=) [ litEq False ]
707
708 CharEqOp -> mkRelOpRule nm (==) [ litEq True ]
709 CharNeOp -> mkRelOpRule nm (/=) [ litEq False ]
710
711 FloatEqOp -> mkFloatingRelOpRule nm (==)
712 FloatNeOp -> mkFloatingRelOpRule nm (/=)
713
714 DoubleEqOp -> mkFloatingRelOpRule nm (==)
715 DoubleNeOp -> mkFloatingRelOpRule nm (/=)
716
717 -- Relational operators, ordering
718
719 Int8GtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ]
720 Int8GeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ]
721 Int8LeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ]
722 Int8LtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ]
723
724 Int16GtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ]
725 Int16GeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ]
726 Int16LeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ]
727 Int16LtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ]
728
729 Int32GtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ]
730 Int32GeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ]
731 Int32LeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ]
732 Int32LtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ]
733
734 IntGtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ]
735 IntGeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ]
736 IntLeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ]
737 IntLtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ]
738
739 Word8GtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ]
740 Word8GeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ]
741 Word8LeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ]
742 Word8LtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ]
743
744 Word16GtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ]
745 Word16GeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ]
746 Word16LeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ]
747 Word16LtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ]
748
749 Word32GtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ]
750 Word32GeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ]
751 Word32LeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ]
752 Word32LtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ]
753
754 WordGtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ]
755 WordGeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ]
756 WordLeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ]
757 WordLtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ]
758
759 CharGtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ]
760 CharGeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ]
761 CharLeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ]
762 CharLtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ]
763
764 FloatGtOp -> mkFloatingRelOpRule nm (>)
765 FloatGeOp -> mkFloatingRelOpRule nm (>=)
766 FloatLeOp -> mkFloatingRelOpRule nm (<=)
767 FloatLtOp -> mkFloatingRelOpRule nm (<)
768
769 DoubleGtOp -> mkFloatingRelOpRule nm (>)
770 DoubleGeOp -> mkFloatingRelOpRule nm (>=)
771 DoubleLeOp -> mkFloatingRelOpRule nm (<=)
772 DoubleLtOp -> mkFloatingRelOpRule nm (<)
773
774 -- Misc
775
776 AddrAddOp -> mkPrimOpRule nm 2 [ rightIdentityPlatform zeroi ]
777
778 SeqOp -> mkPrimOpRule nm 4 [ seqRule ]
779 SparkOp -> mkPrimOpRule nm 4 [ sparkRule ]
780
781 _ -> Nothing
782
783 {-
784 ************************************************************************
785 * *
786 \subsection{Doing the business}
787 * *
788 ************************************************************************
789 -}
790
791 -- useful shorthands
792 mkPrimOpRule :: Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
793 mkPrimOpRule nm arity rules = Just $ mkBasicRule nm arity (msum rules)
794
795 mkRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)
796 -> [RuleM CoreExpr] -> Maybe CoreRule
797 mkRelOpRule nm cmp extra
798 = mkPrimOpRule nm 2 $
799 binaryCmpLit cmp : equal_rule : extra
800 where
801 -- x `cmp` x does not depend on x, so
802 -- compute it for the arbitrary value 'True'
803 -- and use that result
804 equal_rule = do { equalArgs
805 ; platform <- getPlatform
806 ; return (if cmp True True
807 then trueValInt platform
808 else falseValInt platform) }
809
810 {- Note [Rules for floating-point comparisons]
811 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
812 We need different rules for floating-point values because for floats
813 it is not true that x = x (for NaNs); so we do not want the equal_rule
814 rule that mkRelOpRule uses.
815
816 Note also that, in the case of equality/inequality, we do /not/
817 want to switch to a case-expression. For example, we do not want
818 to convert
819 case (eqFloat# x 3.8#) of
820 True -> this
821 False -> that
822 to
823 case x of
824 3.8#::Float# -> this
825 _ -> that
826 See #9238. Reason: comparing floating-point values for equality
827 delicate, and we don't want to implement that delicacy in the code for
828 case expressions. So we make it an invariant of Core that a case
829 expression never scrutinises a Float# or Double#.
830
831 This transformation is what the litEq rule does;
832 see Note [The litEq rule: converting equality to case].
833 So we /refrain/ from using litEq for mkFloatingRelOpRule.
834 -}
835
836 mkFloatingRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)
837 -> Maybe CoreRule
838 -- See Note [Rules for floating-point comparisons]
839 mkFloatingRelOpRule nm cmp
840 = mkPrimOpRule nm 2 [binaryCmpLit cmp]
841
842 -- common constants
843 zeroi, onei, zerow, onew :: Platform -> Literal
844 zeroi platform = mkLitInt platform 0
845 onei platform = mkLitInt platform 1
846 zerow platform = mkLitWord platform 0
847 onew platform = mkLitWord platform 1
848
849 zeroI8, oneI8, zeroW8, oneW8 :: Literal
850 zeroI8 = mkLitInt8 0
851 oneI8 = mkLitInt8 1
852 zeroW8 = mkLitWord8 0
853 oneW8 = mkLitWord8 1
854
855 zeroI16, oneI16, zeroW16, oneW16 :: Literal
856 zeroI16 = mkLitInt16 0
857 oneI16 = mkLitInt16 1
858 zeroW16 = mkLitWord16 0
859 oneW16 = mkLitWord16 1
860
861 zeroI32, oneI32, zeroW32, oneW32 :: Literal
862 zeroI32 = mkLitInt32 0
863 oneI32 = mkLitInt32 1
864 zeroW32 = mkLitWord32 0
865 oneW32 = mkLitWord32 1
866
867 zeroI64, oneI64, zeroW64, oneW64 :: Literal
868 zeroI64 = mkLitInt64 0
869 oneI64 = mkLitInt64 1
870 zeroW64 = mkLitWord64 0
871 oneW64 = mkLitWord64 1
872
873 zerof, onef, twof, zerod, oned, twod :: Literal
874 zerof = mkLitFloat 0.0
875 onef = mkLitFloat 1.0
876 twof = mkLitFloat 2.0
877 zerod = mkLitDouble 0.0
878 oned = mkLitDouble 1.0
879 twod = mkLitDouble 2.0
880
881 cmpOp :: Platform -> (forall a . Ord a => a -> a -> Bool)
882 -> Literal -> Literal -> Maybe CoreExpr
883 cmpOp platform cmp = go
884 where
885 done True = Just $ trueValInt platform
886 done False = Just $ falseValInt platform
887
888 -- These compares are at different types
889 go (LitChar i1) (LitChar i2) = done (i1 `cmp` i2)
890 go (LitFloat i1) (LitFloat i2) = done (i1 `cmp` i2)
891 go (LitDouble i1) (LitDouble i2) = done (i1 `cmp` i2)
892 go (LitNumber nt1 i1) (LitNumber nt2 i2)
893 | nt1 /= nt2 = Nothing
894 | otherwise = done (i1 `cmp` i2)
895 go _ _ = Nothing
896
897 --------------------------
898
899 negOp :: RuleOpts -> Literal -> Maybe CoreExpr -- Negate
900 negOp env = \case
901 (LitFloat 0.0) -> Nothing -- can't represent -0.0 as a Rational
902 (LitFloat f) -> Just (mkFloatVal env (-f))
903 (LitDouble 0.0) -> Nothing
904 (LitDouble d) -> Just (mkDoubleVal env (-d))
905 (LitNumber nt i)
906 | litNumIsSigned nt -> Just (Lit (mkLitNumberWrap (roPlatform env) nt (-i)))
907 _ -> Nothing
908
909 complementOp :: RuleOpts -> Literal -> Maybe CoreExpr -- Binary complement
910 complementOp env (LitNumber nt i) =
911 Just (Lit (mkLitNumberWrap (roPlatform env) nt (complement i)))
912 complementOp _ _ = Nothing
913
914 int8Op2
915 :: (Integral a, Integral b)
916 => (a -> b -> Integer)
917 -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
918 int8Op2 op _ (LitNumber LitNumInt8 i1) (LitNumber LitNumInt8 i2) =
919 int8Result (fromInteger i1 `op` fromInteger i2)
920 int8Op2 _ _ _ _ = Nothing
921
922 int16Op2
923 :: (Integral a, Integral b)
924 => (a -> b -> Integer)
925 -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
926 int16Op2 op _ (LitNumber LitNumInt16 i1) (LitNumber LitNumInt16 i2) =
927 int16Result (fromInteger i1 `op` fromInteger i2)
928 int16Op2 _ _ _ _ = Nothing
929
930 int32Op2
931 :: (Integral a, Integral b)
932 => (a -> b -> Integer)
933 -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
934 int32Op2 op _ (LitNumber LitNumInt32 i1) (LitNumber LitNumInt32 i2) =
935 int32Result (fromInteger i1 `op` fromInteger i2)
936 int32Op2 _ _ _ _ = Nothing
937
938 int64Op2
939 :: (Integral a, Integral b)
940 => (a -> b -> Integer)
941 -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
942 int64Op2 op _ (LitNumber LitNumInt64 i1) (LitNumber LitNumInt64 i2) =
943 int64Result (fromInteger i1 `op` fromInteger i2)
944 int64Op2 _ _ _ _ = Nothing
945
946 intOp2 :: (Integral a, Integral b)
947 => (a -> b -> Integer)
948 -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
949 intOp2 = intOp2' . const
950
951 intOp2' :: (Integral a, Integral b)
952 => (RuleOpts -> a -> b -> Integer)
953 -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
954 intOp2' op env (LitNumber LitNumInt i1) (LitNumber LitNumInt i2) =
955 let o = op env
956 in intResult (roPlatform env) (fromInteger i1 `o` fromInteger i2)
957 intOp2' _ _ _ _ = Nothing
958
959 intOpC2 :: (Integral a, Integral b)
960 => (a -> b -> Integer)
961 -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
962 intOpC2 op env (LitNumber LitNumInt i1) (LitNumber LitNumInt i2) =
963 intCResult (roPlatform env) (fromInteger i1 `op` fromInteger i2)
964 intOpC2 _ _ _ _ = Nothing
965
966 shiftRightLogical :: forall t. (Integral t, Bits t) => Integer -> Int -> Integer
967 shiftRightLogical x n = fromIntegral (fromInteger x `shiftR` n :: t)
968
969 -- | Shift right, putting zeros in rather than sign-propagating as
970 -- 'Bits.shiftR' would do. Do this by converting to the appropriate Word
971 -- and back. Obviously this won't work for too-big values, but its ok as
972 -- we use it here.
973 shiftRightLogicalNative :: Platform -> Integer -> Int -> Integer
974 shiftRightLogicalNative platform =
975 case platformWordSize platform of
976 PW4 -> shiftRightLogical @Word32
977 PW8 -> shiftRightLogical @Word64
978
979 --------------------------
980 retLit :: (Platform -> Literal) -> RuleM CoreExpr
981 retLit l = do platform <- getPlatform
982 return $ Lit $ l platform
983
984 retLitNoC :: (Platform -> Literal) -> RuleM CoreExpr
985 retLitNoC l = do platform <- getPlatform
986 let lit = l platform
987 let ty = literalType lit
988 return $ mkCoreUbxTup [ty, ty] [Lit lit, Lit (zeroi platform)]
989
990 word8Op2
991 :: (Integral a, Integral b)
992 => (a -> b -> Integer)
993 -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
994 word8Op2 op _ (LitNumber LitNumWord8 i1) (LitNumber LitNumWord8 i2) =
995 word8Result (fromInteger i1 `op` fromInteger i2)
996 word8Op2 _ _ _ _ = Nothing
997
998 word16Op2
999 :: (Integral a, Integral b)
1000 => (a -> b -> Integer)
1001 -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
1002 word16Op2 op _ (LitNumber LitNumWord16 i1) (LitNumber LitNumWord16 i2) =
1003 word16Result (fromInteger i1 `op` fromInteger i2)
1004 word16Op2 _ _ _ _ = Nothing
1005
1006 word32Op2
1007 :: (Integral a, Integral b)
1008 => (a -> b -> Integer)
1009 -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
1010 word32Op2 op _ (LitNumber LitNumWord32 i1) (LitNumber LitNumWord32 i2) =
1011 word32Result (fromInteger i1 `op` fromInteger i2)
1012 word32Op2 _ _ _ _ = Nothing
1013
1014 word64Op2
1015 :: (Integral a, Integral b)
1016 => (a -> b -> Integer)
1017 -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
1018 word64Op2 op _ (LitNumber LitNumWord64 i1) (LitNumber LitNumWord64 i2) =
1019 word64Result (fromInteger i1 `op` fromInteger i2)
1020 word64Op2 _ _ _ _ = Nothing
1021
1022 wordOp2 :: (Integral a, Integral b)
1023 => (a -> b -> Integer)
1024 -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
1025 wordOp2 op env (LitNumber LitNumWord w1) (LitNumber LitNumWord w2)
1026 = wordResult (roPlatform env) (fromInteger w1 `op` fromInteger w2)
1027 wordOp2 _ _ _ _ = Nothing
1028
1029 wordOpC2 :: (Integral a, Integral b)
1030 => (a -> b -> Integer)
1031 -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
1032 wordOpC2 op env (LitNumber LitNumWord w1) (LitNumber LitNumWord w2) =
1033 wordCResult (roPlatform env) (fromInteger w1 `op` fromInteger w2)
1034 wordOpC2 _ _ _ _ = Nothing
1035
1036 shiftRule :: LitNumType
1037 -> (Platform -> Integer -> Int -> Integer)
1038 -> RuleM CoreExpr
1039 -- Shifts take an Int; hence third arg of op is Int
1040 -- Used for shift primops
1041 -- IntSllOp, IntSraOp, IntSrlOp :: Int# -> Int# -> Int#
1042 -- SllOp, SrlOp :: Word# -> Int# -> Word#
1043 shiftRule lit_num_ty shift_op = do
1044 platform <- getPlatform
1045 [e1, Lit (LitNumber LitNumInt shift_len)] <- getArgs
1046
1047 bit_size <- case litNumBitSize platform lit_num_ty of
1048 Nothing -> mzero
1049 Just bs -> pure (toInteger bs)
1050
1051 case e1 of
1052 _ | shift_len == 0 -> pure e1
1053
1054 -- See Note [Guarding against silly shifts]
1055 _ | shift_len < 0 || shift_len > bit_size
1056 -> pure $ Lit $ mkLitNumberWrap platform lit_num_ty 0
1057 -- Be sure to use lit_num_ty here, so we get a correctly typed zero.
1058 -- See #18589
1059
1060 Lit (LitNumber nt x)
1061 | 0 < shift_len && shift_len <= bit_size
1062 -> assert (nt == lit_num_ty) $
1063 let op = shift_op platform
1064 -- Do the shift at type Integer, but shift length is Int.
1065 -- Using host's Int is ok even if target's Int has a different size
1066 -- because we test that shift_len <= bit_size (which is at most 64)
1067 y = x `op` fromInteger shift_len
1068 in pure $ Lit $ mkLitNumberWrap platform nt y
1069
1070 _ -> mzero
1071
1072 --------------------------
1073 floatOp2 :: (Rational -> Rational -> Rational)
1074 -> RuleOpts -> Literal -> Literal
1075 -> Maybe (Expr CoreBndr)
1076 floatOp2 op env (LitFloat f1) (LitFloat f2)
1077 = Just (mkFloatVal env (f1 `op` f2))
1078 floatOp2 _ _ _ _ = Nothing
1079
1080 --------------------------
1081 floatDecodeOp :: RuleOpts -> Literal -> Maybe CoreExpr
1082 floatDecodeOp env (LitFloat ((decodeFloat . fromRational @Float) -> (m, e)))
1083 = Just $ mkCoreUbxTup [intPrimTy, intPrimTy]
1084 [ mkIntVal (roPlatform env) (toInteger m)
1085 , mkIntVal (roPlatform env) (toInteger e) ]
1086 floatDecodeOp _ _
1087 = Nothing
1088
1089 --------------------------
1090 doubleOp2 :: (Rational -> Rational -> Rational)
1091 -> RuleOpts -> Literal -> Literal
1092 -> Maybe (Expr CoreBndr)
1093 doubleOp2 op env (LitDouble f1) (LitDouble f2)
1094 = Just (mkDoubleVal env (f1 `op` f2))
1095 doubleOp2 _ _ _ _ = Nothing
1096
1097 --------------------------
1098 doubleDecodeOp :: RuleOpts -> Literal -> Maybe CoreExpr
1099 doubleDecodeOp env (LitDouble ((decodeFloat . fromRational @Double) -> (m, e)))
1100 = Just $ mkCoreUbxTup [iNT64Ty, intPrimTy]
1101 [ Lit (mkLitINT64 (toInteger m))
1102 , mkIntVal platform (toInteger e) ]
1103 where
1104 platform = roPlatform env
1105 (iNT64Ty, mkLitINT64)
1106 | platformWordSizeInBits platform < 64
1107 = (int64PrimTy, mkLitInt64Wrap)
1108 | otherwise
1109 = (intPrimTy , mkLitIntWrap platform)
1110 doubleDecodeOp _ _
1111 = Nothing
1112
1113 --------------------------
1114 {- Note [The litEq rule: converting equality to case]
1115 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1116 This stuff turns
1117 n ==# 3#
1118 into
1119 case n of
1120 3# -> True
1121 m -> False
1122
1123 This is a Good Thing, because it allows case-of case things
1124 to happen, and case-default absorption to happen. For
1125 example:
1126
1127 if (n ==# 3#) || (n ==# 4#) then e1 else e2
1128 will transform to
1129 case n of
1130 3# -> e1
1131 4# -> e1
1132 m -> e2
1133 (modulo the usual precautions to avoid duplicating e1)
1134 -}
1135
1136 litEq :: Bool -- True <=> equality, False <=> inequality
1137 -> RuleM CoreExpr
1138 litEq is_eq = msum
1139 [ do [Lit lit, expr] <- getArgs
1140 platform <- getPlatform
1141 do_lit_eq platform lit expr
1142 , do [expr, Lit lit] <- getArgs
1143 platform <- getPlatform
1144 do_lit_eq platform lit expr ]
1145 where
1146 do_lit_eq platform lit expr = do
1147 guard (not (litIsLifted lit))
1148 return (mkWildCase expr (unrestricted $ literalType lit) intPrimTy
1149 [ Alt DEFAULT [] val_if_neq
1150 , Alt (LitAlt lit) [] val_if_eq])
1151 where
1152 val_if_eq | is_eq = trueValInt platform
1153 | otherwise = falseValInt platform
1154 val_if_neq | is_eq = falseValInt platform
1155 | otherwise = trueValInt platform
1156
1157
1158 -- | Check if there is comparison with minBound or maxBound, that is
1159 -- always true or false. For instance, an Int cannot be smaller than its
1160 -- minBound, so we can replace such comparison with False.
1161 boundsCmp :: Comparison -> RuleM CoreExpr
1162 boundsCmp op = do
1163 platform <- getPlatform
1164 [a, b] <- getArgs
1165 liftMaybe $ mkRuleFn platform op a b
1166
1167 data Comparison = Gt | Ge | Lt | Le
1168
1169 mkRuleFn :: Platform -> Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr
1170 mkRuleFn platform Gt (Lit lit) _ | isMinBound platform lit = Just $ falseValInt platform
1171 mkRuleFn platform Le (Lit lit) _ | isMinBound platform lit = Just $ trueValInt platform
1172 mkRuleFn platform Ge _ (Lit lit) | isMinBound platform lit = Just $ trueValInt platform
1173 mkRuleFn platform Lt _ (Lit lit) | isMinBound platform lit = Just $ falseValInt platform
1174 mkRuleFn platform Ge (Lit lit) _ | isMaxBound platform lit = Just $ trueValInt platform
1175 mkRuleFn platform Lt (Lit lit) _ | isMaxBound platform lit = Just $ falseValInt platform
1176 mkRuleFn platform Gt _ (Lit lit) | isMaxBound platform lit = Just $ falseValInt platform
1177 mkRuleFn platform Le _ (Lit lit) | isMaxBound platform lit = Just $ trueValInt platform
1178 mkRuleFn _ _ _ _ = Nothing
1179
1180 -- | Create an Int literal expression while ensuring the given Integer is in the
1181 -- target Int range
1182 int8Result :: Integer -> Maybe CoreExpr
1183 int8Result result = Just (int8Result' result)
1184
1185 int8Result' :: Integer -> CoreExpr
1186 int8Result' result = Lit (mkLitInt8Wrap result)
1187
1188 -- | Create an Int literal expression while ensuring the given Integer is in the
1189 -- target Int range
1190 int16Result :: Integer -> Maybe CoreExpr
1191 int16Result result = Just (int16Result' result)
1192
1193 int16Result' :: Integer -> CoreExpr
1194 int16Result' result = Lit (mkLitInt16Wrap result)
1195
1196 -- | Create an Int literal expression while ensuring the given Integer is in the
1197 -- target Int range
1198 int32Result :: Integer -> Maybe CoreExpr
1199 int32Result result = Just (int32Result' result)
1200
1201 int32Result' :: Integer -> CoreExpr
1202 int32Result' result = Lit (mkLitInt32Wrap result)
1203
1204 intResult :: Platform -> Integer -> Maybe CoreExpr
1205 intResult platform result = Just (intResult' platform result)
1206
1207 intResult' :: Platform -> Integer -> CoreExpr
1208 intResult' platform result = Lit (mkLitIntWrap platform result)
1209
1210 -- | Create an unboxed pair of an Int literal expression, ensuring the given
1211 -- Integer is in the target Int range and the corresponding overflow flag
1212 -- (@0#@/@1#@) if it wasn't.
1213 intCResult :: Platform -> Integer -> Maybe CoreExpr
1214 intCResult platform result = Just (mkPair [Lit lit, Lit c])
1215 where
1216 mkPair = mkCoreUbxTup [intPrimTy, intPrimTy]
1217 (lit, b) = mkLitIntWrapC platform result
1218 c = if b then onei platform else zeroi platform
1219
1220 -- | Create a Word literal expression while ensuring the given Integer is in the
1221 -- target Word range
1222 word8Result :: Integer -> Maybe CoreExpr
1223 word8Result result = Just (word8Result' result)
1224
1225 word8Result' :: Integer -> CoreExpr
1226 word8Result' result = Lit (mkLitWord8Wrap result)
1227
1228 -- | Create a Word literal expression while ensuring the given Integer is in the
1229 -- target Word range
1230 word16Result :: Integer -> Maybe CoreExpr
1231 word16Result result = Just (word16Result' result)
1232
1233 word16Result' :: Integer -> CoreExpr
1234 word16Result' result = Lit (mkLitWord16Wrap result)
1235
1236 -- | Create a Word literal expression while ensuring the given Integer is in the
1237 -- target Word range
1238 word32Result :: Integer -> Maybe CoreExpr
1239 word32Result result = Just (word32Result' result)
1240
1241 word32Result' :: Integer -> CoreExpr
1242 word32Result' result = Lit (mkLitWord32Wrap result)
1243
1244 -- | Create a Word literal expression while ensuring the given Integer is in the
1245 -- target Word range
1246 wordResult :: Platform -> Integer -> Maybe CoreExpr
1247 wordResult platform result = Just (wordResult' platform result)
1248
1249 wordResult' :: Platform -> Integer -> CoreExpr
1250 wordResult' platform result = Lit (mkLitWordWrap platform result)
1251
1252 -- | Create an unboxed pair of a Word literal expression, ensuring the given
1253 -- Integer is in the target Word range and the corresponding carry flag
1254 -- (@0#@/@1#@) if it wasn't.
1255 wordCResult :: Platform -> Integer -> Maybe CoreExpr
1256 wordCResult platform result = Just (mkPair [Lit lit, Lit c])
1257 where
1258 mkPair = mkCoreUbxTup [wordPrimTy, intPrimTy]
1259 (lit, b) = mkLitWordWrapC platform result
1260 c = if b then onei platform else zeroi platform
1261
1262 int64Result :: Integer -> Maybe CoreExpr
1263 int64Result result = Just (int64Result' result)
1264
1265 int64Result' :: Integer -> CoreExpr
1266 int64Result' result = Lit (mkLitInt64Wrap result)
1267
1268 word64Result :: Integer -> Maybe CoreExpr
1269 word64Result result = Just (word64Result' result)
1270
1271 word64Result' :: Integer -> CoreExpr
1272 word64Result' result = Lit (mkLitWord64Wrap result)
1273
1274
1275 -- | 'ambiant (primop x) = x', but not nececesarily 'primop (ambient x) = x'.
1276 semiInversePrimOp :: PrimOp -> RuleM CoreExpr
1277 semiInversePrimOp primop = do
1278 [Var primop_id `App` e] <- getArgs
1279 matchPrimOpId primop primop_id
1280 return e
1281
1282 subsumesPrimOp :: PrimOp -> PrimOp -> RuleM CoreExpr
1283 this `subsumesPrimOp` that = do
1284 [Var primop_id `App` e] <- getArgs
1285 matchPrimOpId that primop_id
1286 return (Var (mkPrimOpId this) `App` e)
1287
1288 subsumedByPrimOp :: PrimOp -> RuleM CoreExpr
1289 subsumedByPrimOp primop = do
1290 [e@(Var primop_id `App` _)] <- getArgs
1291 matchPrimOpId primop primop_id
1292 return e
1293
1294 -- | Transform `extendWordN (narrowWordN x)` into `x .&. 0xFF..FF`
1295 extendNarrowPassthrough :: PrimOp -> Integer -> RuleM CoreExpr
1296 extendNarrowPassthrough narrow_primop n = do
1297 [Var primop_id `App` x] <- getArgs
1298 matchPrimOpId narrow_primop primop_id
1299 return (Var (mkPrimOpId WordAndOp) `App` x `App` Lit (LitNumber LitNumWord n))
1300
1301 -- | narrow subsumes bitwise `and` with full mask (cf #16402):
1302 --
1303 -- narrowN (x .&. m)
1304 -- m .&. (2^N-1) = 2^N-1
1305 -- ==> narrowN x
1306 --
1307 -- e.g. narrow16 (x .&. 0xFFFF)
1308 -- ==> narrow16 x
1309 --
1310 narrowSubsumesAnd :: PrimOp -> PrimOp -> Int -> RuleM CoreExpr
1311 narrowSubsumesAnd and_primop narrw n = do
1312 [Var primop_id `App` x `App` y] <- getArgs
1313 matchPrimOpId and_primop primop_id
1314 let mask = bit n -1
1315 g v (Lit (LitNumber _ m)) = do
1316 guard (m .&. mask == mask)
1317 return (Var (mkPrimOpId narrw) `App` v)
1318 g _ _ = mzero
1319 g x y <|> g y x
1320
1321 idempotent :: RuleM CoreExpr
1322 idempotent = do [e1, e2] <- getArgs
1323 guard $ cheapEqExpr e1 e2
1324 return e1
1325
1326 -- | Match
1327 -- (op (op v e) e)
1328 -- or (op e (op v e))
1329 -- or (op (op e v) e)
1330 -- or (op e (op e v))
1331 -- and return the innermost (op v e) or (op e v).
1332 sameArgIdempotentCommut :: PrimOp -> RuleM CoreExpr
1333 sameArgIdempotentCommut op = do
1334 [a,b] <- getArgs
1335 case (a,b) of
1336 (is_binop op -> Just (e1,e2), e3)
1337 | cheapEqExpr e2 e3 -> return a
1338 | cheapEqExpr e1 e3 -> return a
1339 (e3, is_binop op -> Just (e1,e2))
1340 | cheapEqExpr e2 e3 -> return b
1341 | cheapEqExpr e1 e3 -> return b
1342 _ -> mzero
1343
1344 {-
1345 Note [Guarding against silly shifts]
1346 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1347 Consider this code:
1348
1349 import Data.Bits( (.|.), shiftL )
1350 chunkToBitmap :: [Bool] -> Word32
1351 chunkToBitmap chunk = foldr (.|.) 0 [ 1 `shiftL` n | (True,n) <- zip chunk [0..] ]
1352
1353 This optimises to:
1354 Shift.$wgo = \ (w_sCS :: GHC.Prim.Int#) (w1_sCT :: [GHC.Types.Bool]) ->
1355 case w1_sCT of _ {
1356 [] -> 0##;
1357 : x_aAW xs_aAX ->
1358 case x_aAW of _ {
1359 GHC.Types.False ->
1360 case w_sCS of wild2_Xh {
1361 __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild2_Xh 1) xs_aAX;
1362 9223372036854775807 -> 0## };
1363 GHC.Types.True ->
1364 case GHC.Prim.>=# w_sCS 64 of _ {
1365 GHC.Types.False ->
1366 case w_sCS of wild3_Xh {
1367 __DEFAULT ->
1368 case Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX of ww_sCW { __DEFAULT ->
1369 GHC.Prim.or# (GHC.Prim.narrow32Word#
1370 (GHC.Prim.uncheckedShiftL# 1## wild3_Xh))
1371 ww_sCW
1372 };
1373 9223372036854775807 ->
1374 GHC.Prim.narrow32Word#
1375 !!!!--> (GHC.Prim.uncheckedShiftL# 1## 9223372036854775807)
1376 };
1377 GHC.Types.True ->
1378 case w_sCS of wild3_Xh {
1379 __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX;
1380 9223372036854775807 -> 0##
1381 } } } }
1382
1383 Note the massive shift on line "!!!!". It can't happen, because we've checked
1384 that w < 64, but the optimiser didn't spot that. We DO NOT want to constant-fold this!
1385 Moreover, if the programmer writes (n `uncheckedShiftL` 9223372036854775807), we
1386 can't constant fold it, but if it gets to the assembler we get
1387 Error: operand type mismatch for `shl'
1388
1389 So the best thing to do is to rewrite the shift with a call to error,
1390 when the second arg is large. However, in general we cannot do this; consider
1391 this case
1392
1393 let x = I# (uncheckedIShiftL# n 80)
1394 in ...
1395
1396 Here x contains an invalid shift and consequently we would like to rewrite it
1397 as follows:
1398
1399 let x = I# (error "invalid shift)
1400 in ...
1401
1402 This was originally done in the fix to #16449 but this breaks the let/app
1403 invariant (see Note [Core let/app invariant] in GHC.Core) as noted in #16742.
1404 For the reasons discussed in Note [Checking versus non-checking primops] (in
1405 the PrimOp module) there is no safe way rewrite the argument of I# such that
1406 it bottoms.
1407
1408 Consequently we instead take advantage of the fact that large shifts are
1409 undefined behavior (see associated documentation in primops.txt.pp) and
1410 transform the invalid shift into an "obviously incorrect" value.
1411
1412 There are two cases:
1413
1414 - Shifting fixed-width things: the primops IntSll, Sll, etc
1415 These are handled by shiftRule.
1416
1417 We are happy to shift by any amount up to wordSize but no more.
1418
1419 - Shifting Bignums (Integer, Natural): these are handled by bignum_shift.
1420
1421 Here we could in principle shift by any amount, but we arbitrary
1422 limit the shift to 4 bits; in particular we do not want shift by a
1423 huge amount, which can happen in code like that above.
1424
1425 The two cases are more different in their code paths that is comfortable,
1426 but that is only a historical accident.
1427
1428
1429 ************************************************************************
1430 * *
1431 \subsection{Vaguely generic functions}
1432 * *
1433 ************************************************************************
1434 -}
1435
1436 mkBasicRule :: Name -> Int -> RuleM CoreExpr -> CoreRule
1437 -- Gives the Rule the same name as the primop itself
1438 mkBasicRule op_name n_args rm
1439 = BuiltinRule { ru_name = occNameFS (nameOccName op_name),
1440 ru_fn = op_name,
1441 ru_nargs = n_args,
1442 ru_try = runRuleM rm }
1443
1444 newtype RuleM r = RuleM
1445 { runRuleM :: RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe r }
1446 deriving (Functor)
1447
1448 instance Applicative RuleM where
1449 pure x = RuleM $ \_ _ _ _ -> Just x
1450 (<*>) = ap
1451
1452 instance Monad RuleM where
1453 RuleM f >>= g
1454 = RuleM $ \env iu fn args ->
1455 case f env iu fn args of
1456 Nothing -> Nothing
1457 Just r -> runRuleM (g r) env iu fn args
1458
1459 instance MonadFail RuleM where
1460 fail _ = mzero
1461
1462 instance Alternative RuleM where
1463 empty = RuleM $ \_ _ _ _ -> Nothing
1464 RuleM f1 <|> RuleM f2 = RuleM $ \env iu fn args ->
1465 f1 env iu fn args <|> f2 env iu fn args
1466
1467 instance MonadPlus RuleM
1468
1469 getPlatform :: RuleM Platform
1470 getPlatform = roPlatform <$> getRuleOpts
1471
1472 getWordSize :: RuleM PlatformWordSize
1473 getWordSize = platformWordSize <$> getPlatform
1474
1475 getRuleOpts :: RuleM RuleOpts
1476 getRuleOpts = RuleM $ \rule_opts _ _ _ -> Just rule_opts
1477
1478 liftMaybe :: Maybe a -> RuleM a
1479 liftMaybe Nothing = mzero
1480 liftMaybe (Just x) = return x
1481
1482 liftLit :: (Literal -> Literal) -> RuleM CoreExpr
1483 liftLit f = liftLitPlatform (const f)
1484
1485 liftLitPlatform :: (Platform -> Literal -> Literal) -> RuleM CoreExpr
1486 liftLitPlatform f = do
1487 platform <- getPlatform
1488 [Lit lit] <- getArgs
1489 return $ Lit (f platform lit)
1490
1491 removeOp32 :: RuleM CoreExpr
1492 removeOp32 = do
1493 platform <- getPlatform
1494 case platformWordSize platform of
1495 PW4 -> do
1496 [e] <- getArgs
1497 return e
1498 PW8 ->
1499 mzero
1500
1501 getArgs :: RuleM [CoreExpr]
1502 getArgs = RuleM $ \_ _ _ args -> Just args
1503
1504 getInScopeEnv :: RuleM InScopeEnv
1505 getInScopeEnv = RuleM $ \_ iu _ _ -> Just iu
1506
1507 getFunction :: RuleM Id
1508 getFunction = RuleM $ \_ _ fn _ -> Just fn
1509
1510 isLiteral :: CoreExpr -> RuleM Literal
1511 isLiteral e = do
1512 env <- getInScopeEnv
1513 case exprIsLiteral_maybe env e of
1514 Nothing -> mzero
1515 Just l -> pure l
1516
1517 -- | Match BigNat#, Integer and Natural literals
1518 isBignumLiteral :: CoreExpr -> RuleM Integer
1519 isBignumLiteral e = isNumberLiteral e <|> isIntegerLiteral e <|> isNaturalLiteral e
1520
1521 -- | Match numeric literals
1522 isNumberLiteral :: CoreExpr -> RuleM Integer
1523 isNumberLiteral e = isLiteral e >>= \case
1524 LitNumber _ x -> pure x
1525 _ -> mzero
1526
1527 -- | Match the application of a DataCon to a numeric literal.
1528 --
1529 -- Can be used to match e.g.:
1530 -- IS 123#
1531 -- IP bigNatLiteral
1532 -- W# 123##
1533 isLitNumConApp :: CoreExpr -> RuleM (DataCon,Integer)
1534 isLitNumConApp e = do
1535 env <- getInScopeEnv
1536 case exprIsConApp_maybe env e of
1537 Just (_env,_fb,dc,_tys,[arg]) -> case exprIsLiteral_maybe env arg of
1538 Just (LitNumber _ i) -> pure (dc,i)
1539 _ -> mzero
1540 _ -> mzero
1541
1542 isIntegerLiteral :: CoreExpr -> RuleM Integer
1543 isIntegerLiteral e = do
1544 (dc,i) <- isLitNumConApp e
1545 if | dc == integerISDataCon -> pure i
1546 | dc == integerINDataCon -> pure (negate i)
1547 | dc == integerIPDataCon -> pure i
1548 | otherwise -> mzero
1549
1550 isBigIntegerLiteral :: CoreExpr -> RuleM Integer
1551 isBigIntegerLiteral e = do
1552 (dc,i) <- isLitNumConApp e
1553 if | dc == integerINDataCon -> pure (negate i)
1554 | dc == integerIPDataCon -> pure i
1555 | otherwise -> mzero
1556
1557 isNaturalLiteral :: CoreExpr -> RuleM Integer
1558 isNaturalLiteral e = do
1559 (dc,i) <- isLitNumConApp e
1560 if | dc == naturalNSDataCon -> pure i
1561 | dc == naturalNBDataCon -> pure i
1562 | otherwise -> mzero
1563
1564 -- return the n-th argument of this rule, if it is a literal
1565 -- argument indices start from 0
1566 getLiteral :: Int -> RuleM Literal
1567 getLiteral n = RuleM $ \_ _ _ exprs -> case drop n exprs of
1568 (Lit l:_) -> Just l
1569 _ -> Nothing
1570
1571 unaryLit :: (RuleOpts -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
1572 unaryLit op = do
1573 env <- getRuleOpts
1574 [Lit l] <- getArgs
1575 liftMaybe $ op env (convFloating env l)
1576
1577 binaryLit :: (RuleOpts -> Literal -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
1578 binaryLit op = do
1579 env <- getRuleOpts
1580 [Lit l1, Lit l2] <- getArgs
1581 liftMaybe $ op env (convFloating env l1) (convFloating env l2)
1582
1583 binaryCmpLit :: (forall a . Ord a => a -> a -> Bool) -> RuleM CoreExpr
1584 binaryCmpLit op = do
1585 platform <- getPlatform
1586 binaryLit (\_ -> cmpOp platform op)
1587
1588 leftIdentity :: Literal -> RuleM CoreExpr
1589 leftIdentity id_lit = leftIdentityPlatform (const id_lit)
1590
1591 rightIdentity :: Literal -> RuleM CoreExpr
1592 rightIdentity id_lit = rightIdentityPlatform (const id_lit)
1593
1594 identity :: Literal -> RuleM CoreExpr
1595 identity lit = leftIdentity lit `mplus` rightIdentity lit
1596
1597 leftIdentityPlatform :: (Platform -> Literal) -> RuleM CoreExpr
1598 leftIdentityPlatform id_lit = do
1599 platform <- getPlatform
1600 [Lit l1, e2] <- getArgs
1601 guard $ l1 == id_lit platform
1602 return e2
1603
1604 -- | Left identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in
1605 -- addition to the result, we have to indicate that no carry/overflow occurred.
1606 leftIdentityCPlatform :: (Platform -> Literal) -> RuleM CoreExpr
1607 leftIdentityCPlatform id_lit = do
1608 platform <- getPlatform
1609 [Lit l1, e2] <- getArgs
1610 guard $ l1 == id_lit platform
1611 let no_c = Lit (zeroi platform)
1612 return (mkCoreUbxTup [exprType e2, intPrimTy] [e2, no_c])
1613
1614 rightIdentityPlatform :: (Platform -> Literal) -> RuleM CoreExpr
1615 rightIdentityPlatform id_lit = do
1616 platform <- getPlatform
1617 [e1, Lit l2] <- getArgs
1618 guard $ l2 == id_lit platform
1619 return e1
1620
1621 -- | Right identity rule for PrimOps like 'IntSubC' and 'WordSubC', where, in
1622 -- addition to the result, we have to indicate that no carry/overflow occurred.
1623 rightIdentityCPlatform :: (Platform -> Literal) -> RuleM CoreExpr
1624 rightIdentityCPlatform id_lit = do
1625 platform <- getPlatform
1626 [e1, Lit l2] <- getArgs
1627 guard $ l2 == id_lit platform
1628 let no_c = Lit (zeroi platform)
1629 return (mkCoreUbxTup [exprType e1, intPrimTy] [e1, no_c])
1630
1631 identityPlatform :: (Platform -> Literal) -> RuleM CoreExpr
1632 identityPlatform lit =
1633 leftIdentityPlatform lit `mplus` rightIdentityPlatform lit
1634
1635 -- | Identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in addition
1636 -- to the result, we have to indicate that no carry/overflow occurred.
1637 identityCPlatform :: (Platform -> Literal) -> RuleM CoreExpr
1638 identityCPlatform lit =
1639 leftIdentityCPlatform lit `mplus` rightIdentityCPlatform lit
1640
1641 leftZero :: RuleM CoreExpr
1642 leftZero = do
1643 [Lit l1, _] <- getArgs
1644 guard $ isZeroLit l1
1645 return $ Lit l1
1646
1647 rightZero :: RuleM CoreExpr
1648 rightZero = do
1649 [_, Lit l2] <- getArgs
1650 guard $ isZeroLit l2
1651 return $ Lit l2
1652
1653 zeroElem :: RuleM CoreExpr
1654 zeroElem = leftZero `mplus` rightZero
1655
1656 equalArgs :: RuleM ()
1657 equalArgs = do
1658 [e1, e2] <- getArgs
1659 guard $ e1 `cheapEqExpr` e2
1660
1661 nonZeroLit :: Int -> RuleM ()
1662 nonZeroLit n = getLiteral n >>= guard . not . isZeroLit
1663
1664 oneLit :: Int -> RuleM ()
1665 oneLit n = getLiteral n >>= guard . isOneLit
1666
1667 lift_bits_op :: forall a. (Num a, FiniteBits a) => (a -> Integer) -> RuleM CoreExpr
1668 lift_bits_op op = do
1669 platform <- getPlatform
1670 [Lit (LitNumber _ l)] <- getArgs
1671 pure $ mkWordLit platform $ op (fromInteger l :: a)
1672
1673 pop_count :: forall a. (Num a, FiniteBits a) => RuleM CoreExpr
1674 pop_count = lift_bits_op @a (fromIntegral . popCount)
1675
1676 ctz :: forall a. (Num a, FiniteBits a) => RuleM CoreExpr
1677 ctz = lift_bits_op @a (fromIntegral . countTrailingZeros)
1678
1679 clz :: forall a. (Num a, FiniteBits a) => RuleM CoreExpr
1680 clz = lift_bits_op @a (fromIntegral . countLeadingZeros)
1681
1682 -- When excess precision is not requested, cut down the precision of the
1683 -- Rational value to that of Float/Double. We confuse host architecture
1684 -- and target architecture here, but it's convenient (and wrong :-).
1685 convFloating :: RuleOpts -> Literal -> Literal
1686 convFloating env (LitFloat f) | not (roExcessRationalPrecision env) =
1687 LitFloat (toRational (fromRational f :: Float ))
1688 convFloating env (LitDouble d) | not (roExcessRationalPrecision env) =
1689 LitDouble (toRational (fromRational d :: Double))
1690 convFloating _ l = l
1691
1692 guardFloatDiv :: RuleM ()
1693 guardFloatDiv = do
1694 [Lit (LitFloat f1), Lit (LitFloat f2)] <- getArgs
1695 guard $ (f1 /=0 || f2 > 0) -- see Note [negative zero]
1696 && f2 /= 0 -- avoid NaN and Infinity/-Infinity
1697
1698 guardDoubleDiv :: RuleM ()
1699 guardDoubleDiv = do
1700 [Lit (LitDouble d1), Lit (LitDouble d2)] <- getArgs
1701 guard $ (d1 /=0 || d2 > 0) -- see Note [negative zero]
1702 && d2 /= 0 -- avoid NaN and Infinity/-Infinity
1703 -- Note [negative zero] Avoid (0 / -d), otherwise 0/(-1) reduces to
1704 -- zero, but we might want to preserve the negative zero here which
1705 -- is representable in Float/Double but not in (normalised)
1706 -- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead?
1707
1708 strengthReduction :: Literal -> PrimOp -> RuleM CoreExpr
1709 strengthReduction two_lit add_op = do -- Note [Strength reduction]
1710 arg <- msum [ do [arg, Lit mult_lit] <- getArgs
1711 guard (mult_lit == two_lit)
1712 return arg
1713 , do [Lit mult_lit, arg] <- getArgs
1714 guard (mult_lit == two_lit)
1715 return arg ]
1716 return $ Var (mkPrimOpId add_op) `App` arg `App` arg
1717
1718 -- Note [Strength reduction]
1719 -- ~~~~~~~~~~~~~~~~~~~~~~~~~
1720 --
1721 -- This rule turns floating point multiplications of the form 2.0 * x and
1722 -- x * 2.0 into x + x addition, because addition costs less than multiplication.
1723 -- See #7116
1724
1725 -- Note [What's true and false]
1726 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1727 --
1728 -- trueValInt and falseValInt represent true and false values returned by
1729 -- comparison primops for Char, Int, Word, Integer, Double, Float and Addr.
1730 -- True is represented as an unboxed 1# literal, while false is represented
1731 -- as 0# literal.
1732 -- We still need Bool data constructors (True and False) to use in a rule
1733 -- for constant folding of equal Strings
1734
1735 trueValInt, falseValInt :: Platform -> Expr CoreBndr
1736 trueValInt platform = Lit $ onei platform -- see Note [What's true and false]
1737 falseValInt platform = Lit $ zeroi platform
1738
1739 trueValBool, falseValBool :: Expr CoreBndr
1740 trueValBool = Var trueDataConId -- see Note [What's true and false]
1741 falseValBool = Var falseDataConId
1742
1743 ltVal, eqVal, gtVal :: Expr CoreBndr
1744 ltVal = Var ordLTDataConId
1745 eqVal = Var ordEQDataConId
1746 gtVal = Var ordGTDataConId
1747
1748 mkIntVal :: Platform -> Integer -> Expr CoreBndr
1749 mkIntVal platform i = Lit (mkLitInt platform i)
1750 mkFloatVal :: RuleOpts -> Rational -> Expr CoreBndr
1751 mkFloatVal env f = Lit (convFloating env (LitFloat f))
1752 mkDoubleVal :: RuleOpts -> Rational -> Expr CoreBndr
1753 mkDoubleVal env d = Lit (convFloating env (LitDouble d))
1754
1755 matchPrimOpId :: PrimOp -> Id -> RuleM ()
1756 matchPrimOpId op id = do
1757 op' <- liftMaybe $ isPrimOpId_maybe id
1758 guard $ op == op'
1759
1760 {-
1761 ************************************************************************
1762 * *
1763 \subsection{Special rules for seq, tagToEnum, dataToTag}
1764 * *
1765 ************************************************************************
1766
1767 Note [tagToEnum#]
1768 ~~~~~~~~~~~~~~~~~
1769 Nasty check to ensure that tagToEnum# is applied to a type that is an
1770 enumeration TyCon. Unification may refine the type later, but this
1771 check won't see that, alas. It's crude but it works.
1772
1773 Here's are two cases that should fail
1774 f :: forall a. a
1775 f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable
1776
1777 g :: Int
1778 g = tagToEnum# 0 -- Int is not an enumeration
1779
1780 We used to make this check in the type inference engine, but it's quite
1781 ugly to do so, because the delayed constraint solving means that we don't
1782 really know what's going on until the end. It's very much a corner case
1783 because we don't expect the user to call tagToEnum# at all; we merely
1784 generate calls in derived instances of Enum. So we compromise: a
1785 rewrite rule rewrites a bad instance of tagToEnum# to an error call,
1786 and emits a warning.
1787 -}
1788
1789 tagToEnumRule :: RuleM CoreExpr
1790 -- If data T a = A | B | C
1791 -- then tagToEnum# (T ty) 2# --> B ty
1792 tagToEnumRule = do
1793 [Type ty, Lit (LitNumber LitNumInt i)] <- getArgs
1794 case splitTyConApp_maybe ty of
1795 Just (tycon, tc_args) | isEnumerationTyCon tycon -> do
1796 let tag = fromInteger i
1797 correct_tag dc = (dataConTagZ dc) == tag
1798 (dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` [])
1799 massert (null rest)
1800 return $ mkTyApps (Var (dataConWorkId dc)) tc_args
1801
1802 -- See Note [tagToEnum#]
1803 _ -> warnPprTrace True (text "tagToEnum# on non-enumeration type" <+> ppr ty) $
1804 return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type"
1805
1806 ------------------------------
1807 dataToTagRule :: RuleM CoreExpr
1808 -- See Note [dataToTag#] in primops.txt.pp
1809 dataToTagRule = a `mplus` b
1810 where
1811 -- dataToTag (tagToEnum x) ==> x
1812 a = do
1813 [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] <- getArgs
1814 guard $ tag_to_enum `hasKey` tagToEnumKey
1815 guard $ ty1 `eqType` ty2
1816 return tag
1817
1818 -- dataToTag (K e1 e2) ==> tag-of K
1819 -- This also works (via exprIsConApp_maybe) for
1820 -- dataToTag x
1821 -- where x's unfolding is a constructor application
1822 b = do
1823 dflags <- getPlatform
1824 [_, val_arg] <- getArgs
1825 in_scope <- getInScopeEnv
1826 (_,floats, dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg
1827 massert (not (isNewTyCon (dataConTyCon dc)))
1828 return $ wrapFloats floats (mkIntVal dflags (toInteger (dataConTagZ dc)))
1829
1830 {- Note [dataToTag# magic]
1831 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1832 The primop dataToTag# is unusual because it evaluates its argument.
1833 Only `SeqOp` shares that property. (Other primops do not do anything
1834 as fancy as argument evaluation.) The special handling for dataToTag#
1835 is:
1836
1837 * GHC.Core.Utils.exprOkForSpeculation has a special case for DataToTagOp,
1838 (actually in app_ok). Most primops with lifted arguments do not
1839 evaluate those arguments, but DataToTagOp and SeqOp are two
1840 exceptions. We say that they are /never/ ok-for-speculation,
1841 regardless of the evaluated-ness of their argument.
1842 See GHC.Core.Utils Note [exprOkForSpeculation and SeqOp/DataToTagOp]
1843
1844 * There is a special case for DataToTagOp in GHC.StgToCmm.Expr.cgExpr,
1845 that evaluates its argument and then extracts the tag from
1846 the returned value.
1847
1848 * An application like (dataToTag# (Just x)) is optimised by
1849 dataToTagRule in GHC.Core.Opt.ConstantFold.
1850
1851 * A case expression like
1852 case (dataToTag# e) of <alts>
1853 gets transformed t
1854 case e of <transformed alts>
1855 by GHC.Core.Opt.ConstantFold.caseRules; see Note [caseRules for dataToTag]
1856
1857 See #15696 for a long saga.
1858 -}
1859
1860 {- *********************************************************************
1861 * *
1862 unsafeEqualityProof
1863 * *
1864 ********************************************************************* -}
1865
1866 -- unsafeEqualityProof k t t ==> UnsafeRefl (Refl t)
1867 -- That is, if the two types are equal, it's not unsafe!
1868
1869 unsafeEqualityProofRule :: RuleM CoreExpr
1870 unsafeEqualityProofRule
1871 = do { [Type rep, Type t1, Type t2] <- getArgs
1872 ; guard (t1 `eqType` t2)
1873 ; fn <- getFunction
1874 ; let (_, ue) = splitForAllTyCoVars (idType fn)
1875 tc = tyConAppTyCon ue -- tycon: UnsafeEquality
1876 (dc:_) = tyConDataCons tc -- data con: UnsafeRefl
1877 -- UnsafeRefl :: forall (r :: RuntimeRep) (a :: TYPE r).
1878 -- UnsafeEquality r a a
1879 ; return (mkTyApps (Var (dataConWrapId dc)) [rep, t1]) }
1880
1881
1882 {- *********************************************************************
1883 * *
1884 Rules for seq# and spark#
1885 * *
1886 ********************************************************************* -}
1887
1888 {- Note [seq# magic]
1889 ~~~~~~~~~~~~~~~~~~~~
1890 The primop
1891 seq# :: forall a s . a -> State# s -> (# State# s, a #)
1892
1893 is /not/ the same as the Prelude function seq :: a -> b -> b
1894 as you can see from its type. In fact, seq# is the implementation
1895 mechanism for 'evaluate'
1896
1897 evaluate :: a -> IO a
1898 evaluate a = IO $ \s -> seq# a s
1899
1900 The semantics of seq# is
1901 * evaluate its first argument
1902 * and return it
1903
1904 Things to note
1905
1906 * Why do we need a primop at all? That is, instead of
1907 case seq# x s of (# x, s #) -> blah
1908 why not instead say this?
1909 case x of { DEFAULT -> blah)
1910
1911 Reason (see #5129): if we saw
1912 catch# (\s -> case x of { DEFAULT -> raiseIO# exn s }) handler
1913
1914 then we'd drop the 'case x' because the body of the case is bottom
1915 anyway. But we don't want to do that; the whole /point/ of
1916 seq#/evaluate is to evaluate 'x' first in the IO monad.
1917
1918 In short, we /always/ evaluate the first argument and never
1919 just discard it.
1920
1921 * Why return the value? So that we can control sharing of seq'd
1922 values: in
1923 let x = e in x `seq` ... x ...
1924 We don't want to inline x, so better to represent it as
1925 let x = e in case seq# x RW of (# _, x' #) -> ... x' ...
1926 also it matches the type of rseq in the Eval monad.
1927
1928 Implementing seq#. The compiler has magic for SeqOp in
1929
1930 - GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# <whnf> s)
1931
1932 - GHC.StgToCmm.Expr.cgExpr, and cgCase: special case for seq#
1933
1934 - GHC.Core.Utils.exprOkForSpeculation;
1935 see Note [exprOkForSpeculation and SeqOp/DataToTagOp] in GHC.Core.Utils
1936
1937 - Simplify.addEvals records evaluated-ness for the result; see
1938 Note [Adding evaluatedness info to pattern-bound variables]
1939 in GHC.Core.Opt.Simplify
1940 -}
1941
1942 seqRule :: RuleM CoreExpr
1943 seqRule = do
1944 [Type ty_a, Type _ty_s, a, s] <- getArgs
1945 guard $ exprIsHNF a
1946 return $ mkCoreUbxTup [exprType s, ty_a] [s, a]
1947
1948 -- spark# :: forall a s . a -> State# s -> (# State# s, a #)
1949 sparkRule :: RuleM CoreExpr
1950 sparkRule = seqRule -- reduce on HNF, just the same
1951 -- XXX perhaps we shouldn't do this, because a spark eliminated by
1952 -- this rule won't be counted as a dud at runtime?
1953
1954 {-
1955 ************************************************************************
1956 * *
1957 \subsection{Built in rules}
1958 * *
1959 ************************************************************************
1960
1961 Note [Scoping for Builtin rules]
1962 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1963 When compiling a (base-package) module that defines one of the
1964 functions mentioned in the RHS of a built-in rule, there's a danger
1965 that we'll see
1966
1967 f = ...(eq String x)....
1968
1969 ....and lower down...
1970
1971 eqString = ...
1972
1973 Then a rewrite would give
1974
1975 f = ...(eqString x)...
1976 ....and lower down...
1977 eqString = ...
1978
1979 and lo, eqString is not in scope. This only really matters when we
1980 get to code generation. But the occurrence analyser does a GlomBinds
1981 step when necessary, that does a new SCC analysis on the whole set of
1982 bindings (see occurAnalysePgm), which sorts out the dependency, so all
1983 is fine.
1984 -}
1985
1986 builtinRules :: [CoreRule]
1987 -- Rules for non-primops that can't be expressed using a RULE pragma
1988 builtinRules
1989 = [BuiltinRule { ru_name = fsLit "CStringFoldrLit",
1990 ru_fn = unpackCStringFoldrName,
1991 ru_nargs = 4, ru_try = match_cstring_foldr_lit_C },
1992 BuiltinRule { ru_name = fsLit "CStringFoldrLitUtf8",
1993 ru_fn = unpackCStringFoldrUtf8Name,
1994 ru_nargs = 4, ru_try = match_cstring_foldr_lit_utf8 },
1995 BuiltinRule { ru_name = fsLit "CStringAppendLit",
1996 ru_fn = unpackCStringAppendName,
1997 ru_nargs = 2, ru_try = match_cstring_append_lit_C },
1998 BuiltinRule { ru_name = fsLit "CStringAppendLitUtf8",
1999 ru_fn = unpackCStringAppendUtf8Name,
2000 ru_nargs = 2, ru_try = match_cstring_append_lit_utf8 },
2001 BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,
2002 ru_nargs = 2, ru_try = match_eq_string },
2003 BuiltinRule { ru_name = fsLit "CStringLength", ru_fn = cstringLengthName,
2004 ru_nargs = 1, ru_try = match_cstring_length },
2005 BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,
2006 ru_nargs = 2, ru_try = \_ _ _ -> match_inline },
2007
2008 mkBasicRule unsafeEqualityProofName 3 unsafeEqualityProofRule,
2009
2010 mkBasicRule divIntName 2 $ msum
2011 [ nonZeroLit 1 >> binaryLit (intOp2 div)
2012 , leftZero
2013 , do
2014 [arg, Lit (LitNumber LitNumInt d)] <- getArgs
2015 Just n <- return $ exactLog2 d
2016 platform <- getPlatform
2017 return $ Var (mkPrimOpId IntSraOp) `App` arg `App` mkIntVal platform n
2018 ],
2019
2020 mkBasicRule modIntName 2 $ msum
2021 [ nonZeroLit 1 >> binaryLit (intOp2 mod)
2022 , leftZero
2023 , do
2024 [arg, Lit (LitNumber LitNumInt d)] <- getArgs
2025 Just _ <- return $ exactLog2 d
2026 platform <- getPlatform
2027 return $ Var (mkPrimOpId IntAndOp)
2028 `App` arg `App` mkIntVal platform (d - 1)
2029 ]
2030 ]
2031 ++ builtinBignumRules
2032 {-# NOINLINE builtinRules #-}
2033 -- there is no benefit to inlining these yet, despite this, GHC produces
2034 -- unfoldings for this regardless since the floated list entries look small.
2035
2036 builtinBignumRules :: [CoreRule]
2037 builtinBignumRules =
2038 [ -- conversions
2039 lit_to_integer "Word# -> Integer" integerFromWordName
2040 , lit_to_integer "Int64# -> Integer" integerFromInt64Name
2041 , lit_to_integer "Word64# -> Integer" integerFromWord64Name
2042 , lit_to_integer "Natural -> Integer" integerFromNaturalName
2043
2044 , integer_to_lit "Integer -> Word# (wrap)" integerToWordName mkWordLitWrap
2045 , integer_to_lit "Integer -> Int# (wrap)" integerToIntName mkIntLitWrap
2046 , integer_to_lit "Integer -> Word64# (wrap)" integerToWord64Name (\_ -> mkWord64LitWord64 . fromInteger)
2047 , integer_to_lit "Integer -> Int64# (wrap)" integerToInt64Name (\_ -> mkInt64LitInt64 . fromInteger)
2048 , integer_to_lit "Integer -> Float#" integerToFloatName (\_ -> mkFloatLitFloat . fromInteger)
2049 , integer_to_lit "Integer -> Double#" integerToDoubleName (\_ -> mkDoubleLitDouble . fromInteger)
2050
2051 , integer_to_natural "Integer -> Natural (clamp)" integerToNaturalClampName False True
2052 , integer_to_natural "Integer -> Natural (wrap)" integerToNaturalName False False
2053 , integer_to_natural "Integer -> Natural (throw)" integerToNaturalThrowName True False
2054
2055 , natural_to_word "Natural -> Word# (wrap)" naturalToWordName
2056
2057 -- comparisons (return an unlifted Int#)
2058 , bignum_bin_pred "bigNatEq#" bignatEqName (==)
2059
2060 -- comparisons (return an Ordering)
2061 , bignum_compare "bignatCompare" bignatCompareName
2062 , bignum_compare "bignatCompareWord#" bignatCompareWordName
2063
2064 -- binary operations
2065 , integer_binop "integerAdd" integerAddName (+)
2066 , integer_binop "integerSub" integerSubName (-)
2067 , integer_binop "integerMul" integerMulName (*)
2068 , integer_binop "integerGcd" integerGcdName gcd
2069 , integer_binop "integerLcm" integerLcmName lcm
2070 , integer_binop "integerAnd" integerAndName (.&.)
2071 , integer_binop "integerOr" integerOrName (.|.)
2072 , integer_binop "integerXor" integerXorName xor
2073
2074 , natural_binop "naturalAdd" naturalAddName (+)
2075 , natural_binop "naturalMul" naturalMulName (*)
2076 , natural_binop "naturalGcd" naturalGcdName gcd
2077 , natural_binop "naturalLcm" naturalLcmName lcm
2078 , natural_binop "naturalAnd" naturalAndName (.&.)
2079 , natural_binop "naturalOr" naturalOrName (.|.)
2080 , natural_binop "naturalXor" naturalXorName xor
2081
2082 -- Natural subtraction: it's a binop but it can fail because of underflow so
2083 -- we have several primitives to handle here.
2084 , natural_sub "naturalSubUnsafe" naturalSubUnsafeName
2085 , natural_sub "naturalSubThrow" naturalSubThrowName
2086 , mkRule "naturalSub" naturalSubName 2 $ do
2087 [a0,a1] <- getArgs
2088 x <- isNaturalLiteral a0
2089 y <- isNaturalLiteral a1
2090 -- return an unboxed sum: (# (# #) | Natural #)
2091 let ret n v = pure $ mkCoreUbxSum 2 n [unboxedUnitTy,naturalTy] v
2092 platform <- getPlatform
2093 if x < y
2094 then ret 1 $ Var voidPrimId
2095 else ret 2 $ mkNaturalExpr platform (x - y)
2096
2097 -- unary operations
2098 , bignum_unop "integerNegate" integerNegateName mkIntegerExpr negate
2099 , bignum_unop "integerAbs" integerAbsName mkIntegerExpr abs
2100 , bignum_unop "integerComplement" integerComplementName mkIntegerExpr complement
2101
2102 , bignum_popcount "integerPopCount" integerPopCountName mkLitIntWrap
2103 , bignum_popcount "naturalPopCount" naturalPopCountName mkLitWordWrap
2104
2105 -- Bits.bit
2106 , bignum_bit "integerBit" integerBitName mkIntegerExpr
2107 , bignum_bit "naturalBit" naturalBitName mkNaturalExpr
2108
2109 -- Bits.testBit
2110 , bignum_testbit "integerTestBit" integerTestBitName
2111 , bignum_testbit "naturalTestBit" naturalTestBitName
2112
2113 -- Bits.shift
2114 , bignum_shift "integerShiftL" integerShiftLName shiftL mkIntegerExpr
2115 , bignum_shift "integerShiftR" integerShiftRName shiftR mkIntegerExpr
2116 , bignum_shift "naturalShiftL" naturalShiftLName shiftL mkNaturalExpr
2117 , bignum_shift "naturalShiftR" naturalShiftRName shiftR mkNaturalExpr
2118
2119 -- division
2120 , divop_one "integerQuot" integerQuotName quot mkIntegerExpr
2121 , divop_one "integerRem" integerRemName rem mkIntegerExpr
2122 , divop_one "integerDiv" integerDivName div mkIntegerExpr
2123 , divop_one "integerMod" integerModName mod mkIntegerExpr
2124 , divop_both "integerDivMod" integerDivModName divMod mkIntegerExpr integerTy
2125 , divop_both "integerQuotRem" integerQuotRemName quotRem mkIntegerExpr integerTy
2126
2127 , divop_one "naturalQuot" naturalQuotName quot mkNaturalExpr
2128 , divop_one "naturalRem" naturalRemName rem mkNaturalExpr
2129 , divop_both "naturalQuotRem" naturalQuotRemName quotRem mkNaturalExpr naturalTy
2130
2131 -- conversions from Rational for Float/Double literals
2132 , rational_to "rationalToFloat" rationalToFloatName mkFloatExpr
2133 , rational_to "rationalToDouble" rationalToDoubleName mkDoubleExpr
2134
2135 -- conversions from Integer for Float/Double literals
2136 , integer_encode_float "integerEncodeFloat" integerEncodeFloatName mkFloatLitFloat
2137 , integer_encode_float "integerEncodeDouble" integerEncodeDoubleName mkDoubleLitDouble
2138 ]
2139 where
2140 mkRule str name nargs f = BuiltinRule
2141 { ru_name = fsLit str
2142 , ru_fn = name
2143 , ru_nargs = nargs
2144 , ru_try = runRuleM $ do
2145 env <- getRuleOpts
2146 guard (roBignumRules env)
2147 f
2148 }
2149
2150 integer_to_lit str name convert = mkRule str name 1 $ do
2151 [a0] <- getArgs
2152 platform <- getPlatform
2153 -- we only match on Big Integer literals. Small literals
2154 -- are matched by the "Int# -> Integer -> *" rules
2155 x <- isBigIntegerLiteral a0
2156 pure (convert platform x)
2157
2158 natural_to_word str name = mkRule str name 1 $ do
2159 [a0] <- getArgs
2160 n <- isNaturalLiteral a0
2161 platform <- getPlatform
2162 pure (Lit (mkLitWordWrap platform n))
2163
2164 integer_to_natural str name thrw clamp = mkRule str name 1 $ do
2165 [a0] <- getArgs
2166 x <- isIntegerLiteral a0
2167 platform <- getPlatform
2168 if | x >= 0 -> pure $ mkNaturalExpr platform x
2169 | thrw -> mzero
2170 | clamp -> pure $ mkNaturalExpr platform 0 -- clamp to 0
2171 | otherwise -> pure $ mkNaturalExpr platform (abs x) -- negate/wrap
2172
2173 lit_to_integer str name = mkRule str name 1 $ do
2174 [a0] <- getArgs
2175 platform <- getPlatform
2176 i <- isBignumLiteral a0
2177 -- convert any numeric literal into an Integer literal
2178 pure (mkIntegerExpr platform i)
2179
2180 integer_binop str name op = mkRule str name 2 $ do
2181 [a0,a1] <- getArgs
2182 x <- isIntegerLiteral a0
2183 y <- isIntegerLiteral a1
2184 platform <- getPlatform
2185 pure (mkIntegerExpr platform (x `op` y))
2186
2187 natural_binop str name op = mkRule str name 2 $ do
2188 [a0,a1] <- getArgs
2189 x <- isNaturalLiteral a0
2190 y <- isNaturalLiteral a1
2191 platform <- getPlatform
2192 pure (mkNaturalExpr platform (x `op` y))
2193
2194 natural_sub str name = mkRule str name 2 $ do
2195 [a0,a1] <- getArgs
2196 x <- isNaturalLiteral a0
2197 y <- isNaturalLiteral a1
2198 guard (x >= y)
2199 platform <- getPlatform
2200 pure (mkNaturalExpr platform (x - y))
2201
2202 bignum_bin_pred str name op = mkRule str name 2 $ do
2203 platform <- getPlatform
2204 [a0,a1] <- getArgs
2205 x <- isBignumLiteral a0
2206 y <- isBignumLiteral a1
2207 pure $ if x `op` y
2208 then trueValInt platform
2209 else falseValInt platform
2210
2211 bignum_compare str name = mkRule str name 2 $ do
2212 [a0,a1] <- getArgs
2213 x <- isBignumLiteral a0
2214 y <- isBignumLiteral a1
2215 pure $ case x `compare` y of
2216 LT -> ltVal
2217 EQ -> eqVal
2218 GT -> gtVal
2219
2220 bignum_unop str name mk_lit op = mkRule str name 1 $ do
2221 [a0] <- getArgs
2222 x <- isBignumLiteral a0
2223 platform <- getPlatform
2224 pure $ mk_lit platform (op x)
2225
2226 bignum_popcount str name mk_lit = mkRule str name 1 $ do
2227 platform <- getPlatform
2228 -- We use a host Int to compute the popCount. If we compile on a 32-bit
2229 -- host for a 64-bit target, the result may be different than if computed
2230 -- by the target. So we disable this rule if sizes don't match.
2231 guard (platformWordSizeInBits platform == finiteBitSize (0 :: Word))
2232 [a0] <- getArgs
2233 x <- isBignumLiteral a0
2234 pure $ Lit (mk_lit platform (fromIntegral (popCount x)))
2235
2236 bignum_bit str name mk_lit = mkRule str name 1 $ do
2237 [a0] <- getArgs
2238 platform <- getPlatform
2239 n <- isNumberLiteral a0
2240 -- Make sure n is positive and small enough to yield a decently
2241 -- small number. Attempting to construct the Integer for
2242 -- (integerBit 9223372036854775807#)
2243 -- would be a bad idea (#14959)
2244 guard (n >= 0 && n <= fromIntegral (platformWordSizeInBits platform))
2245 -- it's safe to convert a target Int value into a host Int value
2246 -- to perform the "bit" operation because n is very small (<= 64).
2247 pure $ mk_lit platform (bit (fromIntegral n))
2248
2249 bignum_testbit str name = mkRule str name 2 $ do
2250 [a0,a1] <- getArgs
2251 platform <- getPlatform
2252 x <- isBignumLiteral a0
2253 n <- isNumberLiteral a1
2254 -- ensure that we can store 'n' in a host Int
2255 guard (n >= 0 && n <= fromIntegral (maxBound :: Int))
2256 pure $ if testBit x (fromIntegral n)
2257 then trueValInt platform
2258 else falseValInt platform
2259
2260 bignum_shift str name shift_op mk_lit = mkRule str name 2 $ do
2261 [a0,a1] <- getArgs
2262 x <- isBignumLiteral a0
2263 n <- isNumberLiteral a1
2264 -- See Note [Guarding against silly shifts]
2265 -- Restrict constant-folding of shifts on Integers, somewhat arbitrary.
2266 -- We can get huge shifts in inaccessible code (#15673)
2267 guard (n <= 4)
2268 platform <- getPlatform
2269 pure $ mk_lit platform (x `shift_op` fromIntegral n)
2270
2271 divop_one str name divop mk_lit = mkRule str name 2 $ do
2272 [a0,a1] <- getArgs
2273 n <- isBignumLiteral a0
2274 d <- isBignumLiteral a1
2275 guard (d /= 0)
2276 platform <- getPlatform
2277 pure $ mk_lit platform (n `divop` d)
2278
2279 divop_both str name divop mk_lit ty = mkRule str name 2 $ do
2280 [a0,a1] <- getArgs
2281 n <- isBignumLiteral a0
2282 d <- isBignumLiteral a1
2283 guard (d /= 0)
2284 let (r,s) = n `divop` d
2285 platform <- getPlatform
2286 pure $ mkCoreUbxTup [ty,ty] [mk_lit platform r, mk_lit platform s]
2287
2288 integer_encode_float :: RealFloat a => String -> Name -> (a -> CoreExpr) -> CoreRule
2289 integer_encode_float str name mk_lit = mkRule str name 2 $ do
2290 [a0,a1] <- getArgs
2291 x <- isIntegerLiteral a0
2292 y <- isNumberLiteral a1
2293 -- check that y (a target Int) is in the host Int range
2294 guard (y <= fromIntegral (maxBound :: Int))
2295 pure (mk_lit $ encodeFloat x (fromInteger y))
2296
2297 rational_to :: RealFloat a => String -> Name -> (a -> CoreExpr) -> CoreRule
2298 rational_to str name mk_lit = mkRule str name 2 $ do
2299 -- This turns `rationalToFloat n d` where `n` and `d` are literals into
2300 -- a literal Float (and similarly for Double).
2301 [a0,a1] <- getArgs
2302 n <- isIntegerLiteral a0
2303 d <- isIntegerLiteral a1
2304 -- it's important to not match d == 0, because that may represent a
2305 -- literal "0/0" or similar, and we can't produce a literal value for
2306 -- NaN or +-Inf
2307 guard (d /= 0)
2308 pure $ mk_lit (fromRational (n % d))
2309
2310
2311 ---------------------------------------------------
2312 -- The rules are:
2313 -- unpackAppendCString*# "foo"# (unpackCString*# "baz"#)
2314 -- = unpackCString*# "foobaz"#
2315 --
2316 -- unpackAppendCString*# "foo"# (unpackAppendCString*# "baz"# e)
2317 -- = unpackAppendCString*# "foobaz"# e
2318 --
2319
2320 -- CString version
2321 match_cstring_append_lit_C :: RuleFun
2322 match_cstring_append_lit_C = match_cstring_append_lit unpackCStringAppendIdKey unpackCStringIdKey
2323
2324 -- CStringUTF8 version
2325 match_cstring_append_lit_utf8 :: RuleFun
2326 match_cstring_append_lit_utf8 = match_cstring_append_lit unpackCStringAppendUtf8IdKey unpackCStringUtf8IdKey
2327
2328 {-# INLINE match_cstring_append_lit #-}
2329 match_cstring_append_lit :: Unique -> Unique -> RuleFun
2330 match_cstring_append_lit append_key unpack_key _ env _ [lit1, e2]
2331 | Just (LitString s1) <- exprIsLiteral_maybe env lit1
2332 , (strTicks, Var unpk `App` lit2) <- stripStrTopTicks env e2
2333 , unpk `hasKey` unpack_key
2334 , Just (LitString s2) <- exprIsLiteral_maybe env lit2
2335 = Just $ mkTicks strTicks
2336 $ Var unpk `App` Lit (LitString (s1 `BS.append` s2))
2337
2338 | Just (LitString s1) <- exprIsLiteral_maybe env lit1
2339 , (strTicks, Var appnd `App` lit2 `App` e) <- stripStrTopTicks env e2
2340 , appnd `hasKey` append_key
2341 , Just (LitString s2) <- exprIsLiteral_maybe env lit2
2342 = Just $ mkTicks strTicks
2343 $ Var appnd `App` Lit (LitString (s1 `BS.append` s2)) `App` e
2344
2345 match_cstring_append_lit _ _ _ _ _ _ = Nothing
2346
2347 ---------------------------------------------------
2348 -- The rule is this:
2349 -- unpackFoldrCString*# "foo"# c (unpackFoldrCString*# "baz"# c n)
2350 -- = unpackFoldrCString*# "foobaz"# c n
2351 --
2352 -- See also Note [String literals in GHC] in CString.hs
2353
2354 -- CString version
2355 match_cstring_foldr_lit_C :: RuleFun
2356 match_cstring_foldr_lit_C = match_cstring_foldr_lit unpackCStringFoldrIdKey
2357
2358 -- CStringUTF8 version
2359 match_cstring_foldr_lit_utf8 :: RuleFun
2360 match_cstring_foldr_lit_utf8 = match_cstring_foldr_lit unpackCStringFoldrUtf8IdKey
2361
2362 {-# INLINE match_cstring_foldr_lit #-}
2363 match_cstring_foldr_lit :: Unique -> RuleFun
2364 match_cstring_foldr_lit foldVariant _ env _
2365 [ Type ty1
2366 , lit1
2367 , c1
2368 , e2
2369 ]
2370 | (strTicks, Var unpk `App` Type ty2
2371 `App` lit2
2372 `App` c2
2373 `App` n) <- stripStrTopTicks env e2
2374 , unpk `hasKey` foldVariant
2375 , Just (LitString s1) <- exprIsLiteral_maybe env lit1
2376 , Just (LitString s2) <- exprIsLiteral_maybe env lit2
2377 , let freeVars = (mkInScopeSet (exprFreeVars c1 `unionVarSet` exprFreeVars c2))
2378 in eqExpr freeVars c1 c2
2379 , (c1Ticks, c1') <- stripStrTopTicks env c1
2380 , c2Ticks <- stripStrTopTicksT c2
2381 = assert (ty1 `eqType` ty2) $
2382 Just $ mkTicks strTicks
2383 $ Var unpk `App` Type ty1
2384 `App` Lit (LitString (s1 `BS.append` s2))
2385 `App` mkTicks (c1Ticks ++ c2Ticks) c1'
2386 `App` n
2387
2388 match_cstring_foldr_lit _ _ _ _ _ = Nothing
2389
2390
2391 -- N.B. Ensure that we strip off any ticks (e.g. source notes) from the
2392 -- argument, lest this may fail to fire when building with -g3. See #16740.
2393 --
2394 -- Also, look into variable's unfolding just in case the expression we look for
2395 -- is in a top-level thunk.
2396 stripStrTopTicks :: InScopeEnv -> CoreExpr -> ([CoreTickish], CoreExpr)
2397 stripStrTopTicks (_,id_unf) e = case e of
2398 Var v
2399 | Just rhs <- expandUnfolding_maybe (id_unf v)
2400 -> stripTicksTop tickishFloatable rhs
2401 _ -> stripTicksTop tickishFloatable e
2402
2403 stripStrTopTicksT :: CoreExpr -> [CoreTickish]
2404 stripStrTopTicksT e = stripTicksTopT tickishFloatable e
2405
2406 ---------------------------------------------------
2407 -- The rule is this:
2408 -- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2)) = s1==s2
2409 -- Also matches unpackCStringUtf8#
2410
2411 match_eq_string :: RuleFun
2412 match_eq_string _ env _ [e1, e2]
2413 | (ticks1, Var unpk1 `App` lit1) <- stripStrTopTicks env e1
2414 , (ticks2, Var unpk2 `App` lit2) <- stripStrTopTicks env e2
2415 , unpk_key1 <- getUnique unpk1
2416 , unpk_key2 <- getUnique unpk2
2417 , unpk_key1 == unpk_key2
2418 -- For now we insist the literals have to agree in their encoding
2419 -- to keep the rule simple. But we could check if the decoded strings
2420 -- compare equal in here as well.
2421 , unpk_key1 `elem` [unpackCStringUtf8IdKey, unpackCStringIdKey]
2422 , Just (LitString s1) <- exprIsLiteral_maybe env lit1
2423 , Just (LitString s2) <- exprIsLiteral_maybe env lit2
2424 = Just $ mkTicks (ticks1 ++ ticks2)
2425 $ (if s1 == s2 then trueValBool else falseValBool)
2426
2427 match_eq_string _ _ _ _ = Nothing
2428
2429 -----------------------------------------------------------------------
2430 -- Illustration of this rule:
2431 --
2432 -- cstringLength# "foobar"# --> 6
2433 -- cstringLength# "fizz\NULzz"# --> 4
2434 --
2435 -- Nota bene: Addr# literals are suffixed by a NUL byte when they are
2436 -- compiled to read-only data sections. That's why cstringLength# is
2437 -- well defined on Addr# literals that do not explicitly have an embedded
2438 -- NUL byte.
2439 --
2440 -- See GHC issue #5218, MR 2165, and bytestring PR 191. This is particularly
2441 -- helpful when using OverloadedStrings to create a ByteString since the
2442 -- function computing the length of such ByteStrings can often be constant
2443 -- folded.
2444 match_cstring_length :: RuleFun
2445 match_cstring_length rule_env env _ [lit1]
2446 | Just (LitString str) <- exprIsLiteral_maybe env lit1
2447 -- If elemIndex returns Just, it has the index of the first embedded NUL
2448 -- in the string. If no NUL bytes are present (the common case) then use
2449 -- full length of the byte string.
2450 = let len = fromMaybe (BS.length str) (BS.elemIndex 0 str)
2451 in Just (Lit (mkLitInt (roPlatform rule_env) (fromIntegral len)))
2452 match_cstring_length _ _ _ _ = Nothing
2453
2454 ---------------------------------------------------
2455 {- Note [inlineId magic]
2456 ~~~~~~~~~~~~~~~~~~~~~~~~
2457 The call 'inline f' arranges that 'f' is inlined, regardless of
2458 its size. More precisely, the call 'inline f' rewrites to the
2459 right-hand side of 'f's definition. This allows the programmer to
2460 control inlining from a particular call site rather than the
2461 definition site of the function.
2462
2463 The moving parts are simple:
2464
2465 * A very simple definition in the library base:GHC.Magic
2466 {-# NOINLINE[0] inline #-}
2467 inline :: a -> a
2468 inline x = x
2469 So in phase 0, 'inline' will be inlined, so its use imposes
2470 no overhead.
2471
2472 * A rewrite rule, in GHC.Core.Opt.ConstantFold, which makes
2473 (inline f) inline, implemented by match_inline.
2474 The rule for the 'inline' function is this:
2475 inline f_ty (f a b c) = <f's unfolding> a b c
2476 (if f has an unfolding, EVEN if it's a loop breaker)
2477
2478 It's important to allow the argument to 'inline' to have args itself
2479 (a) because its more forgiving to allow the programmer to write
2480 either inline f a b c
2481 or inline (f a b c)
2482 (b) because a polymorphic f wll get a type argument that the
2483 programmer can't avoid, so the call may look like
2484 inline (map @Int @Bool) g xs
2485
2486 Also, don't forget about 'inline's type argument!
2487 -}
2488
2489 match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
2490 match_inline (Type _ : e : _)
2491 | (Var f, args1) <- collectArgs e,
2492 Just unf <- maybeUnfoldingTemplate (realIdUnfolding f)
2493 -- Ignore the IdUnfoldingFun here!
2494 = Just (mkApps unf args1)
2495
2496 match_inline _ = Nothing
2497
2498 --------------------------------------------------------
2499 -- Note [Constant folding through nested expressions]
2500 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2501 --
2502 -- We use rewrites rules to perform constant folding. It means that we don't
2503 -- have a global view of the expression we are trying to optimise. As a
2504 -- consequence we only perform local (small-step) transformations that either:
2505 -- 1) reduce the number of operations
2506 -- 2) rearrange the expression to increase the odds that other rules will
2507 -- match
2508 --
2509 -- We don't try to handle more complex expression optimisation cases that would
2510 -- require a global view. For example, rewriting expressions to increase
2511 -- sharing (e.g., Horner's method); optimisations that require local
2512 -- transformations increasing the number of operations; rearrangements to
2513 -- cancel/factorize terms (e.g., (a+b-a-b) isn't rearranged to reduce to 0).
2514 --
2515 -- We already have rules to perform constant folding on expressions with the
2516 -- following shape (where a and/or b are literals):
2517 --
2518 -- D) op
2519 -- /\
2520 -- / \
2521 -- / \
2522 -- a b
2523 --
2524 -- To support nested expressions, we match three other shapes of expression
2525 -- trees:
2526 --
2527 -- A) op1 B) op1 C) op1
2528 -- /\ /\ /\
2529 -- / \ / \ / \
2530 -- / \ / \ / \
2531 -- a op2 op2 c op2 op3
2532 -- /\ /\ /\ /\
2533 -- / \ / \ / \ / \
2534 -- b c a b a b c d
2535 --
2536 --
2537 -- R1) +/- simplification:
2538 -- ops = + or -, two literals (not siblings)
2539 --
2540 -- Examples:
2541 -- A: 5 + (10-x) ==> 15-x
2542 -- B: (10+x) + 5 ==> 15+x
2543 -- C: (5+a)-(5-b) ==> 0+(a+b)
2544 --
2545 -- R2) *, `and`, `or` simplification
2546 -- ops = *, `and`, `or` two literals (not siblings)
2547 --
2548 -- Examples:
2549 -- A: 5 * (10*x) ==> 50*x
2550 -- B: (10*x) * 5 ==> 50*x
2551 -- C: (5*a)*(5*b) ==> 25*(a*b)
2552 --
2553 -- R3) * distribution over +/-
2554 -- op1 = *, op2 = + or -, two literals (not siblings)
2555 --
2556 -- This transformation doesn't reduce the number of operations but switches
2557 -- the outer and the inner operations so that the outer is (+) or (-) instead
2558 -- of (*). It increases the odds that other rules will match after this one.
2559 --
2560 -- Examples:
2561 -- A: 5 * (10-x) ==> 50 - (5*x)
2562 -- B: (10+x) * 5 ==> 50 + (5*x)
2563 -- C: Not supported as it would increase the number of operations:
2564 -- (5+a)*(5-b) ==> 25 - 5*b + 5*a - a*b
2565 --
2566 -- R4) Simple factorization
2567 --
2568 -- op1 = + or -, op2/op3 = *,
2569 -- one literal for each innermost * operation (except in the D case),
2570 -- the two other terms are equals
2571 --
2572 -- Examples:
2573 -- A: x - (10*x) ==> (-9)*x
2574 -- B: (10*x) + x ==> 11*x
2575 -- C: (5*x)-(x*3) ==> 2*x
2576 -- D: x+x ==> 2*x
2577 --
2578 -- R5) +/- propagation
2579 --
2580 -- ops = + or -, one literal
2581 --
2582 -- This transformation doesn't reduce the number of operations but propagates
2583 -- the constant to the outer level. It increases the odds that other rules
2584 -- will match after this one.
2585 --
2586 -- Examples:
2587 -- A: x - (10-y) ==> (x+y) - 10
2588 -- B: (10+x) - y ==> 10 + (x-y)
2589 -- C: N/A (caught by the A and B cases)
2590 --
2591 --------------------------------------------------------
2592
2593 -- Rules to perform constant folding into nested expressions
2594 --
2595 --See Note [Constant folding through nested expressions]
2596
2597 addFoldingRules :: PrimOp -> NumOps -> RuleM CoreExpr
2598 addFoldingRules op num_ops = do
2599 massert (op == numAdd num_ops)
2600 env <- getRuleOpts
2601 guard (roNumConstantFolding env)
2602 [arg1,arg2] <- getArgs
2603 platform <- getPlatform
2604 liftMaybe
2605 -- commutativity for + is handled here
2606 (addFoldingRules' platform arg1 arg2 num_ops
2607 <|> addFoldingRules' platform arg2 arg1 num_ops)
2608
2609 subFoldingRules :: PrimOp -> NumOps -> RuleM CoreExpr
2610 subFoldingRules op num_ops = do
2611 massert (op == numSub num_ops)
2612 env <- getRuleOpts
2613 guard (roNumConstantFolding env)
2614 [arg1,arg2] <- getArgs
2615 platform <- getPlatform
2616 liftMaybe (subFoldingRules' platform arg1 arg2 num_ops)
2617
2618 mulFoldingRules :: PrimOp -> NumOps -> RuleM CoreExpr
2619 mulFoldingRules op num_ops = do
2620 massert (op == numMul num_ops)
2621 env <- getRuleOpts
2622 guard (roNumConstantFolding env)
2623 [arg1,arg2] <- getArgs
2624 platform <- getPlatform
2625 liftMaybe
2626 -- commutativity for * is handled here
2627 (mulFoldingRules' platform arg1 arg2 num_ops
2628 <|> mulFoldingRules' platform arg2 arg1 num_ops)
2629
2630 andFoldingRules :: NumOps -> RuleM CoreExpr
2631 andFoldingRules num_ops = do
2632 env <- getRuleOpts
2633 guard (roNumConstantFolding env)
2634 [arg1,arg2] <- getArgs
2635 platform <- getPlatform
2636 liftMaybe
2637 -- commutativity for `and` is handled here
2638 (andFoldingRules' platform arg1 arg2 num_ops
2639 <|> andFoldingRules' platform arg2 arg1 num_ops)
2640
2641 orFoldingRules :: NumOps -> RuleM CoreExpr
2642 orFoldingRules num_ops = do
2643 env <- getRuleOpts
2644 guard (roNumConstantFolding env)
2645 [arg1,arg2] <- getArgs
2646 platform <- getPlatform
2647 liftMaybe
2648 -- commutativity for `or` is handled here
2649 (orFoldingRules' platform arg1 arg2 num_ops
2650 <|> orFoldingRules' platform arg2 arg1 num_ops)
2651
2652 addFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr
2653 addFoldingRules' platform arg1 arg2 num_ops = case (arg1, arg2) of
2654
2655 -- x + (-y) ==> x-y
2656 (x, is_neg num_ops -> Just y)
2657 -> Just (x `sub` y)
2658
2659 -- R1) +/- simplification
2660
2661 -- l1 + (l2 + x) ==> (l1+l2) + x
2662 (L l1, is_lit_add num_ops -> Just (l2,x))
2663 -> Just (mkL (l1+l2) `add` x)
2664
2665 -- l1 + (l2 - x) ==> (l1+l2) - x
2666 (L l1, is_sub num_ops -> Just (L l2,x))
2667 -> Just (mkL (l1+l2) `sub` x)
2668
2669 -- l1 + (x - l2) ==> (l1-l2) + x
2670 (L l1, is_sub num_ops -> Just (x,L l2))
2671 -> Just (mkL (l1-l2) `add` x)
2672
2673 -- (l1 + x) + (l2 + y) ==> (l1+l2) + (x+y)
2674 (is_lit_add num_ops -> Just (l1,x), is_lit_add num_ops -> Just (l2,y))
2675 -> Just (mkL (l1+l2) `add` (x `add` y))
2676
2677 -- (l1 + x) + (l2 - y) ==> (l1+l2) + (x-y)
2678 (is_lit_add num_ops -> Just (l1,x), is_sub num_ops -> Just (L l2,y))
2679 -> Just (mkL (l1+l2) `add` (x `sub` y))
2680
2681 -- (l1 + x) + (y - l2) ==> (l1-l2) + (x+y)
2682 (is_lit_add num_ops -> Just (l1,x), is_sub num_ops -> Just (y,L l2))
2683 -> Just (mkL (l1-l2) `add` (x `add` y))
2684
2685 -- (l1 - x) + (l2 - y) ==> (l1+l2) - (x+y)
2686 (is_sub num_ops -> Just (L l1,x), is_sub num_ops -> Just (L l2,y))
2687 -> Just (mkL (l1+l2) `sub` (x `add` y))
2688
2689 -- (l1 - x) + (y - l2) ==> (l1-l2) + (y-x)
2690 (is_sub num_ops -> Just (L l1,x), is_sub num_ops -> Just (y,L l2))
2691 -> Just (mkL (l1-l2) `add` (y `sub` x))
2692
2693 -- (x - l1) + (y - l2) ==> (0-l1-l2) + (x+y)
2694 (is_sub num_ops -> Just (x,L l1), is_sub num_ops -> Just (y,L l2))
2695 -> Just (mkL (0-l1-l2) `add` (x `add` y))
2696
2697 -- R4) Simple factorization
2698
2699 -- x + x ==> 2 * x
2700 _ | Just l1 <- is_expr_mul num_ops arg1 arg2
2701 -> Just (mkL (l1+1) `mul` arg1)
2702
2703 -- (l1 * x) + x ==> (l1+1) * x
2704 _ | Just l1 <- is_expr_mul num_ops arg2 arg1
2705 -> Just (mkL (l1+1) `mul` arg2)
2706
2707 -- (l1 * x) + (l2 * x) ==> (l1+l2) * x
2708 (is_lit_mul num_ops -> Just (l1,x), is_expr_mul num_ops x -> Just l2)
2709 -> Just (mkL (l1+l2) `mul` x)
2710
2711 -- R5) +/- propagation: these transformations push literals outwards
2712 -- with the hope that other rules can then be applied.
2713
2714 -- In the following rules, x can't be a literal otherwise another
2715 -- rule would have combined it with the other literal in arg2. So we
2716 -- don't have to check this to avoid loops here.
2717
2718 -- x + (l1 + y) ==> l1 + (x + y)
2719 (_, is_lit_add num_ops -> Just (l1,y))
2720 -> Just (mkL l1 `add` (arg1 `add` y))
2721
2722 -- x + (l1 - y) ==> l1 + (x - y)
2723 (_, is_sub num_ops -> Just (L l1,y))
2724 -> Just (mkL l1 `add` (arg1 `sub` y))
2725
2726 -- x + (y - l1) ==> (x + y) - l1
2727 (_, is_sub num_ops -> Just (y,L l1))
2728 -> Just ((arg1 `add` y) `sub` mkL l1)
2729
2730 _ -> Nothing
2731
2732 where
2733 mkL = Lit . mkNumLiteral platform num_ops
2734 add x y = BinOpApp x (numAdd num_ops) y
2735 sub x y = BinOpApp x (numSub num_ops) y
2736 mul x y = BinOpApp x (numMul num_ops) y
2737
2738 subFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr
2739 subFoldingRules' platform arg1 arg2 num_ops = case (arg1,arg2) of
2740 -- x - (-y) ==> x+y
2741 (x, is_neg num_ops -> Just y)
2742 -> Just (x `add` y)
2743
2744 -- R1) +/- simplification
2745
2746 -- l1 - (l2 + x) ==> (l1-l2) - x
2747 (L l1, is_lit_add num_ops -> Just (l2,x))
2748 -> Just (mkL (l1-l2) `sub` x)
2749
2750 -- l1 - (l2 - x) ==> (l1-l2) + x
2751 (L l1, is_sub num_ops -> Just (L l2,x))
2752 -> Just (mkL (l1-l2) `add` x)
2753
2754 -- l1 - (x - l2) ==> (l1+l2) - x
2755 (L l1, is_sub num_ops -> Just (x, L l2))
2756 -> Just (mkL (l1+l2) `sub` x)
2757
2758 -- (l1 + x) - l2 ==> (l1-l2) + x
2759 (is_lit_add num_ops -> Just (l1,x), L l2)
2760 -> Just (mkL (l1-l2) `add` x)
2761
2762 -- (l1 - x) - l2 ==> (l1-l2) - x
2763 (is_sub num_ops -> Just (L l1,x), L l2)
2764 -> Just (mkL (l1-l2) `sub` x)
2765
2766 -- (x - l1) - l2 ==> x - (l1+l2)
2767 (is_sub num_ops -> Just (x,L l1), L l2)
2768 -> Just (x `sub` mkL (l1+l2))
2769
2770
2771 -- (l1 + x) - (l2 + y) ==> (l1-l2) + (x-y)
2772 (is_lit_add num_ops -> Just (l1,x), is_lit_add num_ops -> Just (l2,y))
2773 -> Just (mkL (l1-l2) `add` (x `sub` y))
2774
2775 -- (l1 + x) - (l2 - y) ==> (l1-l2) + (x+y)
2776 (is_lit_add num_ops -> Just (l1,x), is_sub num_ops -> Just (L l2,y))
2777 -> Just (mkL (l1-l2) `add` (x `add` y))
2778
2779 -- (l1 + x) - (y - l2) ==> (l1+l2) + (x-y)
2780 (is_lit_add num_ops -> Just (l1,x), is_sub num_ops -> Just (y,L l2))
2781 -> Just (mkL (l1+l2) `add` (x `sub` y))
2782
2783 -- (l1 - x) - (l2 + y) ==> (l1-l2) - (x+y)
2784 (is_sub num_ops -> Just (L l1,x), is_lit_add num_ops -> Just (l2,y))
2785 -> Just (mkL (l1-l2) `sub` (x `add` y))
2786
2787 -- (x - l1) - (l2 + y) ==> (0-l1-l2) + (x-y)
2788 (is_sub num_ops -> Just (x,L l1), is_lit_add num_ops -> Just (l2,y))
2789 -> Just (mkL (0-l1-l2) `add` (x `sub` y))
2790
2791 -- (l1 - x) - (l2 - y) ==> (l1-l2) + (y-x)
2792 (is_sub num_ops -> Just (L l1,x), is_sub num_ops -> Just (L l2,y))
2793 -> Just (mkL (l1-l2) `add` (y `sub` x))
2794
2795 -- (l1 - x) - (y - l2) ==> (l1+l2) - (x+y)
2796 (is_sub num_ops -> Just (L l1,x), is_sub num_ops -> Just (y,L l2))
2797 -> Just (mkL (l1+l2) `sub` (x `add` y))
2798
2799 -- (x - l1) - (l2 - y) ==> (0-l1-l2) + (x+y)
2800 (is_sub num_ops -> Just (x,L l1), is_sub num_ops -> Just (L l2,y))
2801 -> Just (mkL (0-l1-l2) `add` (x `add` y))
2802
2803 -- (x - l1) - (y - l2) ==> (l2-l1) + (x-y)
2804 (is_sub num_ops -> Just (x,L l1), is_sub num_ops -> Just (y,L l2))
2805 -> Just (mkL (l2-l1) `add` (x `sub` y))
2806
2807 -- R4) Simple factorization
2808
2809 -- x - (l1 * x) ==> (1-l1) * x
2810 _ | Just l1 <- is_expr_mul num_ops arg1 arg2
2811 -> Just (mkL (1-l1) `mul` arg1)
2812
2813 -- (l1 * x) - x ==> (l1-1) * x
2814 _ | Just l1 <- is_expr_mul num_ops arg2 arg1
2815 -> Just (mkL (l1-1) `mul` arg2)
2816
2817 -- (l1 * x) - (l2 * x) ==> (l1-l2) * x
2818 (is_lit_mul num_ops -> Just (l1,x), is_expr_mul num_ops x -> Just l2)
2819 -> Just (mkL (l1-l2) `mul` x)
2820
2821 -- R5) +/- propagation: these transformations push literals outwards
2822 -- with the hope that other rules can then be applied.
2823
2824 -- In the following rules, x can't be a literal otherwise another
2825 -- rule would have combined it with the other literal in arg2. So we
2826 -- don't have to check this to avoid loops here.
2827
2828 -- x - (l1 + y) ==> (x - y) - l1
2829 (_, is_lit_add num_ops -> Just (l1,y))
2830 -> Just ((arg1 `sub` y) `sub` mkL l1)
2831
2832 -- (l1 + x) - y ==> l1 + (x - y)
2833 (is_lit_add num_ops -> Just (l1,x), _)
2834 -> Just (mkL l1 `add` (x `sub` arg2))
2835
2836 -- x - (l1 - y) ==> (x + y) - l1
2837 (_, is_sub num_ops -> Just (L l1,y))
2838 -> Just ((arg1 `add` y) `sub` mkL l1)
2839
2840 -- x - (y - l1) ==> l1 + (x - y)
2841 (_, is_sub num_ops -> Just (y,L l1))
2842 -> Just (mkL l1 `add` (arg1 `sub` y))
2843
2844 -- (l1 - x) - y ==> l1 - (x + y)
2845 (is_sub num_ops -> Just (L l1,x), _)
2846 -> Just (mkL l1 `sub` (x `add` arg2))
2847
2848 -- (x - l1) - y ==> (x - y) - l1
2849 (is_sub num_ops -> Just (x,L l1), _)
2850 -> Just ((x `sub` arg2) `sub` mkL l1)
2851
2852 _ -> Nothing
2853 where
2854 mkL = Lit . mkNumLiteral platform num_ops
2855 add x y = BinOpApp x (numAdd num_ops) y
2856 sub x y = BinOpApp x (numSub num_ops) y
2857 mul x y = BinOpApp x (numMul num_ops) y
2858
2859 mulFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr
2860 mulFoldingRules' platform arg1 arg2 num_ops = case (arg1,arg2) of
2861 -- (-x) * (-y) ==> x*y
2862 (is_neg num_ops -> Just x, is_neg num_ops -> Just y)
2863 -> Just (x `mul` y)
2864
2865 -- l1 * (-x) ==> (-l1) * x
2866 (L l1, is_neg num_ops -> Just x)
2867 -> Just (mkL (-l1) `mul` x)
2868
2869 -- l1 * (l2 * x) ==> (l1*l2) * x
2870 (L l1, is_lit_mul num_ops -> Just (l2,x))
2871 -> Just (mkL (l1*l2) `mul` x)
2872
2873 -- l1 * (l2 + x) ==> (l1*l2) + (l1 * x)
2874 (L l1, is_lit_add num_ops -> Just (l2,x))
2875 -> Just (mkL (l1*l2) `add` (arg1 `mul` x))
2876
2877 -- l1 * (l2 - x) ==> (l1*l2) - (l1 * x)
2878 (L l1, is_sub num_ops -> Just (L l2,x))
2879 -> Just (mkL (l1*l2) `sub` (arg1 `mul` x))
2880
2881 -- l1 * (x - l2) ==> (l1 * x) - (l1*l2)
2882 (L l1, is_sub num_ops -> Just (x, L l2))
2883 -> Just ((arg1 `mul` x) `sub` mkL (l1*l2))
2884
2885 -- (l1 * x) * (l2 * y) ==> (l1*l2) * (x * y)
2886 (is_lit_mul num_ops -> Just (l1,x), is_lit_mul num_ops -> Just (l2,y))
2887 -> Just (mkL (l1*l2) `mul` (x `mul` y))
2888
2889 _ -> Nothing
2890 where
2891 mkL = Lit . mkNumLiteral platform num_ops
2892 add x y = BinOpApp x (numAdd num_ops) y
2893 sub x y = BinOpApp x (numSub num_ops) y
2894 mul x y = BinOpApp x (numMul num_ops) y
2895
2896 andFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr
2897 andFoldingRules' platform arg1 arg2 num_ops = case (arg1, arg2) of
2898 -- R2) * `or` `and` simplications
2899 -- l1 and (l2 and x) ==> (l1 and l2) and x
2900 (L l1, is_lit_and num_ops -> Just (l2, x))
2901 -> Just (mkL (l1 .&. l2) `and` x)
2902
2903 -- l1 and (l2 or x) ==> (l1 and l2) or (l1 and x)
2904 -- does not decrease operations
2905
2906 -- (l1 and x) and (l2 and y) ==> (l1 and l2) and (x and y)
2907 (is_lit_and num_ops -> Just (l1, x), is_lit_and num_ops -> Just (l2, y))
2908 -> Just (mkL (l1 .&. l2) `and` (x `and` y))
2909
2910 -- (l1 and x) and (l2 or y) ==> (l1 and l2 and x) or (l1 and x and y)
2911 -- (l1 or x) and (l2 or y) ==> (l1 and l2) or (x and l2) or (l1 and y) or (x and y)
2912 -- increase operation numbers
2913
2914 _ -> Nothing
2915 where
2916 mkL = Lit . mkNumLiteral platform num_ops
2917 and x y = BinOpApp x (fromJust (numAnd num_ops)) y
2918
2919 orFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr
2920 orFoldingRules' platform arg1 arg2 num_ops = case (arg1, arg2) of
2921 -- R2) * `or` `and` simplications
2922 -- l1 or (l2 or x) ==> (l1 or l2) or x
2923 (L l1, is_lit_or num_ops -> Just (l2, x))
2924 -> Just (mkL (l1 .|. l2) `or` x)
2925
2926 -- l1 or (l2 and x) ==> (l1 or l2) and (l1 and x)
2927 -- does not decrease operations
2928
2929 -- (l1 or x) or (l2 or y) ==> (l1 or l2) or (x or y)
2930 (is_lit_or num_ops -> Just (l1, x), is_lit_or num_ops -> Just (l2, y))
2931 -> Just (mkL (l1 .|. l2) `or` (x `or` y))
2932
2933 -- (l1 and x) or (l2 or y) ==> (l1 and l2 and x) or (l1 and x and y)
2934 -- (l1 and x) or (l2 and y) ==> (l1 and l2) or (x and l2) or (l1 and y) or (x and y)
2935 -- increase operation numbers
2936
2937 _ -> Nothing
2938 where
2939 mkL = Lit . mkNumLiteral platform num_ops
2940 or x y = BinOpApp x (fromJust (numOr num_ops)) y
2941
2942 is_binop :: PrimOp -> CoreExpr -> Maybe (Arg CoreBndr, Arg CoreBndr)
2943 is_binop op e = case e of
2944 BinOpApp x op' y | op == op' -> Just (x,y)
2945 _ -> Nothing
2946
2947 is_op :: PrimOp -> CoreExpr -> Maybe (Arg CoreBndr)
2948 is_op op e = case e of
2949 App (OpVal op') x | op == op' -> Just x
2950 _ -> Nothing
2951
2952 is_add, is_sub, is_mul, is_and, is_or :: NumOps -> CoreExpr -> Maybe (Arg CoreBndr, Arg CoreBndr)
2953 is_add num_ops e = is_binop (numAdd num_ops) e
2954 is_sub num_ops e = is_binop (numSub num_ops) e
2955 is_mul num_ops e = is_binop (numMul num_ops) e
2956 is_and num_ops e = numAnd num_ops >>= \op -> is_binop op e
2957 is_or num_ops e = numOr num_ops >>= \op -> is_binop op e
2958
2959 is_neg :: NumOps -> CoreExpr -> Maybe (Arg CoreBndr)
2960 is_neg num_ops e = numNeg num_ops >>= \op -> is_op op e
2961
2962 -- match operation with a literal (handles commutativity)
2963 is_lit_add, is_lit_mul, is_lit_and, is_lit_or :: NumOps -> CoreExpr -> Maybe (Integer, Arg CoreBndr)
2964 is_lit_add num_ops e = is_lit' is_add num_ops e
2965 is_lit_mul num_ops e = is_lit' is_mul num_ops e
2966 is_lit_and num_ops e = is_lit' is_and num_ops e
2967 is_lit_or num_ops e = is_lit' is_or num_ops e
2968
2969 is_lit' :: (NumOps -> CoreExpr -> Maybe (Arg CoreBndr, Arg CoreBndr)) -> NumOps -> CoreExpr -> Maybe (Integer, Arg CoreBndr)
2970 is_lit' f num_ops e = case f num_ops e of
2971 Just (L l, x ) -> Just (l,x)
2972 Just (x , L l) -> Just (l,x)
2973 _ -> Nothing
2974
2975 -- match given "x": return 1
2976 -- match "lit * x": return lit value (handles commutativity)
2977 is_expr_mul :: NumOps -> Expr CoreBndr -> Expr CoreBndr -> Maybe Integer
2978 is_expr_mul num_ops x e = if
2979 | x `cheapEqExpr` e
2980 -> Just 1
2981 | Just (k,x') <- is_lit_mul num_ops e
2982 , x `cheapEqExpr` x'
2983 -> return k
2984 | otherwise
2985 -> Nothing
2986
2987
2988 -- | Match the application of a binary primop
2989 pattern BinOpApp :: Arg CoreBndr -> PrimOp -> Arg CoreBndr -> CoreExpr
2990 pattern BinOpApp x op y = OpVal op `App` x `App` y
2991
2992 -- | Match a primop
2993 pattern OpVal:: PrimOp -> Arg CoreBndr
2994 pattern OpVal op <- Var (isPrimOpId_maybe -> Just op) where
2995 OpVal op = Var (mkPrimOpId op)
2996
2997 -- | Match a literal
2998 pattern L :: Integer -> Arg CoreBndr
2999 pattern L i <- Lit (LitNumber _ i)
3000
3001 -- | Explicit "type-class"-like dictionary for numeric primops
3002 data NumOps = NumOps
3003 { numAdd :: !PrimOp -- ^ Add two numbers
3004 , numSub :: !PrimOp -- ^ Sub two numbers
3005 , numMul :: !PrimOp -- ^ Multiply two numbers
3006 , numAnd :: !(Maybe PrimOp) -- ^ And two numbers
3007 , numOr :: !(Maybe PrimOp) -- ^ Or two numbers
3008 , numNeg :: !(Maybe PrimOp) -- ^ Negate a number
3009 , numLitType :: !LitNumType -- ^ Literal type
3010 }
3011
3012 -- | Create a numeric literal
3013 mkNumLiteral :: Platform -> NumOps -> Integer -> Literal
3014 mkNumLiteral platform ops i = mkLitNumberWrap platform (numLitType ops) i
3015
3016 int8Ops :: NumOps
3017 int8Ops = NumOps
3018 { numAdd = Int8AddOp
3019 , numSub = Int8SubOp
3020 , numMul = Int8MulOp
3021 , numLitType = LitNumInt8
3022 , numAnd = Nothing
3023 , numOr = Nothing
3024 , numNeg = Just Int8NegOp
3025 }
3026
3027 word8Ops :: NumOps
3028 word8Ops = NumOps
3029 { numAdd = Word8AddOp
3030 , numSub = Word8SubOp
3031 , numMul = Word8MulOp
3032 , numAnd = Just Word8AndOp
3033 , numOr = Just Word8OrOp
3034 , numNeg = Nothing
3035 , numLitType = LitNumWord8
3036 }
3037
3038 int16Ops :: NumOps
3039 int16Ops = NumOps
3040 { numAdd = Int16AddOp
3041 , numSub = Int16SubOp
3042 , numMul = Int16MulOp
3043 , numLitType = LitNumInt16
3044 , numAnd = Nothing
3045 , numOr = Nothing
3046 , numNeg = Just Int16NegOp
3047 }
3048
3049 word16Ops :: NumOps
3050 word16Ops = NumOps
3051 { numAdd = Word16AddOp
3052 , numSub = Word16SubOp
3053 , numMul = Word16MulOp
3054 , numAnd = Just Word16AndOp
3055 , numOr = Just Word16OrOp
3056 , numNeg = Nothing
3057 , numLitType = LitNumWord16
3058 }
3059
3060 int32Ops :: NumOps
3061 int32Ops = NumOps
3062 { numAdd = Int32AddOp
3063 , numSub = Int32SubOp
3064 , numMul = Int32MulOp
3065 , numLitType = LitNumInt32
3066 , numAnd = Nothing
3067 , numOr = Nothing
3068 , numNeg = Just Int32NegOp
3069 }
3070
3071 word32Ops :: NumOps
3072 word32Ops = NumOps
3073 { numAdd = Word32AddOp
3074 , numSub = Word32SubOp
3075 , numMul = Word32MulOp
3076 , numAnd = Just Word32AndOp
3077 , numOr = Just Word32OrOp
3078 , numNeg = Nothing
3079 , numLitType = LitNumWord32
3080 }
3081
3082 int64Ops :: NumOps
3083 int64Ops = NumOps
3084 { numAdd = Int64AddOp
3085 , numSub = Int64SubOp
3086 , numMul = Int64MulOp
3087 , numLitType = LitNumInt64
3088 , numAnd = Nothing
3089 , numOr = Nothing
3090 , numNeg = Just Int64NegOp
3091 }
3092
3093 word64Ops :: NumOps
3094 word64Ops = NumOps
3095 { numAdd = Word64AddOp
3096 , numSub = Word64SubOp
3097 , numMul = Word64MulOp
3098 , numAnd = Just Word64AndOp
3099 , numOr = Just Word64OrOp
3100 , numNeg = Nothing
3101 , numLitType = LitNumWord64
3102 }
3103
3104 intOps :: NumOps
3105 intOps = NumOps
3106 { numAdd = IntAddOp
3107 , numSub = IntSubOp
3108 , numMul = IntMulOp
3109 , numAnd = Just IntAndOp
3110 , numOr = Just IntOrOp
3111 , numNeg = Just IntNegOp
3112 , numLitType = LitNumInt
3113 }
3114
3115 wordOps :: NumOps
3116 wordOps = NumOps
3117 { numAdd = WordAddOp
3118 , numSub = WordSubOp
3119 , numMul = WordMulOp
3120 , numAnd = Just WordAndOp
3121 , numOr = Just WordOrOp
3122 , numNeg = Nothing
3123 , numLitType = LitNumWord
3124 }
3125
3126 --------------------------------------------------------
3127 -- Constant folding through case-expressions
3128 --
3129 -- cf Scrutinee Constant Folding in simplCore/GHC.Core.Opt.Simplify.Utils
3130 --------------------------------------------------------
3131
3132 -- | Match the scrutinee of a case and potentially return a new scrutinee and a
3133 -- function to apply to each literal alternative.
3134 caseRules :: Platform
3135 -> CoreExpr -- Scrutinee
3136 -> Maybe ( CoreExpr -- New scrutinee
3137 , AltCon -> Maybe AltCon -- How to fix up the alt pattern
3138 -- Nothing <=> Unreachable
3139 -- See Note [Unreachable caseRules alternatives]
3140 , Id -> CoreExpr) -- How to reconstruct the original scrutinee
3141 -- from the new case-binder
3142 -- e.g case e of b {
3143 -- ...;
3144 -- con bs -> rhs;
3145 -- ... }
3146 -- ==>
3147 -- case e' of b' {
3148 -- ...;
3149 -- fixup_altcon[con] bs -> let b = mk_orig[b] in rhs;
3150 -- ... }
3151
3152 caseRules platform (App (App (Var f) v) (Lit l)) -- v `op` x#
3153 | Just op <- isPrimOpId_maybe f
3154 , LitNumber _ x <- l
3155 , Just adjust_lit <- adjustDyadicRight op x
3156 = Just (v, tx_lit_con platform adjust_lit
3157 , \v -> (App (App (Var f) (Var v)) (Lit l)))
3158
3159 caseRules platform (App (App (Var f) (Lit l)) v) -- x# `op` v
3160 | Just op <- isPrimOpId_maybe f
3161 , LitNumber _ x <- l
3162 , Just adjust_lit <- adjustDyadicLeft x op
3163 = Just (v, tx_lit_con platform adjust_lit
3164 , \v -> (App (App (Var f) (Lit l)) (Var v)))
3165
3166
3167 caseRules platform (App (Var f) v ) -- op v
3168 | Just op <- isPrimOpId_maybe f
3169 , Just adjust_lit <- adjustUnary op
3170 = Just (v, tx_lit_con platform adjust_lit
3171 , \v -> App (Var f) (Var v))
3172
3173 -- See Note [caseRules for tagToEnum]
3174 caseRules platform (App (App (Var f) type_arg) v)
3175 | Just TagToEnumOp <- isPrimOpId_maybe f
3176 = Just (v, tx_con_tte platform
3177 , \v -> (App (App (Var f) type_arg) (Var v)))
3178
3179 -- See Note [caseRules for dataToTag]
3180 caseRules _ (App (App (Var f) (Type ty)) v) -- dataToTag x
3181 | Just DataToTagOp <- isPrimOpId_maybe f
3182 , Just (tc, _) <- tcSplitTyConApp_maybe ty
3183 , isAlgTyCon tc
3184 = Just (v, tx_con_dtt ty
3185 , \v -> App (App (Var f) (Type ty)) (Var v))
3186
3187 caseRules _ _ = Nothing
3188
3189
3190 tx_lit_con :: Platform -> (Integer -> Integer) -> AltCon -> Maybe AltCon
3191 tx_lit_con _ _ DEFAULT = Just DEFAULT
3192 tx_lit_con platform adjust (LitAlt l) = Just $ LitAlt (mapLitValue platform adjust l)
3193 tx_lit_con _ _ alt = pprPanic "caseRules" (ppr alt)
3194 -- NB: mapLitValue uses mkLitIntWrap etc, to ensure that the
3195 -- literal alternatives remain in Word/Int target ranges
3196 -- (See Note [Word/Int underflow/overflow] in GHC.Types.Literal and #13172).
3197
3198 adjustDyadicRight :: PrimOp -> Integer -> Maybe (Integer -> Integer)
3199 -- Given (x `op` lit) return a function 'f' s.t. f (x `op` lit) = x
3200 adjustDyadicRight op lit
3201 = case op of
3202 WordAddOp -> Just (\y -> y-lit )
3203 IntAddOp -> Just (\y -> y-lit )
3204 WordSubOp -> Just (\y -> y+lit )
3205 IntSubOp -> Just (\y -> y+lit )
3206 WordXorOp -> Just (\y -> y `xor` lit)
3207 IntXorOp -> Just (\y -> y `xor` lit)
3208 _ -> Nothing
3209
3210 adjustDyadicLeft :: Integer -> PrimOp -> Maybe (Integer -> Integer)
3211 -- Given (lit `op` x) return a function 'f' s.t. f (lit `op` x) = x
3212 adjustDyadicLeft lit op
3213 = case op of
3214 WordAddOp -> Just (\y -> y-lit )
3215 IntAddOp -> Just (\y -> y-lit )
3216 WordSubOp -> Just (\y -> lit-y )
3217 IntSubOp -> Just (\y -> lit-y )
3218 WordXorOp -> Just (\y -> y `xor` lit)
3219 IntXorOp -> Just (\y -> y `xor` lit)
3220 _ -> Nothing
3221
3222
3223 adjustUnary :: PrimOp -> Maybe (Integer -> Integer)
3224 -- Given (op x) return a function 'f' s.t. f (op x) = x
3225 adjustUnary op
3226 = case op of
3227 WordNotOp -> Just (\y -> complement y)
3228 IntNotOp -> Just (\y -> complement y)
3229 IntNegOp -> Just (\y -> negate y )
3230 _ -> Nothing
3231
3232 tx_con_tte :: Platform -> AltCon -> Maybe AltCon
3233 tx_con_tte _ DEFAULT = Just DEFAULT
3234 tx_con_tte _ alt@(LitAlt {}) = pprPanic "caseRules" (ppr alt)
3235 tx_con_tte platform (DataAlt dc) -- See Note [caseRules for tagToEnum]
3236 = Just $ LitAlt $ mkLitInt platform $ toInteger $ dataConTagZ dc
3237
3238 tx_con_dtt :: Type -> AltCon -> Maybe AltCon
3239 tx_con_dtt _ DEFAULT = Just DEFAULT
3240 tx_con_dtt ty (LitAlt (LitNumber LitNumInt i))
3241 | tag >= 0
3242 , tag < n_data_cons
3243 = Just (DataAlt (data_cons !! tag)) -- tag is zero-indexed, as is (!!)
3244 | otherwise
3245 = Nothing
3246 where
3247 tag = fromInteger i :: ConTagZ
3248 tc = tyConAppTyCon ty
3249 n_data_cons = tyConFamilySize tc
3250 data_cons = tyConDataCons tc
3251
3252 tx_con_dtt _ alt = pprPanic "caseRules" (ppr alt)
3253
3254
3255 {- Note [caseRules for tagToEnum]
3256 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3257 We want to transform
3258 case tagToEnum x of
3259 False -> e1
3260 True -> e2
3261 into
3262 case x of
3263 0# -> e1
3264 1# -> e2
3265
3266 This rule eliminates a lot of boilerplate. For
3267 if (x>y) then e2 else e1
3268 we generate
3269 case tagToEnum (x ># y) of
3270 False -> e1
3271 True -> e2
3272 and it is nice to then get rid of the tagToEnum.
3273
3274 Beware (#14768): avoid the temptation to map constructor 0 to
3275 DEFAULT, in the hope of getting this
3276 case (x ># y) of
3277 DEFAULT -> e1
3278 1# -> e2
3279 That fails utterly in the case of
3280 data Colour = Red | Green | Blue
3281 case tagToEnum x of
3282 DEFAULT -> e1
3283 Red -> e2
3284
3285 We don't want to get this!
3286 case x of
3287 DEFAULT -> e1
3288 DEFAULT -> e2
3289
3290 Instead, we deal with turning one branch into DEFAULT in GHC.Core.Opt.Simplify.Utils
3291 (add_default in mkCase3).
3292
3293 Note [caseRules for dataToTag]
3294 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3295 See also Note [dataToTag#] in primpops.txt.pp
3296
3297 We want to transform
3298 case dataToTag x of
3299 DEFAULT -> e1
3300 1# -> e2
3301 into
3302 case x of
3303 DEFAULT -> e1
3304 (:) _ _ -> e2
3305
3306 Note the need for some wildcard binders in
3307 the 'cons' case.
3308
3309 For the time, we only apply this transformation when the type of `x` is a type
3310 headed by a normal tycon. In particular, we do not apply this in the case of a
3311 data family tycon, since that would require carefully applying coercion(s)
3312 between the data family and the data family instance's representation type,
3313 which caseRules isn't currently engineered to handle (#14680).
3314
3315 Note [Unreachable caseRules alternatives]
3316 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3317 Take care if we see something like
3318 case dataToTag x of
3319 DEFAULT -> e1
3320 -1# -> e2
3321 100 -> e3
3322 because there isn't a data constructor with tag -1 or 100. In this case the
3323 out-of-range alternative is dead code -- we know the range of tags for x.
3324
3325 Hence caseRules returns (AltCon -> Maybe AltCon), with Nothing indicating
3326 an alternative that is unreachable.
3327
3328 You may wonder how this can happen: check out #15436.
3329 -}