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