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