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
  16 {-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
  17
  18 module PrelRules ( primOpRules, builtinRules ) where
  19
  20 #include "HsVersions.h"
  21
  22 import CoreSyn
  23 import Id               ( mkWildId )
  24 import Literal          ( Literal(..), isLitLitLit, mkMachInt, mkMachWord
  25                         , literalType
  26                         , word2IntLit, int2WordLit
  27                         , narrow8IntLit, narrow16IntLit, narrow32IntLit
  28                         , 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        ( exprIsValue, 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 Bits             ( Bits(..) )
  45 #if __GLASGOW_HASKELL__ >= 500
  46 import Word             ( Word )
  47 #else
  48 import Word             ( Word64 )
  49 #endif
  50 import Outputable
  51 import FastString
  52 import CmdLineOpts      ( opt_SimplExcessPrecision )
  53 \end{code}
  54
  55
  56 \begin{code}
  57 primOpRules :: PrimOp -> [CoreRule]
  58 primOpRules op = primop_rule op
  59   where
  60     op_name = mkFastString (occNameUserString (primOpOcc op))
  61     op_name_case = op_name `appendFS` FSLIT("->case")
  62
  63         -- A useful shorthand
  64     one_rule rule_fn = [BuiltinRule op_name rule_fn]
  65
  66     -- ToDo:    something for integer-shift ops?
  67     --          NotOp
  68
  69     primop_rule TagToEnumOp = one_rule tagToEnumRule
  70     primop_rule DataToTagOp = one_rule dataToTagRule
  71
  72         -- Int operations
  73     primop_rule IntAddOp    = one_rule (twoLits (intOp2     (+)))
  74     primop_rule IntSubOp    = one_rule (twoLits (intOp2     (-)))
  75     primop_rule IntMulOp    = one_rule (twoLits (intOp2     (*)))
  76     primop_rule IntQuotOp   = one_rule (twoLits (intOp2Z    quot))
  77     primop_rule IntRemOp    = one_rule (twoLits (intOp2Z    rem))
  78     primop_rule IntNegOp    = one_rule (oneLit  negOp)
  79
  80         -- Word operations
  81 #if __GLASGOW_HASKELL__ >= 500
  82     primop_rule WordAddOp   = one_rule (twoLits (wordOp2    (+)))
  83     primop_rule WordSubOp   = one_rule (twoLits (wordOp2    (-)))
  84     primop_rule WordMulOp   = one_rule (twoLits (wordOp2    (*)))
  85 #endif
  86     primop_rule WordQuotOp  = one_rule (twoLits (wordOp2Z   quot))
  87     primop_rule WordRemOp   = one_rule (twoLits (wordOp2Z   rem))
  88 #if __GLASGOW_HASKELL__ >= 407
  89     primop_rule AndOp       = one_rule (twoLits (wordBitOp2 (.&.)))
  90     primop_rule OrOp        = one_rule (twoLits (wordBitOp2 (.|.)))
  91     primop_rule XorOp       = one_rule (twoLits (wordBitOp2 xor))
  92 #endif
  93
  94         -- coercions
  95     primop_rule Word2IntOp      = one_rule (oneLit (litCoerce word2IntLit))
  96     primop_rule Int2WordOp      = one_rule (oneLit (litCoerce int2WordLit))
  97     primop_rule Narrow8IntOp    = one_rule (oneLit (litCoerce narrow8IntLit))
  98     primop_rule Narrow16IntOp   = one_rule (oneLit (litCoerce narrow16IntLit))
  99     primop_rule Narrow32IntOp   = one_rule (oneLit (litCoerce narrow32IntLit))
 100     primop_rule Narrow8WordOp   = one_rule (oneLit (litCoerce narrow8WordLit))
 101     primop_rule Narrow16WordOp  = one_rule (oneLit (litCoerce narrow16WordLit))
 102     primop_rule Narrow32WordOp  = one_rule (oneLit (litCoerce narrow32WordLit))
 103     primop_rule OrdOp           = one_rule (oneLit (litCoerce char2IntLit))
 104     primop_rule ChrOp           = one_rule (oneLit (litCoerce int2CharLit))
 105     primop_rule Float2IntOp     = one_rule (oneLit (litCoerce float2IntLit))
 106     primop_rule Int2FloatOp     = one_rule (oneLit (litCoerce int2FloatLit))
 107     primop_rule Double2IntOp    = one_rule (oneLit (litCoerce double2IntLit))
 108     primop_rule Int2DoubleOp    = one_rule (oneLit (litCoerce int2DoubleLit))
 109         -- SUP: Not sure what the standard says about precision in the following 2 cases
 110     primop_rule Float2DoubleOp  = one_rule (oneLit (litCoerce float2DoubleLit))
 111     primop_rule Double2FloatOp  = one_rule (oneLit (litCoerce double2FloatLit))
 112
 113         -- Float
 114     primop_rule FloatAddOp   = one_rule (twoLits (floatOp2  (+)))
 115     primop_rule FloatSubOp   = one_rule (twoLits (floatOp2  (-)))
 116     primop_rule FloatMulOp   = one_rule (twoLits (floatOp2  (*)))
 117     primop_rule FloatDivOp   = one_rule (twoLits (floatOp2Z (/)))
 118     primop_rule FloatNegOp   = one_rule (oneLit  negOp)
 119
 120         -- Double
 121     primop_rule DoubleAddOp   = one_rule (twoLits (doubleOp2  (+)))
 122     primop_rule DoubleSubOp   = one_rule (twoLits (doubleOp2  (-)))
 123     primop_rule DoubleMulOp   = one_rule (twoLits (doubleOp2  (*)))
 124     primop_rule DoubleDivOp   = one_rule (twoLits (doubleOp2Z (/)))
 125     primop_rule DoubleNegOp   = one_rule (oneLit  negOp)
 126
 127         -- Relational operators
 128     primop_rule IntEqOp  = [BuiltinRule op_name (relop (==)), BuiltinRule op_name_case (litEq True)]
 129     primop_rule IntNeOp  = [BuiltinRule op_name (relop (/=)), BuiltinRule op_name_case (litEq False)]
 130     primop_rule CharEqOp = [BuiltinRule op_name (relop (==)), BuiltinRule op_name_case (litEq True)]
 131     primop_rule CharNeOp = [BuiltinRule op_name (relop (/=)), BuiltinRule op_name_case (litEq False)]
 132
 133     primop_rule IntGtOp         = one_rule (relop (>))
 134     primop_rule IntGeOp         = one_rule (relop (>=))
 135     primop_rule IntLeOp         = one_rule (relop (<=))
 136     primop_rule IntLtOp         = one_rule (relop (<))
 137
 138     primop_rule CharGtOp        = one_rule (relop (>))
 139     primop_rule CharGeOp        = one_rule (relop (>=))
 140     primop_rule CharLeOp        = one_rule (relop (<=))
 141     primop_rule CharLtOp        = one_rule (relop (<))
 142
 143     primop_rule FloatGtOp       = one_rule (relop (>))
 144     primop_rule FloatGeOp       = one_rule (relop (>=))
 145     primop_rule FloatLeOp       = one_rule (relop (<=))
 146     primop_rule FloatLtOp       = one_rule (relop (<))
 147     primop_rule FloatEqOp       = one_rule (relop (==))
 148     primop_rule FloatNeOp       = one_rule (relop (/=))
 149
 150     primop_rule DoubleGtOp      = one_rule (relop (>))
 151     primop_rule DoubleGeOp      = one_rule (relop (>=))
 152     primop_rule DoubleLeOp      = one_rule (relop (<=))
 153     primop_rule DoubleLtOp      = one_rule (relop (<))
 154     primop_rule DoubleEqOp      = one_rule (relop (==))
 155     primop_rule DoubleNeOp      = one_rule (relop (/=))
 156
 157     primop_rule WordGtOp        = one_rule (relop (>))
 158     primop_rule WordGeOp        = one_rule (relop (>=))
 159     primop_rule WordLeOp        = one_rule (relop (<=))
 160     primop_rule WordLtOp        = one_rule (relop (<))
 161     primop_rule WordEqOp        = one_rule (relop (==))
 162     primop_rule WordNeOp        = one_rule (relop (/=))
 163
 164     primop_rule other           = []
 165
 166
 167     relop cmp = twoLits (cmpOp (\ord -> ord `cmp` EQ))
 168         -- Cunning.  cmpOp compares the values to give an Ordering.
 169         -- It applies its argument to that ordering value to turn
 170         -- the ordering into a boolean value.  (`cmp` EQ) is just the job.
 171 \end{code}
 172
 173 %************************************************************************
 174 %*                                                                      *
 175 \subsection{Doing the business}
 176 %*                                                                      *
 177 %************************************************************************
 178
 179         IMPORTANT NOTE
 180
 181 In all these operations we might find a LitLit as an operand; that's
 182 why we have the catch-all Nothing case.
 183
 184 \begin{code}
 185 --------------------------
 186 litCoerce :: (Literal -> Literal) -> Literal -> Maybe CoreExpr
 187 litCoerce fn lit | isLitLitLit lit = Nothing
 188                  | otherwise       = Just (Lit (fn lit))
 189
 190 --------------------------
 191 cmpOp :: (Ordering -> Bool) -> Literal -> Literal -> Maybe CoreExpr
 192 cmpOp cmp l1 l2
 193   = go l1 l2
 194   where
 195     done res | cmp res   = Just trueVal
 196              | otherwise = Just falseVal
 197
 198         -- These compares are at different types
 199     go (MachChar i1)   (MachChar i2)   = done (i1 `compare` i2)
 200     go (MachInt i1)    (MachInt i2)    = done (i1 `compare` i2)
 201     go (MachInt64 i1)  (MachInt64 i2)  = done (i1 `compare` i2)
 202     go (MachWord i1)   (MachWord i2)   = done (i1 `compare` i2)
 203     go (MachWord64 i1) (MachWord64 i2) = done (i1 `compare` i2)
 204     go (MachFloat i1)  (MachFloat i2)  = done (i1 `compare` i2)
 205     go (MachDouble i1) (MachDouble i2) = done (i1 `compare` i2)
 206     go l1              l2              = Nothing
 207
 208 --------------------------
 209
 210 negOp (MachFloat f)  = Just (mkFloatVal (-f))
 211 negOp (MachDouble d) = Just (mkDoubleVal (-d))
 212 negOp (MachInt i)    = intResult (-i)
 213 negOp l              = Nothing
 214
 215 --------------------------
 216 intOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` i2)
 217 intOp2 op l1           l2           = Nothing           -- Could find LitLit
 218
 219 intOp2Z op (MachInt i1) (MachInt i2)
 220   | i2 /= 0 = Just (mkIntVal (i1 `op` i2))
 221 intOp2Z op l1 l2 = Nothing              -- LitLit or zero dividend
 222
 223 --------------------------
 224 #if __GLASGOW_HASKELL__ >= 500
 225 wordOp2 op (MachWord w1) (MachWord w2)
 226   = wordResult (w1 `op` w2)
 227 wordOp2 op l1 l2 = Nothing              -- Could find LitLit
 228 #endif
 229
 230 wordOp2Z op (MachWord w1) (MachWord w2)
 231   | w2 /= 0 = Just (mkWordVal (w1 `op` w2))
 232 wordOp2Z op l1 l2 = Nothing     -- LitLit or zero dividend
 233
 234 #if __GLASGOW_HASKELL__ >= 500
 235 wordBitOp2 op l1@(MachWord w1) l2@(MachWord w2)
 236   = Just (mkWordVal (w1 `op` w2))
 237 #else
 238 -- Integer is not an instance of Bits, so we operate on Word64
 239 wordBitOp2 op l1@(MachWord w1) l2@(MachWord w2)
 240   = Just (mkWordVal ((fromIntegral::Word64->Integer) (fromIntegral w1 `op` fromIntegral w2)))
 241 #endif
 242 wordBitOp2 op l1 l2 = Nothing           -- Could find LitLit
 243
 244 --------------------------
 245 floatOp2  op (MachFloat f1) (MachFloat f2)
 246   = Just (mkFloatVal (f1 `op` f2))
 247 floatOp2  op l1 l2 = Nothing
 248
 249 floatOp2Z op (MachFloat f1) (MachFloat f2)
 250   | f2 /= 0   = Just (mkFloatVal (f1 `op` f2))
 251 floatOp2Z op l1 l2 = Nothing
 252
 253 --------------------------
 254 doubleOp2  op (MachDouble f1) (MachDouble f2)
 255   = Just (mkDoubleVal (f1 `op` f2))
 256 doubleOp2 op l1 l2 = Nothing
 257
 258 doubleOp2Z op (MachDouble f1) (MachDouble f2)
 259   | f2 /= 0   = Just (mkDoubleVal (f1 `op` f2))
 260 doubleOp2Z op l1 l2 = Nothing
 261
 262
 263 --------------------------
 264         -- This stuff turns
 265         --      n ==# 3#
 266         -- into
 267         --      case n of
 268         --        3# -> True
 269         --        m  -> False
 270         --
 271         -- This is a Good Thing, because it allows case-of case things
 272         -- to happen, and case-default absorption to happen.  For
 273         -- example:
 274         --
 275         --      if (n ==# 3#) || (n ==# 4#) then e1 else e2
 276         -- will transform to
 277         --      case n of
 278         --        3# -> e1
 279         --        4# -> e1
 280         --        m  -> e2
 281         -- (modulo the usual precautions to avoid duplicating e1)
 282
 283 litEq :: Bool           -- True <=> equality, False <=> inequality
 284       -> RuleFun
 285 litEq is_eq [Lit lit, expr] = do_lit_eq is_eq lit expr
 286 litEq is_eq [expr, Lit lit] = do_lit_eq is_eq lit expr
 287 litEq is_eq other           = Nothing
 288
 289 do_lit_eq is_eq lit expr
 290   = Just (Case expr (mkWildId (literalType lit))
 291                 [(DEFAULT,    [], val_if_neq),
 292                  (LitAlt lit, [], val_if_eq)])
 293   where
 294     val_if_eq  | is_eq     = trueVal
 295                | otherwise = falseVal
 296     val_if_neq | is_eq     = falseVal
 297                | otherwise = trueVal
 298
 299 -- Note that we *don't* warn the user about overflow. It's not done at
 300 -- runtime either, and compilation of completely harmless things like
 301 --    ((124076834 :: Word32) + (2147483647 :: Word32))
 302 -- would yield a warning. Instead we simply squash the value into the
 303 -- Int range, but not in a way suitable for cross-compiling... :-(
 304 intResult :: Integer -> Maybe CoreExpr
 305 intResult result
 306   = Just (mkIntVal (toInteger (fromInteger result :: Int)))
 307
 308 #if __GLASGOW_HASKELL__ >= 500
 309 wordResult :: Integer -> Maybe CoreExpr
 310 wordResult result
 311   = Just (mkWordVal (toInteger (fromInteger result :: Word)))
 312 #endif
 313 \end{code}
 314
 315
 316 %************************************************************************
 317 %*                                                                      *
 318 \subsection{Vaguely generic functions
 319 %*                                                                      *
 320 %************************************************************************
 321
 322 \begin{code}
 323 type RuleFun = [CoreExpr] -> Maybe CoreExpr
 324
 325 twoLits :: (Literal -> Literal -> Maybe CoreExpr) -> RuleFun
 326 twoLits rule [Lit l1, Lit l2] = rule (convFloating l1) (convFloating l2)
 327 twoLits rule _                = Nothing
 328
 329 oneLit :: (Literal -> Maybe CoreExpr) -> RuleFun
 330 oneLit rule [Lit l1] = rule (convFloating l1)
 331 oneLit rule _        = Nothing
 332
 333 -- When excess precision is not requested, cut down the precision of the
 334 -- Rational value to that of Float/Double. We confuse host architecture
 335 -- and target architecture here, but it's convenient (and wrong :-).
 336 convFloating :: Literal -> Literal
 337 convFloating (MachFloat  f) | not opt_SimplExcessPrecision =
 338    MachFloat  (toRational ((fromRational f) :: Float ))
 339 convFloating (MachDouble d) | not opt_SimplExcessPrecision =
 340    MachDouble (toRational ((fromRational d) :: Double))
 341 convFloating l = l
 342
 343
 344 trueVal       = Var trueDataConId
 345 falseVal      = Var falseDataConId
 346 mkIntVal    i = Lit (mkMachInt  i)
 347 mkWordVal   w = Lit (mkMachWord w)
 348 mkFloatVal  f = Lit (convFloating (MachFloat  f))
 349 mkDoubleVal d = Lit (convFloating (MachDouble d))
 350 \end{code}
 351
 352
 353 %************************************************************************
 354 %*                                                                      *
 355 \subsection{Special rules for seq, tagToEnum, dataToTag}
 356 %*                                                                      *
 357 %************************************************************************
 358
 359 \begin{code}
 360 tagToEnumRule [Type ty, Lit (MachInt i)]
 361   = ASSERT( isEnumerationTyCon tycon )
 362     case filter correct_tag (tyConDataCons_maybe tycon `orElse` []) of
 363
 364
 365         []        -> Nothing    -- Abstract type
 366         (dc:rest) -> ASSERT( null rest )
 367                      Just (Var (dataConWorkId dc))
 368   where
 369     correct_tag dc = (dataConTag dc - fIRST_TAG) == tag
 370     tag   = fromInteger i
 371     tycon = tyConAppTyCon ty
 372
 373 tagToEnumRule other = Nothing
 374 \end{code}
 375
 376 For dataToTag#, we can reduce if either
 377
 378         (a) the argument is a constructor
 379         (b) the argument is a variable whose unfolding is a known constructor
 380
 381 \begin{code}
 382 dataToTagRule [_, val_arg]
 383   = case exprIsConApp_maybe val_arg of
 384         Just (dc,_) -> ASSERT( not (isNewTyCon (dataConTyCon dc)) )
 385                        Just (mkIntVal (toInteger (dataConTag dc - fIRST_TAG)))
 386
 387         other       -> Nothing
 388
 389 dataToTagRule other = Nothing
 390 \end{code}
 391
 392 %************************************************************************
 393 %*                                                                      *
 394 \subsection{Built in rules}
 395 %*                                                                      *
 396 %************************************************************************
 397
 398 \begin{code}
 399 builtinRules :: [(Name, CoreRule)]
 400 -- Rules for non-primops that can't be expressed using a RULE pragma
 401 builtinRules
 402   = [ (unpackCStringFoldrName, BuiltinRule FSLIT("AppendLitString") match_append_lit),
 403       (eqStringName,           BuiltinRule FSLIT("EqString") match_eq_string)
 404     ]
 405
 406
 407 -- The rule is this:
 408 --      unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)  =  unpackFoldrCString# "foobaz" c n
 409
 410 match_append_lit [Type ty1,
 411                    Lit (MachStr s1),
 412                    c1,
 413                    Var unpk `App` Type ty2
 414                             `App` Lit (MachStr s2)
 415                             `App` c2
 416                             `App` n
 417                   ]
 418   | unpk `hasKey` unpackCStringFoldrIdKey &&
 419     c1 `cheapEqExpr` c2
 420   = ASSERT( ty1 `eqType` ty2 )
 421     Just (Var unpk `App` Type ty1
 422                    `App` Lit (MachStr (s1 `appendFS` s2))
 423                    `App` c1
 424                    `App` n)
 425
 426 match_append_lit other = Nothing
 427
 428 -- The rule is this:
 429 --      eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2
 430
 431 match_eq_string [Var unpk1 `App` Lit (MachStr s1),
 432                  Var unpk2 `App` Lit (MachStr s2)]
 433   | unpk1 `hasKey` unpackCStringIdKey,
 434     unpk2 `hasKey` unpackCStringIdKey
 435   = Just (if s1 == s2 then trueVal else falseVal)
 436
 437 match_eq_string other = Nothing
 438 \end{code}