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