[project @ 2000-07-23 10:53:11 by panne]
[ghc-hetmet.git] / ghc / compiler / prelude / PrelRules.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 %
4 \section[ConFold]{Constant Folder}
5
6 Conceptually, constant folding should be parameterized with the kind
7 of target machine to get identical behaviour during compilation time
8 and runtime. We cheat a little bit here...
9
10 ToDo:
11    check boundaries before folding, e.g. we can fold the Float addition
12    (i1 + i2) only if it results in a valid Float.
13
14 \begin{code}
15 module PrelRules ( primOpRule, builtinRules ) where
16
17 #include "HsVersions.h"
18
19 import CoreSyn
20 import Id               ( mkWildId )
21 import Literal          ( Literal(..), isLitLitLit, mkMachInt, mkMachWord
22                         , inIntRange, inWordRange, literalType
23                         , word2IntLit, int2WordLit, char2IntLit, int2CharLit
24                         , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit
25                         , addr2IntLit, int2AddrLit, float2DoubleLit, double2FloatLit
26                         )
27 import RdrName          ( RdrName )
28 import PrimOp           ( PrimOp(..), primOpOcc )
29 import TysWiredIn       ( trueDataConId, falseDataConId )
30 import TyCon            ( tyConDataConsIfAvailable, isEnumerationTyCon, isNewTyCon )
31 import DataCon          ( dataConTag, dataConTyCon, dataConId, fIRST_TAG )
32 import CoreUtils        ( exprIsValue, cheapEqExpr, exprIsConApp_maybe )
33 import Type             ( splitTyConApp_maybe )
34 import OccName          ( occNameUserString)
35 import PrelNames        ( unpackCStringFoldr_RDR )
36 import Unique           ( unpackCStringFoldrIdKey, hasKey )
37 import Bits             ( Bits(..) )
38 import Word             ( Word64 )
39 import Outputable
40 import CmdLineOpts      ( opt_SimplExcessPrecision )
41 \end{code}
42
43
44 \begin{code}
45 primOpRule :: PrimOp -> CoreRule
46 primOpRule op 
47   = BuiltinRule (primop_rule op)
48   where
49     op_name = _PK_ (occNameUserString (primOpOcc op))
50     op_name_case = op_name _APPEND_ SLIT("->case")
51
52     -- ToDo:    something for integer-shift ops?
53     --          NotOp
54
55     primop_rule SeqOp       = seqRule
56     primop_rule TagToEnumOp = tagToEnumRule
57     primop_rule DataToTagOp = dataToTagRule
58
59         -- Int operations
60     primop_rule IntAddOp    = twoLits (intOp2  (+)  op_name)
61     primop_rule IntSubOp    = twoLits (intOp2  (-)  op_name)
62     primop_rule IntMulOp    = twoLits (intOp2  (*)  op_name)
63     primop_rule IntQuotOp   = twoLits (intOp2Z quot op_name)
64     primop_rule IntRemOp    = twoLits (intOp2Z rem  op_name)
65     primop_rule IntNegOp    = oneLit  (negOp        op_name)
66
67         -- Word operations
68     primop_rule WordQuotOp  = twoLits (wordOp2Z   quot  op_name)
69     primop_rule WordRemOp   = twoLits (wordOp2Z   rem   op_name)
70 #if __GLASGOW_HASKELL__ >= 407
71     primop_rule AndOp       = twoLits (wordBitOp2 (.&.) op_name)
72     primop_rule OrOp        = twoLits (wordBitOp2 (.|.) op_name)
73     primop_rule XorOp       = twoLits (wordBitOp2 xor   op_name)
74 #endif
75
76         -- coercions
77     primop_rule Word2IntOp      = oneLit (litCoerce word2IntLit     op_name)
78     primop_rule Int2WordOp      = oneLit (litCoerce int2WordLit     op_name)
79     primop_rule OrdOp           = oneLit (litCoerce char2IntLit     op_name)
80     primop_rule ChrOp           = oneLit (litCoerce int2CharLit     op_name)
81     primop_rule Float2IntOp     = oneLit (litCoerce float2IntLit    op_name)
82     primop_rule Int2FloatOp     = oneLit (litCoerce int2FloatLit    op_name)
83     primop_rule Double2IntOp    = oneLit (litCoerce double2IntLit   op_name)
84     primop_rule Int2DoubleOp    = oneLit (litCoerce int2DoubleLit   op_name)
85     primop_rule Addr2IntOp      = oneLit (litCoerce addr2IntLit     op_name)
86     primop_rule Int2AddrOp      = oneLit (litCoerce int2AddrLit     op_name)
87         -- SUP: Not sure what the standard says about precision in the following 2 cases
88     primop_rule Float2DoubleOp  = oneLit (litCoerce float2DoubleLit op_name)
89     primop_rule Double2FloatOp  = oneLit (litCoerce double2FloatLit op_name)
90
91         -- Float
92     primop_rule FloatAddOp   = twoLits (floatOp2 (+) op_name)
93     primop_rule FloatSubOp   = twoLits (floatOp2 (-) op_name)
94     primop_rule FloatMulOp   = twoLits (floatOp2 (*) op_name)
95     primop_rule FloatDivOp   = twoLits (floatOp2Z (/) op_name)
96     primop_rule FloatNegOp   = oneLit  (negOp op_name)
97
98         -- Double
99     primop_rule DoubleAddOp   = twoLits (doubleOp2 (+) op_name)
100     primop_rule DoubleSubOp   = twoLits (doubleOp2 (-) op_name)
101     primop_rule DoubleMulOp   = twoLits (doubleOp2 (*) op_name)
102     primop_rule DoubleDivOp   = twoLits (doubleOp2Z (/) op_name)
103     primop_rule DoubleNegOp   = oneLit  (negOp op_name)
104
105         -- Relational operators
106     primop_rule IntEqOp  = relop (==) `or_rule` litEq True  op_name_case
107     primop_rule IntNeOp  = relop (/=) `or_rule` litEq False op_name_case
108     primop_rule CharEqOp = relop (==) `or_rule` litEq True  op_name_case
109     primop_rule CharNeOp = relop (/=) `or_rule` litEq False op_name_case
110
111     primop_rule IntGtOp         = relop (>) 
112     primop_rule IntGeOp         = relop (>=)
113     primop_rule IntLeOp         = relop (<=)
114     primop_rule IntLtOp         = relop (<) 
115                                             
116     primop_rule CharGtOp        = relop (>) 
117     primop_rule CharGeOp        = relop (>=)
118     primop_rule CharLeOp        = relop (<=)
119     primop_rule CharLtOp        = relop (<) 
120                                             
121     primop_rule FloatGtOp       = relop (>) 
122     primop_rule FloatGeOp       = relop (>=)
123     primop_rule FloatLeOp       = relop (<=)
124     primop_rule FloatLtOp       = relop (<) 
125     primop_rule FloatEqOp       = relop (==)
126     primop_rule FloatNeOp       = relop (/=)
127                                             
128     primop_rule DoubleGtOp      = relop (>) 
129     primop_rule DoubleGeOp      = relop (>=)
130     primop_rule DoubleLeOp      = relop (<=)
131     primop_rule DoubleLtOp      = relop (<) 
132     primop_rule DoubleEqOp      = relop (==)
133     primop_rule DoubleNeOp      = relop (/=)
134                                             
135     primop_rule WordGtOp        = relop (>) 
136     primop_rule WordGeOp        = relop (>=)
137     primop_rule WordLeOp        = relop (<=)
138     primop_rule WordLtOp        = relop (<) 
139     primop_rule WordEqOp        = relop (==)
140     primop_rule WordNeOp        = relop (/=)
141
142     primop_rule other           = \args -> Nothing
143
144
145     relop cmp = twoLits (cmpOp (\ord -> ord `cmp` EQ) op_name)
146         -- Cunning.  cmpOp compares the values to give an Ordering.
147         -- It applies its argument to that ordering value to turn
148         -- the ordering into a boolean value.  (`cmp` EQ) is just the job.
149 \end{code}
150
151 %************************************************************************
152 %*                                                                      *
153 \subsection{Doing the business}
154 %*                                                                      *
155 %************************************************************************
156
157         IMPORTANT NOTE
158
159 In all these operations we might find a LitLit as an operand; that's
160 why we have the catch-all Nothing case.
161
162 \begin{code}
163 --------------------------
164 litCoerce :: (Literal -> Literal) -> RuleName -> Literal -> Maybe (RuleName, CoreExpr)
165 litCoerce fn name lit | isLitLitLit lit = Nothing
166                       | otherwise       = Just (name, Lit (fn lit))
167
168 --------------------------
169 cmpOp :: (Ordering -> Bool) -> FAST_STRING -> Literal -> Literal -> Maybe (RuleName, CoreExpr)
170 cmpOp cmp name l1 l2
171   = go l1 l2
172   where
173     done res | cmp res = Just (name, trueVal)
174              | otherwise    = Just (name, falseVal)
175
176         -- These compares are at different types
177     go (MachChar i1)   (MachChar i2)   = done (i1 `compare` i2)
178     go (MachInt i1)    (MachInt i2)    = done (i1 `compare` i2)
179     go (MachInt64 i1)  (MachInt64 i2)  = done (i1 `compare` i2)
180     go (MachWord i1)   (MachWord i2)   = done (i1 `compare` i2)
181     go (MachWord64 i1) (MachWord64 i2) = done (i1 `compare` i2)
182     go (MachFloat i1)  (MachFloat i2)  = done (i1 `compare` i2)
183     go (MachDouble i1) (MachDouble i2) = done (i1 `compare` i2)
184     go l1              l2              = Nothing
185
186 --------------------------
187
188 negOp name (MachFloat f)  = Just (name, mkFloatVal (-f))
189 negOp name (MachDouble d) = Just (name, mkDoubleVal (-d))
190 negOp name l@(MachInt i)  = intResult name (-i)
191 negOp name l              = Nothing
192
193 --------------------------
194 intOp2 op name l1@(MachInt i1) l2@(MachInt i2)
195   = intResult name (i1 `op` i2)
196 intOp2 op name l1 l2 = Nothing          -- Could find LitLit
197
198 intOp2Z op name (MachInt i1) (MachInt i2)
199   | i2 /= 0 = Just (name, mkIntVal (i1 `op` i2))
200 intOp2Z op name l1 l2 = Nothing         -- LitLit or zero dividend
201
202 --------------------------
203 -- Integer is not an instance of Bits, so we operate on Word64
204 wordBitOp2 op name l1@(MachWord w1) l2@(MachWord w2)
205   = Just (name, mkWordVal ((fromIntegral::Word64->Integer) (fromIntegral w1 `op` fromIntegral w2)))
206 wordBitOp2 op name l1 l2 = Nothing              -- Could find LitLit
207
208 wordOp2Z op name (MachWord w1) (MachWord w2)
209   | w2 /= 0 = Just (name, mkWordVal (w1 `op` w2))
210 wordOp2Z op name l1 l2 = Nothing        -- LitLit or zero dividend
211
212 --------------------------
213 floatOp2  op name (MachFloat f1) (MachFloat f2)
214   = Just (name, mkFloatVal (f1 `op` f2))
215 floatOp2  op name l1 l2 = Nothing
216
217 floatOp2Z op name (MachFloat f1) (MachFloat f2)
218   | f2 /= 0   = Just (name, mkFloatVal (f1 `op` f2))
219 floatOp2Z op name l1 l2 = Nothing
220
221 --------------------------
222 doubleOp2  op name (MachDouble f1) (MachDouble f2)
223   = Just (name, mkDoubleVal (f1 `op` f2))
224 doubleOp2 op name l1 l2 = Nothing
225
226 doubleOp2Z op name (MachDouble f1) (MachDouble f2)
227   | f2 /= 0   = Just (name, mkDoubleVal (f1 `op` f2))
228 doubleOp2Z op name l1 l2 = Nothing
229
230
231 --------------------------
232         -- This stuff turns
233         --      n ==# 3#
234         -- into
235         --      case n of
236         --        3# -> True
237         --        m  -> False
238         --
239         -- This is a Good Thing, because it allows case-of case things
240         -- to happen, and case-default absorption to happen.  For
241         -- example:
242         --
243         --      if (n ==# 3#) || (n ==# 4#) then e1 else e2
244         -- will transform to
245         --      case n of
246         --        3# -> e1
247         --        4# -> e1
248         --        m  -> e2
249         -- (modulo the usual precautions to avoid duplicating e1)
250
251 litEq :: Bool           -- True <=> equality, False <=> inequality
252         -> RuleName
253         -> RuleFun
254 litEq is_eq name [Lit lit, expr] = do_lit_eq is_eq name lit expr
255 litEq is_eq name [expr, Lit lit] = do_lit_eq is_eq name lit expr
256 litEq is_eq name other           = Nothing
257
258 do_lit_eq is_eq name lit expr
259   = Just (name, Case expr (mkWildId (literalType lit))
260                      [(LitAlt lit, [], val_if_eq),
261                       (DEFAULT,    [], val_if_neq)])
262   where
263     val_if_eq  | is_eq     = trueVal
264                | otherwise = falseVal
265     val_if_neq | is_eq     = falseVal
266                | otherwise = trueVal
267
268 -- Note that we *don't* warn the user about overflow. It's not done at
269 -- runtime either, and compilation of completely harmless things like
270 --    ((124076834 :: Word32) + (2147483647 :: Word32))
271 -- would yield a warning. Instead we simply squash the value into the
272 -- Int range, but not in a way suitable for cross-compiling... :-(
273 intResult :: RuleName -> Integer -> Maybe (RuleName, CoreExpr)
274 intResult name result
275   = Just (name, mkIntVal (toInteger ((fromInteger result)::Int)))
276 \end{code}
277
278
279 %************************************************************************
280 %*                                                                      *
281 \subsection{Vaguely generic functions
282 %*                                                                      *
283 %************************************************************************
284
285 \begin{code}
286 type RuleFun = [CoreExpr] -> Maybe (RuleName, CoreExpr)
287
288 or_rule :: RuleFun -> RuleFun -> RuleFun
289 or_rule r1 r2 args = maybe (r2 args) Just (r1 args) -- i.e.: r1 args `mplus` r2 args
290
291 twoLits :: (Literal -> Literal -> Maybe (RuleName, CoreExpr)) -> RuleFun
292 twoLits rule [Lit l1, Lit l2] = rule (convFloating l1) (convFloating l2)
293 twoLits rule other            = Nothing
294
295 oneLit :: (Literal -> Maybe (RuleName, CoreExpr)) -> RuleFun
296 oneLit rule [Lit l1] = rule (convFloating l1)
297 oneLit rule other    = Nothing
298
299 -- When excess precision is not requested, cut down the precision of the
300 -- Rational value to that of Float/Double. We confuse host architecture
301 -- and target architecture here, but it's convenient (and wrong :-).
302 convFloating :: Literal -> Literal
303 convFloating (MachFloat  f) | not opt_SimplExcessPrecision =
304    MachFloat  (toRational ((fromRational f) :: Float ))
305 convFloating (MachDouble d) | not opt_SimplExcessPrecision =
306    MachDouble (toRational ((fromRational d) :: Double))
307 convFloating l = l
308
309
310 trueVal       = Var trueDataConId
311 falseVal      = Var falseDataConId
312 mkIntVal    i = Lit (mkMachInt  i)
313 mkWordVal   w = Lit (mkMachWord w)
314 mkCharVal   c = Lit (MachChar   c)
315 mkFloatVal  f = Lit (convFloating (MachFloat  f))
316 mkDoubleVal d = Lit (convFloating (MachDouble d))
317 \end{code}
318
319                                                 
320 %************************************************************************
321 %*                                                                      *
322 \subsection{Special rules for seq, tagToEnum, dataToTag}
323 %*                                                                      *
324 %************************************************************************
325
326 In the parallel world, we use _seq_ to control the order in which
327 certain expressions will be evaluated.  Operationally, the expression
328 ``_seq_ a b'' evaluates a and then evaluates b.  We have an inlining
329 for _seq_ which translates _seq_ to:
330
331    _seq_ = /\ a b -> \ x::a y::b -> case seq# x of { 0# -> parError#; _ -> y }
332
333 Now, we know that the seq# primitive will never return 0#, but we
334 don't let the simplifier know that.  We also use a special error
335 value, parError#, which is *not* a bottoming Id, so as far as the
336 simplifier is concerned, we have to evaluate seq# a before we know
337 whether or not y will be evaluated.
338
339 If we didn't have the extra case, then after inlining the compiler might
340 see:
341         f p q = case seq# p of { _ -> p+q }
342
343 If it sees that, it can see that f is strict in q, and hence it might
344 evaluate q before p!  The "0# ->" case prevents this happening.
345 By having the parError# branch we make sure that anything in the
346 other branch stays there!
347
348 This is fine, but we'd like to get rid of the extraneous code.  Hence,
349 we *do* let the simplifier know that seq# is strict in its argument.
350 As a result, we hope that `a' will be evaluated before seq# is called.
351 At this point, we have a very special and magical simpification which
352 says that ``seq# a'' can be immediately simplified to `1#' if we
353 know that `a' is already evaluated.
354
355 NB: If we ever do case-floating, we have an extra worry:
356
357     case a of
358       a' -> let b' = case seq# a of { True -> b; False -> parError# }
359             in case b' of ...
360
361     =>
362
363     case a of
364       a' -> let b' = case True of { True -> b; False -> parError# }
365             in case b' of ...
366
367     =>
368
369     case a of
370       a' -> let b' = b
371             in case b' of ...
372
373     =>
374
375     case a of
376       a' -> case b of ...
377
378 The second case must never be floated outside of the first!
379
380 \begin{code}
381 seqRule [Type ty, arg] | exprIsValue arg = Just (SLIT("Seq"), mkIntVal 1)
382 seqRule other                            = Nothing
383 \end{code}
384
385
386 \begin{code}
387 tagToEnumRule [Type ty, Lit (MachInt i)]
388   = ASSERT( isEnumerationTyCon tycon ) 
389     case filter correct_tag (tyConDataConsIfAvailable tycon) of
390
391
392         []        -> Nothing    -- Abstract type
393         (dc:rest) -> ASSERT( null rest )
394                      Just (SLIT("TagToEnum"), Var (dataConId dc))
395   where 
396     correct_tag dc = (dataConTag dc - fIRST_TAG) == tag
397     tag = fromInteger i
398     (Just (tycon,_)) = splitTyConApp_maybe ty
399
400 tagToEnumRule other = Nothing
401 \end{code}
402
403 For dataToTag#, we can reduce if either 
404         
405         (a) the argument is a constructor
406         (b) the argument is a variable whose unfolding is a known constructor
407
408 \begin{code}
409 dataToTagRule [_, val_arg]
410   = case exprIsConApp_maybe val_arg of
411         Just (dc,_) -> ASSERT( not (isNewTyCon (dataConTyCon dc)) )
412                        Just (SLIT("DataToTag"), 
413                              mkIntVal (toInteger (dataConTag dc - fIRST_TAG)))
414
415         other       -> Nothing
416
417 dataToTagRule other = Nothing
418 \end{code}
419
420 %************************************************************************
421 %*                                                                      *
422 \subsection{Built in rules}
423 %*                                                                      *
424 %************************************************************************
425
426 \begin{code}
427 builtinRules :: [(RdrName, CoreRule)]
428 -- Rules for non-primops that can't be expressed using a RULE pragma
429 builtinRules
430   = [ (unpackCStringFoldr_RDR, BuiltinRule match_append_lit_str)
431     ]
432
433
434 -- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)  =  unpackFoldrCString# "foobaz" c n
435
436 match_append_lit_str [Type ty1,
437                       Lit (MachStr s1),
438                       c1,
439                       Var unpk `App` Type ty2 
440                                `App` Lit (MachStr s2)
441                                `App` c2
442                                `App` n
443                      ]
444   | unpk `hasKey` unpackCStringFoldrIdKey && 
445     c1 `cheapEqExpr` c2
446   = ASSERT( ty1 == ty2 )
447     Just (SLIT("AppendLitString"),
448           Var unpk `App` Type ty1
449                    `App` Lit (MachStr (s1 _APPEND_ s2))
450                    `App` c1
451                    `App` n)
452
453 match_append_lit_str other = Nothing
454 \end{code}