PrelRules.lhs 15.3 KB
Newer Older
1
2
3
4
5
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[ConFold]{Constant Folder}

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

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

\begin{code}
15
16
17

{-# OPTIONS -optc-DNON_POSIX_SOURCE #-}

18
module PrelRules ( primOpRules, builtinRules ) where
19
20
21
22

#include "HsVersions.h"

import CoreSyn
23
24
import Id		( mkWildId )
import Literal		( Literal(..), isLitLitLit, mkMachInt, mkMachWord
25
			, literalType
26
			, word2IntLit, int2WordLit
apt's avatar
apt committed
27
28
			, narrow8IntLit, narrow16IntLit, narrow32IntLit
			, narrow8WordLit, narrow16WordLit, narrow32WordLit
29
			, char2IntLit, int2CharLit
30
			, float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit
31
			, float2DoubleLit, double2FloatLit
32
			)
33
import PrimOp		( PrimOp(..), primOpOcc )
34
import TysWiredIn	( trueDataConId, falseDataConId )
35
import TyCon		( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon )
36
import DataCon		( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG )
37
import CoreUtils	( cheapEqExpr, exprIsConApp_maybe )
38
import Type		( tyConAppTyCon, eqType )
39
import OccName		( occNameUserString)
40
import PrelNames	( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey,
41
			  eqStringName, unpackCStringIdKey )
42
import Maybes		( orElse )
43
import Name		( Name )
44
import Outputable
45
import FastString
46
import CmdLineOpts      ( opt_SimplExcessPrecision )
47
48
49
50
51
52
53

import DATA_BITS	( Bits(..) )
#if __GLASGOW_HASKELL__ >= 500
import DATA_WORD	( Word )
#else
import DATA_WORD	( Word64 )
#endif
54
55
56
57
\end{code}


\begin{code}
58
59
primOpRules :: PrimOp -> [CoreRule]
primOpRules op = primop_rule op
60
  where
61
62
    op_name = mkFastString (occNameUserString (primOpOcc op))
    op_name_case = op_name `appendFS` FSLIT("->case")
63

64
65
66
	-- A useful shorthand
    one_rule rule_fn = [BuiltinRule op_name rule_fn]

67
68
69
    -- ToDo:	something for integer-shift ops?
    --		NotOp

70
71
    primop_rule TagToEnumOp = one_rule tagToEnumRule
    primop_rule DataToTagOp = one_rule dataToTagRule
72

73
	-- Int operations
74
75
76
77
78
79
    primop_rule IntAddOp    = one_rule (twoLits (intOp2     (+)))
    primop_rule IntSubOp    = one_rule (twoLits (intOp2     (-)))
    primop_rule IntMulOp    = one_rule (twoLits (intOp2     (*)))
    primop_rule IntQuotOp   = one_rule (twoLits (intOp2Z    quot))
    primop_rule IntRemOp    = one_rule (twoLits (intOp2Z    rem))
    primop_rule IntNegOp    = one_rule (oneLit  negOp)
80
81

	-- Word operations
82
#if __GLASGOW_HASKELL__ >= 500
83
84
85
    primop_rule WordAddOp   = one_rule (twoLits (wordOp2    (+)))
    primop_rule WordSubOp   = one_rule (twoLits (wordOp2    (-)))
    primop_rule WordMulOp   = one_rule (twoLits (wordOp2    (*)))
86
#endif
87
88
    primop_rule WordQuotOp  = one_rule (twoLits (wordOp2Z   quot))
    primop_rule WordRemOp   = one_rule (twoLits (wordOp2Z   rem))
89
#if __GLASGOW_HASKELL__ >= 407
90
91
92
    primop_rule AndOp       = one_rule (twoLits (wordBitOp2 (.&.)))
    primop_rule OrOp        = one_rule (twoLits (wordBitOp2 (.|.)))
    primop_rule XorOp       = one_rule (twoLits (wordBitOp2 xor))
93
#endif
94
95

	-- coercions
96
97
98
99
100
101
102
103
104
105
106
107
108
109
    primop_rule Word2IntOp 	= one_rule (oneLit (litCoerce word2IntLit))
    primop_rule Int2WordOp 	= one_rule (oneLit (litCoerce int2WordLit))
    primop_rule Narrow8IntOp 	= one_rule (oneLit (litCoerce narrow8IntLit))
    primop_rule Narrow16IntOp 	= one_rule (oneLit (litCoerce narrow16IntLit))
    primop_rule Narrow32IntOp 	= one_rule (oneLit (litCoerce narrow32IntLit))
    primop_rule Narrow8WordOp 	= one_rule (oneLit (litCoerce narrow8WordLit))
    primop_rule Narrow16WordOp 	= one_rule (oneLit (litCoerce narrow16WordLit))
    primop_rule Narrow32WordOp 	= one_rule (oneLit (litCoerce narrow32WordLit))
    primop_rule OrdOp   	= one_rule (oneLit (litCoerce char2IntLit))
    primop_rule ChrOp    	= one_rule (oneLit (litCoerce int2CharLit))
    primop_rule Float2IntOp	= one_rule (oneLit (litCoerce float2IntLit))
    primop_rule Int2FloatOp	= one_rule (oneLit (litCoerce int2FloatLit))
    primop_rule Double2IntOp	= one_rule (oneLit (litCoerce double2IntLit))
    primop_rule Int2DoubleOp	= one_rule (oneLit (litCoerce int2DoubleLit))
110
	-- SUP: Not sure what the standard says about precision in the following 2 cases
111
112
    primop_rule Float2DoubleOp 	= one_rule (oneLit (litCoerce float2DoubleLit))
    primop_rule Double2FloatOp 	= one_rule (oneLit (litCoerce double2FloatLit))
113
114

	-- Float
115
116
117
118
119
    primop_rule FloatAddOp   = one_rule (twoLits (floatOp2  (+)))
    primop_rule FloatSubOp   = one_rule (twoLits (floatOp2  (-)))
    primop_rule FloatMulOp   = one_rule (twoLits (floatOp2  (*)))
    primop_rule FloatDivOp   = one_rule (twoLits (floatOp2Z (/)))
    primop_rule FloatNegOp   = one_rule (oneLit  negOp)
120
121

	-- Double
122
123
124
125
126
    primop_rule DoubleAddOp   = one_rule (twoLits (doubleOp2  (+)))
    primop_rule DoubleSubOp   = one_rule (twoLits (doubleOp2  (-)))
    primop_rule DoubleMulOp   = one_rule (twoLits (doubleOp2  (*)))
    primop_rule DoubleDivOp   = one_rule (twoLits (doubleOp2Z (/)))
    primop_rule DoubleNegOp   = one_rule (oneLit  negOp)
127
128

	-- Relational operators
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
    primop_rule IntEqOp  = [BuiltinRule op_name (relop (==)), BuiltinRule op_name_case (litEq True)]
    primop_rule IntNeOp  = [BuiltinRule op_name (relop (/=)), BuiltinRule op_name_case (litEq False)]
    primop_rule CharEqOp = [BuiltinRule op_name (relop (==)), BuiltinRule op_name_case (litEq True)]
    primop_rule CharNeOp = [BuiltinRule op_name (relop (/=)), BuiltinRule op_name_case (litEq False)]

    primop_rule IntGtOp		= one_rule (relop (>))
    primop_rule IntGeOp		= one_rule (relop (>=))
    primop_rule IntLeOp		= one_rule (relop (<=))
    primop_rule IntLtOp		= one_rule (relop (<))

    primop_rule CharGtOp	= one_rule (relop (>))
    primop_rule CharGeOp	= one_rule (relop (>=))
    primop_rule CharLeOp	= one_rule (relop (<=))
    primop_rule CharLtOp	= one_rule (relop (<))

    primop_rule FloatGtOp	= one_rule (relop (>))
    primop_rule FloatGeOp	= one_rule (relop (>=))
    primop_rule FloatLeOp	= one_rule (relop (<=))
    primop_rule FloatLtOp	= one_rule (relop (<))
    primop_rule FloatEqOp	= one_rule (relop (==))
    primop_rule FloatNeOp	= one_rule (relop (/=))

    primop_rule DoubleGtOp	= one_rule (relop (>))
    primop_rule DoubleGeOp	= one_rule (relop (>=))
    primop_rule DoubleLeOp	= one_rule (relop (<=))
    primop_rule DoubleLtOp	= one_rule (relop (<))
    primop_rule DoubleEqOp	= one_rule (relop (==))
    primop_rule DoubleNeOp	= one_rule (relop (/=))

    primop_rule WordGtOp	= one_rule (relop (>))
    primop_rule WordGeOp	= one_rule (relop (>=))
    primop_rule WordLeOp	= one_rule (relop (<=))
    primop_rule WordLtOp	= one_rule (relop (<))
    primop_rule WordEqOp	= one_rule (relop (==))
    primop_rule WordNeOp	= one_rule (relop (/=))

    primop_rule other		= []


    relop cmp = twoLits (cmpOp (\ord -> ord `cmp` EQ))
169
170
171
	-- Cunning.  cmpOp compares the values to give an Ordering.
	-- It applies its argument to that ordering value to turn
	-- the ordering into a boolean value.  (`cmp` EQ) is just the job.
172
173
174
175
176
177
178
179
\end{code}

%************************************************************************
%*									*
\subsection{Doing the business}
%*									*
%************************************************************************

180
181
182
183
184
	IMPORTANT NOTE

In all these operations we might find a LitLit as an operand; that's
why we have the catch-all Nothing case.

185
186
\begin{code}
--------------------------
187
188
189
litCoerce :: (Literal -> Literal) -> Literal -> Maybe CoreExpr
litCoerce fn lit | isLitLitLit lit = Nothing
                 | otherwise       = Just (Lit (fn lit))
190
191

--------------------------
192
193
cmpOp :: (Ordering -> Bool) -> Literal -> Literal -> Maybe CoreExpr
cmpOp cmp l1 l2
194
195
  = go l1 l2
  where
196
197
    done res | cmp res   = Just trueVal
	     | otherwise = Just falseVal
198
199
200
201
202
203
204
205
206
207

	-- These compares are at different types
    go (MachChar i1)   (MachChar i2)   = done (i1 `compare` i2)
    go (MachInt i1)    (MachInt i2)    = done (i1 `compare` i2)
    go (MachInt64 i1)  (MachInt64 i2)  = done (i1 `compare` i2)
    go (MachWord i1)   (MachWord i2)   = done (i1 `compare` i2)
    go (MachWord64 i1) (MachWord64 i2) = done (i1 `compare` i2)
    go (MachFloat i1)  (MachFloat i2)  = done (i1 `compare` i2)
    go (MachDouble i1) (MachDouble i2) = done (i1 `compare` i2)
    go l1	       l2	       = Nothing
208
209

--------------------------
210

211
212
213
214
215
216
negOp (MachFloat 0.0) = Nothing  -- can't represent -0.0 as a Rational
negOp (MachFloat f)   = Just (mkFloatVal (-f))
negOp (MachDouble 0.0) = Nothing
negOp (MachDouble d)   = Just (mkDoubleVal (-d))
negOp (MachInt i)      = intResult (-i)
negOp l		       = Nothing
217
218

--------------------------
219
220
intOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` i2)
intOp2 op l1	       l2	    = Nothing		-- Could find LitLit
221

222
223
224
intOp2Z op (MachInt i1) (MachInt i2)
  | i2 /= 0 = Just (mkIntVal (i1 `op` i2))
intOp2Z op l1 l2 = Nothing		-- LitLit or zero dividend
225

226
--------------------------
227
#if __GLASGOW_HASKELL__ >= 500
228
229
230
wordOp2 op (MachWord w1) (MachWord w2)
  = wordResult (w1 `op` w2)
wordOp2 op l1 l2 = Nothing		-- Could find LitLit
231
#endif
232

233
234
235
wordOp2Z op (MachWord w1) (MachWord w2)
  | w2 /= 0 = Just (mkWordVal (w1 `op` w2))
wordOp2Z op l1 l2 = Nothing	-- LitLit or zero dividend
236

237
#if __GLASGOW_HASKELL__ >= 500
238
239
wordBitOp2 op l1@(MachWord w1) l2@(MachWord w2)
  = Just (mkWordVal (w1 `op` w2))
240
241
#else
-- Integer is not an instance of Bits, so we operate on Word64
242
243
wordBitOp2 op l1@(MachWord w1) l2@(MachWord w2)
  = Just (mkWordVal ((fromIntegral::Word64->Integer) (fromIntegral w1 `op` fromIntegral w2)))
244
#endif
245
wordBitOp2 op l1 l2 = Nothing		-- Could find LitLit
246

247
--------------------------
248
249
250
floatOp2  op (MachFloat f1) (MachFloat f2)
  = Just (mkFloatVal (f1 `op` f2))
floatOp2  op l1 l2 = Nothing
251

252
253
254
floatOp2Z op (MachFloat f1) (MachFloat f2)
  | f2 /= 0   = Just (mkFloatVal (f1 `op` f2))
floatOp2Z op l1 l2 = Nothing
255

256
--------------------------
257
258
259
doubleOp2  op (MachDouble f1) (MachDouble f2)
  = Just (mkDoubleVal (f1 `op` f2))
doubleOp2 op l1 l2 = Nothing
260

261
262
263
doubleOp2Z op (MachDouble f1) (MachDouble f2)
  | f2 /= 0   = Just (mkDoubleVal (f1 `op` f2))
doubleOp2Z op l1 l2 = Nothing
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285


--------------------------
	-- This stuff turns
	--	n ==# 3#
	-- into
	--	case n of
	--	  3# -> True
	--	  m  -> False
	--
	-- This is a Good Thing, because it allows case-of case things
	-- to happen, and case-default absorption to happen.  For
	-- example:
	--
	--	if (n ==# 3#) || (n ==# 4#) then e1 else e2
	-- will transform to
	--	case n of
	--	  3# -> e1
	--	  4# -> e1
	--	  m  -> e2
	-- (modulo the usual precautions to avoid duplicating e1)

286
litEq :: Bool		-- True <=> equality, False <=> inequality
287
288
289
290
291
292
293
294
295
      -> RuleFun
litEq is_eq [Lit lit, expr] = do_lit_eq is_eq lit expr
litEq is_eq [expr, Lit lit] = do_lit_eq is_eq lit expr
litEq is_eq other	    = Nothing

do_lit_eq is_eq lit expr
  = Just (Case expr (mkWildId (literalType lit))
		[(DEFAULT,    [], val_if_neq),
		 (LitAlt lit, [], val_if_eq)])
296
297
298
299
300
  where
    val_if_eq  | is_eq     = trueVal
	       | otherwise = falseVal
    val_if_neq | is_eq     = falseVal
	       | otherwise = trueVal
301

302
303
304
305
306
-- Note that we *don't* warn the user about overflow. It's not done at
-- runtime either, and compilation of completely harmless things like
--    ((124076834 :: Word32) + (2147483647 :: Word32))
-- would yield a warning. Instead we simply squash the value into the
-- Int range, but not in a way suitable for cross-compiling... :-(
307
308
309
intResult :: Integer -> Maybe CoreExpr
intResult result
  = Just (mkIntVal (toInteger (fromInteger result :: Int)))
310
311

#if __GLASGOW_HASKELL__ >= 500
312
313
314
wordResult :: Integer -> Maybe CoreExpr
wordResult result
  = Just (mkWordVal (toInteger (fromInteger result :: Word)))
315
#endif
316
317
318
319
320
321
322
323
324
325
\end{code}


%************************************************************************
%*									*
\subsection{Vaguely generic functions
%*									*
%************************************************************************

\begin{code}
326
type RuleFun = [CoreExpr] -> Maybe CoreExpr
327

328
twoLits :: (Literal -> Literal -> Maybe CoreExpr) -> RuleFun
329
twoLits rule [Lit l1, Lit l2] = rule (convFloating l1) (convFloating l2)
330
twoLits rule _                = Nothing
331

332
oneLit :: (Literal -> Maybe CoreExpr) -> RuleFun
333
oneLit rule [Lit l1] = rule (convFloating l1)
334
oneLit rule _        = Nothing
335

336
337
338
-- When excess precision is not requested, cut down the precision of the
-- Rational value to that of Float/Double. We confuse host architecture
-- and target architecture here, but it's convenient (and wrong :-).
339
convFloating :: Literal -> Literal
340
convFloating (MachFloat  f) | not opt_SimplExcessPrecision =
341
   MachFloat  (toRational ((fromRational f) :: Float ))
342
convFloating (MachDouble d) | not opt_SimplExcessPrecision =
343
344
345
   MachDouble (toRational ((fromRational d) :: Double))
convFloating l = l

346

347
348
trueVal       = Var trueDataConId
falseVal      = Var falseDataConId
349
350
mkIntVal    i = Lit (mkMachInt  i)
mkWordVal   w = Lit (mkMachWord w)
351
352
mkFloatVal  f = Lit (convFloating (MachFloat  f))
mkDoubleVal d = Lit (convFloating (MachDouble d))
353
354
355
356
357
358
359
360
361
362
\end{code}

						
%************************************************************************
%*									*
\subsection{Special rules for seq, tagToEnum, dataToTag}
%*									*
%************************************************************************

\begin{code}
363
tagToEnumRule [Type ty, Lit (MachInt i)]
364
  = ASSERT( isEnumerationTyCon tycon ) 
365
    case filter correct_tag (tyConDataCons_maybe tycon `orElse` []) of
366
367
368
369


	[]	  -> Nothing	-- Abstract type
	(dc:rest) -> ASSERT( null rest )
370
		     Just (Var (dataConWorkId dc))
371
  where 
372
    correct_tag dc = (dataConTag dc - fIRST_TAG) == tag
373
374
    tag   = fromInteger i
    tycon = tyConAppTyCon ty
375
376
377
378
379
380
381
382
383
384
385

tagToEnumRule other = Nothing
\end{code}

For dataToTag#, we can reduce if either 
	
	(a) the argument is a constructor
	(b) the argument is a variable whose unfolding is a known constructor

\begin{code}
dataToTagRule [_, val_arg]
386
387
  = case exprIsConApp_maybe val_arg of
	Just (dc,_) -> ASSERT( not (isNewTyCon (dataConTyCon dc)) )
388
	     	       Just (mkIntVal (toInteger (dataConTag dc - fIRST_TAG)))
389

390
	other	    -> Nothing
391
392
393
394
395
396
397
398
399
400
401

dataToTagRule other = Nothing
\end{code}

%************************************************************************
%*									*
\subsection{Built in rules}
%*									*
%************************************************************************

\begin{code}
402
builtinRules :: [(Name, CoreRule)]
403
-- Rules for non-primops that can't be expressed using a RULE pragma
404
builtinRules
405
406
  = [ (unpackCStringFoldrName, BuiltinRule FSLIT("AppendLitString") match_append_lit),
      (eqStringName,	       BuiltinRule FSLIT("EqString") match_eq_string)
407
408
409
    ]


410
411
-- The rule is this:
-- 	unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)  =  unpackFoldrCString# "foobaz" c n
412

413
414
415
416
417
418
419
420
match_append_lit [Type ty1,
		   Lit (MachStr s1),
		   c1,
		   Var unpk `App` Type ty2 
		  	    `App` Lit (MachStr s2)
		  	    `App` c2
		  	    `App` n
		  ]
421
  | unpk `hasKey` unpackCStringFoldrIdKey && 
422
    c1 `cheapEqExpr` c2
423
  = ASSERT( ty1 `eqType` ty2 )
424
    Just (Var unpk `App` Type ty1
425
		   `App` Lit (MachStr (s1 `appendFS` s2))
426
427
428
		   `App` c1
		   `App` n)

429
430
431
match_append_lit other = Nothing

-- The rule is this:
432
-- 	eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2
433
434
435

match_eq_string [Var unpk1 `App` Lit (MachStr s1),
		 Var unpk2 `App` Lit (MachStr s2)]
436
437
  | unpk1 `hasKey` unpackCStringIdKey,
    unpk2 `hasKey` unpackCStringIdKey
438
439
440
  = Just (if s1 == s2 then trueVal else falseVal)

match_eq_string other = Nothing
441
\end{code}