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 f)  = Just (mkFloatVal (-f))
 212 negOp (MachDouble d) = Just (mkDoubleVal (-d))
 213 negOp (MachInt i)    = intResult (-i)
 214 negOp l              = Nothing
 215
 216 --------------------------
 217 intOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` i2)
 218 intOp2 op l1           l2           = Nothing           -- Could find LitLit
 219
 220 intOp2Z op (MachInt i1) (MachInt i2)
 221   | i2 /= 0 = Just (mkIntVal (i1 `op` i2))
 222 intOp2Z op l1 l2 = Nothing              -- LitLit or zero dividend
 223
 224 --------------------------
 225 #if __GLASGOW_HASKELL__ >= 500
 226 wordOp2 op (MachWord w1) (MachWord w2)
 227   = wordResult (w1 `op` w2)
 228 wordOp2 op l1 l2 = Nothing              -- Could find LitLit
 229 #endif
 230
 231 wordOp2Z op (MachWord w1) (MachWord w2)
 232   | w2 /= 0 = Just (mkWordVal (w1 `op` w2))
 233 wordOp2Z op l1 l2 = Nothing     -- LitLit or zero dividend
 234
 235 #if __GLASGOW_HASKELL__ >= 500
 236 wordBitOp2 op l1@(MachWord w1) l2@(MachWord w2)
 237   = Just (mkWordVal (w1 `op` w2))
 238 #else
 239 -- Integer is not an instance of Bits, so we operate on Word64
 240 wordBitOp2 op l1@(MachWord w1) l2@(MachWord w2)
 241   = Just (mkWordVal ((fromIntegral::Word64->Integer) (fromIntegral w1 `op` fromIntegral w2)))
 242 #endif
 243 wordBitOp2 op l1 l2 = Nothing           -- Could find LitLit
 244
 245 --------------------------
 246 floatOp2  op (MachFloat f1) (MachFloat f2)
 247   = Just (mkFloatVal (f1 `op` f2))
 248 floatOp2  op l1 l2 = Nothing
 249
 250 floatOp2Z op (MachFloat f1) (MachFloat f2)
 251   | f2 /= 0   = Just (mkFloatVal (f1 `op` f2))
 252 floatOp2Z op l1 l2 = Nothing
 253
 254 --------------------------
 255 doubleOp2  op (MachDouble f1) (MachDouble f2)
 256   = Just (mkDoubleVal (f1 `op` f2))
 257 doubleOp2 op l1 l2 = Nothing
 258
 259 doubleOp2Z op (MachDouble f1) (MachDouble f2)
 260   | f2 /= 0   = Just (mkDoubleVal (f1 `op` f2))
 261 doubleOp2Z op l1 l2 = Nothing
 262
 263
 264 --------------------------
 265         -- This stuff turns
 266         --      n ==# 3#
 267         -- into
 268         --      case n of
 269         --        3# -> True
 270         --        m  -> False
 271         --
 272         -- This is a Good Thing, because it allows case-of case things
 273         -- to happen, and case-default absorption to happen.  For
 274         -- example:
 275         --
 276         --      if (n ==# 3#) || (n ==# 4#) then e1 else e2
 277         -- will transform to
 278         --      case n of
 279         --        3# -> e1
 280         --        4# -> e1
 281         --        m  -> e2
 282         -- (modulo the usual precautions to avoid duplicating e1)
 283
 284 litEq :: Bool           -- True <=> equality, False <=> inequality
 285       -> RuleFun
 286 litEq is_eq [Lit lit, expr] = do_lit_eq is_eq lit expr
 287 litEq is_eq [expr, Lit lit] = do_lit_eq is_eq lit expr
 288 litEq is_eq other           = Nothing
 289
 290 do_lit_eq is_eq lit expr
 291   = Just (Case expr (mkWildId (literalType lit))
 292                 [(DEFAULT,    [], val_if_neq),
 293                  (LitAlt lit, [], val_if_eq)])
 294   where
 295     val_if_eq  | is_eq     = trueVal
 296                | otherwise = falseVal
 297     val_if_neq | is_eq     = falseVal
 298                | otherwise = trueVal
 299
 300 -- Note that we *don't* warn the user about overflow. It's not done at
 301 -- runtime either, and compilation of completely harmless things like
 302 --    ((124076834 :: Word32) + (2147483647 :: Word32))
 303 -- would yield a warning. Instead we simply squash the value into the
 304 -- Int range, but not in a way suitable for cross-compiling... :-(
 305 intResult :: Integer -> Maybe CoreExpr
 306 intResult result
 307   = Just (mkIntVal (toInteger (fromInteger result :: Int)))
 308
 309 #if __GLASGOW_HASKELL__ >= 500
 310 wordResult :: Integer -> Maybe CoreExpr
 311 wordResult result
 312   = Just (mkWordVal (toInteger (fromInteger result :: Word)))
 313 #endif
 314 \end{code}
 315
 316
 317 %************************************************************************
 318 %*                                                                      *
 319 \subsection{Vaguely generic functions
 320 %*                                                                      *
 321 %************************************************************************
 322
 323 \begin{code}
 324 type RuleFun = [CoreExpr] -> Maybe CoreExpr
 325
 326 twoLits :: (Literal -> Literal -> Maybe CoreExpr) -> RuleFun
 327 twoLits rule [Lit l1, Lit l2] = rule (convFloating l1) (convFloating l2)
 328 twoLits rule _                = Nothing
 329
 330 oneLit :: (Literal -> Maybe CoreExpr) -> RuleFun
 331 oneLit rule [Lit l1] = rule (convFloating l1)
 332 oneLit rule _        = Nothing
 333
 334 -- When excess precision is not requested, cut down the precision of the
 335 -- Rational value to that of Float/Double. We confuse host architecture
 336 -- and target architecture here, but it's convenient (and wrong :-).
 337 convFloating :: Literal -> Literal
 338 convFloating (MachFloat  f) | not opt_SimplExcessPrecision =
 339    MachFloat  (toRational ((fromRational f) :: Float ))
 340 convFloating (MachDouble d) | not opt_SimplExcessPrecision =
 341    MachDouble (toRational ((fromRational d) :: Double))
 342 convFloating l = l
 343
 344
 345 trueVal       = Var trueDataConId
 346 falseVal      = Var falseDataConId
 347 mkIntVal    i = Lit (mkMachInt  i)
 348 mkWordVal   w = Lit (mkMachWord w)
 349 mkFloatVal  f = Lit (convFloating (MachFloat  f))
 350 mkDoubleVal d = Lit (convFloating (MachDouble d))
 351 \end{code}
 352
 353
 354 %************************************************************************
 355 %*                                                                      *
 356 \subsection{Special rules for seq, tagToEnum, dataToTag}
 357 %*                                                                      *
 358 %************************************************************************
 359
 360 \begin{code}
 361 tagToEnumRule [Type ty, Lit (MachInt i)]
 362   = ASSERT( isEnumerationTyCon tycon )
 363     case filter correct_tag (tyConDataCons_maybe tycon `orElse` []) of
 364
 365
 366         []        -> Nothing    -- Abstract type
 367         (dc:rest) -> ASSERT( null rest )
 368                      Just (Var (dataConWorkId dc))
 369   where
 370     correct_tag dc = (dataConTag dc - fIRST_TAG) == tag
 371     tag   = fromInteger i
 372     tycon = tyConAppTyCon ty
 373
 374 tagToEnumRule other = Nothing
 375 \end{code}
 376
 377 For dataToTag#, we can reduce if either
 378
 379         (a) the argument is a constructor
 380         (b) the argument is a variable whose unfolding is a known constructor
 381
 382 \begin{code}
 383 dataToTagRule [_, val_arg]
 384   = case exprIsConApp_maybe val_arg of
 385         Just (dc,_) -> ASSERT( not (isNewTyCon (dataConTyCon dc)) )
 386                        Just (mkIntVal (toInteger (dataConTag dc - fIRST_TAG)))
 387
 388         other       -> Nothing
 389
 390 dataToTagRule other = Nothing
 391 \end{code}
 392
 393 %************************************************************************
 394 %*                                                                      *
 395 \subsection{Built in rules}
 396 %*                                                                      *
 397 %************************************************************************
 398
 399 \begin{code}
 400 builtinRules :: [(Name, CoreRule)]
 401 -- Rules for non-primops that can't be expressed using a RULE pragma
 402 builtinRules
 403   = [ (unpackCStringFoldrName, BuiltinRule FSLIT("AppendLitString") match_append_lit),
 404       (eqStringName,           BuiltinRule FSLIT("EqString") match_eq_string)
 405     ]
 406
 407
 408 -- The rule is this:
 409 --      unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)  =  unpackFoldrCString# "foobaz" c n
 410
 411 match_append_lit [Type ty1,
 412                    Lit (MachStr s1),
 413                    c1,
 414                    Var unpk `App` Type ty2
 415                             `App` Lit (MachStr s2)
 416                             `App` c2
 417                             `App` n
 418                   ]
 419   | unpk `hasKey` unpackCStringFoldrIdKey &&
 420     c1 `cheapEqExpr` c2
 421   = ASSERT( ty1 `eqType` ty2 )
 422     Just (Var unpk `App` Type ty1
 423                    `App` Lit (MachStr (s1 `appendFS` s2))
 424                    `App` c1
 425                    `App` n)
 426
 427 match_append_lit other = Nothing
 428
 429 -- The rule is this:
 430 --      eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2
 431
 432 match_eq_string [Var unpk1 `App` Lit (MachStr s1),
 433                  Var unpk2 `App` Lit (MachStr s2)]
 434   | unpk1 `hasKey` unpackCStringIdKey,
 435     unpk2 `hasKey` unpackCStringIdKey
 436   = Just (if s1 == s2 then trueVal else falseVal)
 437
 438 match_eq_string other = Nothing
 439 \end{code}