PrelRules: Handle Int left shifts of more than word-size bits
[ghc.git] / compiler / prelude / PrelRules.hs
index 2b1bf76..810fd2b 100644 (file)
@@ -25,18 +25,21 @@ where
 #include "HsVersions.h"
 #include "../includes/MachDeps.h"
 
+import GhcPrelude
+
 import {-# SOURCE #-} MkId ( mkPrimOpId, magicDictId )
 
 import CoreSyn
 import MkCore
 import Id
 import Literal
-import CoreSubst   ( exprIsLiteral_maybe )
+import CoreOpt     ( exprIsLiteral_maybe )
 import PrimOp      ( PrimOp(..), tagToEnumKey )
 import TysWiredIn
 import TysPrim
-import TyCon       ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon, unwrapNewTyCon_maybe )
-import DataCon     ( dataConTag, dataConTyCon, dataConWorkId )
+import TyCon       ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon
+                   , unwrapNewTyCon_maybe, tyConDataCons )
+import DataCon     ( DataCon, dataConTagZ, dataConTyCon, dataConWorkId )
 import CoreUtils   ( cheapEqExpr, exprIsHNF )
 import CoreUnfold  ( exprIsConApp_maybe )
 import Type
@@ -55,9 +58,7 @@ import Coercion     (mkUnbranchedAxInstCo,mkSymCo,Role(..))
 import Control.Applicative ( Alternative(..) )
 
 import Control.Monad
-#if __GLASGOW_HASKELL__ > 710
 import qualified Control.Monad.Fail as MonadFail
-#endif
 import Data.Bits as Bits
 import qualified Data.ByteString as BS
 import Data.Int
@@ -121,11 +122,11 @@ primOpRules nm NotIOp      = mkPrimOpRule nm 1 [ unaryLit complementOp
                                                , inversePrimOp NotIOp ]
 primOpRules nm IntNegOp    = mkPrimOpRule nm 1 [ unaryLit negOp
                                                , inversePrimOp IntNegOp ]
-primOpRules nm ISllOp      = mkPrimOpRule nm 2 [ binaryLit (intOp2 Bits.shiftL)
+primOpRules nm ISllOp      = mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftL)
                                                , rightIdentityDynFlags zeroi ]
-primOpRules nm ISraOp      = mkPrimOpRule nm 2 [ binaryLit (intOp2 Bits.shiftR)
+primOpRules nm ISraOp      = mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftR)
                                                , rightIdentityDynFlags zeroi ]
-primOpRules nm ISrlOp      = mkPrimOpRule nm 2 [ binaryLit (intOp2' shiftRightLogical)
+primOpRules nm ISrlOp      = mkPrimOpRule nm 2 [ shiftRule shiftRightLogical
                                                , rightIdentityDynFlags zeroi ]
 
 -- Word operations
@@ -156,8 +157,8 @@ primOpRules nm XorOp       = mkPrimOpRule nm 2 [ binaryLit (wordOp2 xor)
                                                , equalArgs >> retLit zerow ]
 primOpRules nm NotOp       = mkPrimOpRule nm 1 [ unaryLit complementOp
                                                , inversePrimOp NotOp ]
-primOpRules nm SllOp       = mkPrimOpRule nm 2 [ wordShiftRule (const Bits.shiftL) ]
-primOpRules nm SrlOp       = mkPrimOpRule nm 2 [ wordShiftRule shiftRightLogical ]
+primOpRules nm SllOp       = mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftL) ]
+primOpRules nm SrlOp       = mkPrimOpRule nm 2 [ shiftRule shiftRightLogical ]
 
 -- coercions
 primOpRules nm Word2IntOp     = mkPrimOpRule nm 1 [ liftLitDynFlags word2IntLit
@@ -418,10 +419,10 @@ wordOp2 op dflags (MachWord w1) (MachWord w2)
     = wordResult dflags (fromInteger w1 `op` fromInteger w2)
 wordOp2 _ _ _ _ = Nothing  -- Could find LitLit
 
-wordShiftRule :: (DynFlags -> Integer -> Int -> Integer) -> RuleM CoreExpr
+shiftRule :: (DynFlags -> Integer -> Int -> Integer) -> RuleM CoreExpr
                  -- Shifts take an Int; hence third arg of op is Int
 -- See Note [Guarding against silly shifts]
-wordShiftRule shift_op
+shiftRule shift_op
   = do { dflags <- getDynFlags
        ; [e1, Lit (MachInt shift_len)] <- getArgs
        ; case e1 of
@@ -430,10 +431,16 @@ wordShiftRule shift_op
              | shift_len < 0 || wordSizeInBits dflags < shift_len
              -> return (mkRuntimeErrorApp rUNTIME_ERROR_ID wordPrimTy
                                         ("Bad shift length" ++ show shift_len))
+
+           -- Do the shift at type Integer, but shift length is Int
+           Lit (MachInt x)
+             -> let op = shift_op dflags
+                in  liftMaybe $ intResult dflags (x `op` fromInteger shift_len)
+
            Lit (MachWord x)
              -> let op = shift_op dflags
                 in  liftMaybe $ wordResult dflags (x `op` fromInteger shift_len)
-                    -- Do the shift at type Integer, but shift length is Int
+
            _ -> mzero }
 
 wordSizeInBits :: DynFlags -> Integer
@@ -538,51 +545,15 @@ isMaxBound dflags (MachWord i)   = i == tARGET_MAX_WORD dflags
 isMaxBound _      (MachWord64 i) = i == toInteger (maxBound :: Word64)
 isMaxBound _      _              = False
 
-
--- Note [Word/Int underflow/overflow]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
---
--- According to the Haskell Report 2010 (Sections 18.1 and 23.1 about signed and
--- unsigned integral types): "All arithmetic is performed modulo 2^n, where n is
--- the number of bits in the type."
---
--- GHC stores Word# and Int# constant values as Integer. Core optimizations such
--- as constant folding must ensure that the Integer value remains in the valid
--- target Word/Int range (see #13172). The following functions are used to
--- ensure this.
---
--- Note that we *don't* warn the user about overflow. It's not done at runtime
--- either, and compilation of completely harmless things like
---    ((124076834 :: Word32) + (2147483647 :: Word32))
--- doesn't yield a warning. Instead we simply squash the value into the *target*
--- Int/Word range.
-
--- | Ensure the given Integer is in the target Int range
-intResult' :: DynFlags -> Integer -> Integer
-intResult' dflags result = case platformWordSize (targetPlatform dflags) of
-   4 -> toInteger (fromInteger result :: Int32)
-   8 -> toInteger (fromInteger result :: Int64)
-   w -> panic ("intResult: Unknown platformWordSize: " ++ show w)
-
--- | Ensure the given Integer is in the target Word range
-wordResult' :: DynFlags -> Integer -> Integer
-wordResult' dflags result = case platformWordSize (targetPlatform dflags) of
-   4 -> toInteger (fromInteger result :: Word32)
-   8 -> toInteger (fromInteger result :: Word64)
-   w -> panic ("wordResult: Unknown platformWordSize: " ++ show w)
-
 -- | Create an Int literal expression while ensuring the given Integer is in the
 -- target Int range
 intResult :: DynFlags -> Integer -> Maybe CoreExpr
-intResult dflags result = Just (mkIntVal dflags (intResult' dflags result))
+intResult dflags result = Just (Lit (mkMachIntWrap dflags result))
 
 -- | Create a Word literal expression while ensuring the given Integer is in the
 -- target Word range
 wordResult :: DynFlags -> Integer -> Maybe CoreExpr
-wordResult dflags result = Just (mkWordVal dflags (wordResult' dflags result))
-
-
-
+wordResult dflags result = Just (Lit (mkMachWordWrap dflags result))
 
 inversePrimOp :: PrimOp -> RuleM CoreExpr
 inversePrimOp primop = do
@@ -684,12 +655,10 @@ instance Monad RuleM where
   RuleM f >>= g = RuleM $ \dflags iu e -> case f dflags iu e of
     Nothing -> Nothing
     Just r -> runRuleM (g r) dflags iu e
-  fail _ = mzero
+  fail = MonadFail.fail
 
-#if __GLASGOW_HASKELL__ > 710
 instance MonadFail.MonadFail RuleM where
     fail _ = mzero
-#endif
 
 instance Alternative RuleM where
   empty = RuleM $ \_ _ _ -> Nothing
@@ -872,8 +841,6 @@ gtVal = Var gtDataConId
 
 mkIntVal :: DynFlags -> Integer -> Expr CoreBndr
 mkIntVal dflags i = Lit (mkMachInt dflags i)
-mkWordVal :: DynFlags -> Integer -> Expr CoreBndr
-mkWordVal dflags w = Lit (mkMachWord dflags w)
 mkFloatVal :: DynFlags -> Rational -> Expr CoreBndr
 mkFloatVal dflags f = Lit (convFloating dflags (MachFloat  f))
 mkDoubleVal :: DynFlags -> Rational -> Expr CoreBndr
@@ -921,7 +888,7 @@ tagToEnumRule = do
   case splitTyConApp_maybe ty of
     Just (tycon, tc_args) | isEnumerationTyCon tycon -> do
       let tag = fromInteger i
-          correct_tag dc = (dataConTag dc - fIRST_TAG) == tag
+          correct_tag dc = (dataConTagZ dc) == tag
       (dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` [])
       ASSERT(null rest) return ()
       return $ mkTyApps (Var (dataConWorkId dc)) tc_args
@@ -951,7 +918,7 @@ dataToTagRule = a `mplus` b
       in_scope <- getInScopeEnv
       (dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg
       ASSERT( not (isNewTyCon (dataConTyCon dc)) ) return ()
-      return $ mkIntVal dflags (toInteger (dataConTag dc - fIRST_TAG))
+      return $ mkIntVal dflags (toInteger (dataConTagZ dc))
 
 {-
 ************************************************************************
@@ -1041,6 +1008,9 @@ builtinRules
         ]
      ]
  ++ builtinIntegerRules
+{-# NOINLINE builtinRules #-}
+-- there is no benefit to inlining these yet, despite this, GHC produces
+-- unfoldings for this regardless since the floated list entries look small.
 
 builtinIntegerRules :: [CoreRule]
 builtinIntegerRules =
@@ -1183,7 +1153,7 @@ match_append_lit _ _ _ _ = Nothing
 
 ---------------------------------------------------
 -- The rule is this:
---      eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2
+--      eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2)) = s1==s2
 
 match_eq_string :: RuleFun
 match_eq_string _ id_unf _
@@ -1432,46 +1402,150 @@ match_smallIntegerTo _ _ _ _ _ = Nothing
 
 -- | Match the scrutinee of a case and potentially return a new scrutinee and a
 -- function to apply to each literal alternative.
-caseRules :: DynFlags -> CoreExpr -> Maybe (CoreExpr, Integer -> Integer)
-caseRules dflags scrut = case scrut of
-
-   -- We need to call wordResult' and intResult' to ensure that the literal
-   -- alternatives remain in Word/Int target ranges (cf Note [Word/Int
-   -- underflow/overflow] and #13172).
-
-   -- v `op` x#
-   App (App (Var f) v) (Lit l)
-      | Just op <- isPrimOpId_maybe f
-      , Just x  <- isLitValue_maybe l ->
-      case op of
-         WordAddOp -> Just (v, \y -> wordResult' dflags $ y-x      )
-         IntAddOp  -> Just (v, \y -> intResult'  dflags $ y-x      )
-         WordSubOp -> Just (v, \y -> wordResult' dflags $ y+x      )
-         IntSubOp  -> Just (v, \y -> intResult'  dflags $ y+x      )
-         XorOp     -> Just (v, \y -> wordResult' dflags $ y `xor` x)
-         XorIOp    -> Just (v, \y -> intResult'  dflags $ y `xor` x)
+caseRules :: DynFlags
+          -> CoreExpr                    -- Scrutinee
+          -> Maybe ( CoreExpr            -- New scrutinee
+                   , AltCon -> AltCon    -- How to fix up the alt pattern
+                   , Id -> CoreExpr)     -- How to reconstruct the original scrutinee
+                                         -- from the new case-binder
+-- e.g  case e of b {
+--         ...;
+--         con bs -> rhs;
+--         ... }
+--  ==>
+--      case e' of b' {
+--         ...;
+--         fixup_altcon[con] bs -> let b = mk_orig[b] in rhs;
+--         ... }
+
+caseRules dflags (App (App (Var f) v) (Lit l))   -- v `op` x#
+  | Just op <- isPrimOpId_maybe f
+  , Just x  <- isLitValue_maybe l
+  , Just adjust_lit <- adjustDyadicRight op x
+  = Just (v, tx_lit_con dflags adjust_lit
+           , \v -> (App (App (Var f) (Var v)) (Lit l)))
+
+caseRules dflags (App (App (Var f) (Lit l)) v)   -- x# `op` v
+  | Just op <- isPrimOpId_maybe f
+  , Just x  <- isLitValue_maybe l
+  , Just adjust_lit <- adjustDyadicLeft x op
+  = Just (v, tx_lit_con dflags adjust_lit
+           , \v -> (App (App (Var f) (Lit l)) (Var v)))
+
+
+caseRules dflags (App (Var f) v              )   -- op v
+  | Just op <- isPrimOpId_maybe f
+  , Just adjust_lit <- adjustUnary op
+  = Just (v, tx_lit_con dflags adjust_lit
+           , \v -> App (Var f) (Var v))
+
+-- See Note [caseRules for tagToEnum]
+caseRules dflags (App (App (Var f) type_arg) v)
+  | Just TagToEnumOp <- isPrimOpId_maybe f
+  = Just (v, tx_con_tte dflags
+           , \v -> (App (App (Var f) type_arg) (Var v)))
+
+-- See Note [caseRules for dataToTag]
+caseRules _ (App (App (Var f) (Type ty)) v)       -- dataToTag x
+  | Just DataToTagOp <- isPrimOpId_maybe f
+  = Just (v, tx_con_dtt ty
+           , \v -> App (App (Var f) (Type ty)) (Var v))
+
+caseRules _ _ = Nothing
+
+
+tx_lit_con :: DynFlags -> (Integer -> Integer) -> AltCon -> AltCon
+tx_lit_con _      _      DEFAULT    = DEFAULT
+tx_lit_con dflags adjust (LitAlt l) = LitAlt (mapLitValue dflags adjust l)
+tx_lit_con _      _      alt        = pprPanic "caseRules" (ppr alt)
+   -- NB: mapLitValue uses mkMachIntWrap etc, to ensure that the
+   -- literal alternatives remain in Word/Int target ranges
+   -- (See Note [Word/Int underflow/overflow] in Literal and #13172).
+
+adjustDyadicRight :: PrimOp -> Integer -> Maybe (Integer -> Integer)
+-- Given (x `op` lit) return a function 'f' s.t.  f (x `op` lit) = x
+adjustDyadicRight op lit
+  = case op of
+         WordAddOp -> Just (\y -> y-lit      )
+         IntAddOp  -> Just (\y -> y-lit      )
+         WordSubOp -> Just (\y -> y+lit      )
+         IntSubOp  -> Just (\y -> y+lit      )
+         XorOp     -> Just (\y -> y `xor` lit)
+         XorIOp    -> Just (\y -> y `xor` lit)
          _         -> Nothing
 
-   -- x# `op` v
-   App (App (Var f) (Lit l)) v
-      | Just op <- isPrimOpId_maybe f
-      , Just x  <- isLitValue_maybe l ->
-      case op of
-         WordAddOp -> Just (v, \y -> wordResult' dflags $ y-x      )
-         IntAddOp  -> Just (v, \y -> intResult'  dflags $ y-x      )
-         WordSubOp -> Just (v, \y -> wordResult' dflags $ x-y      )
-         IntSubOp  -> Just (v, \y -> intResult'  dflags $ x-y      )
-         XorOp     -> Just (v, \y -> wordResult' dflags $ y `xor` x)
-         XorIOp    -> Just (v, \y -> intResult'  dflags $ y `xor` x)
+adjustDyadicLeft :: Integer -> PrimOp -> Maybe (Integer -> Integer)
+-- Given (lit `op` x) return a function 'f' s.t.  f (lit `op` x) = x
+adjustDyadicLeft lit op
+  = case op of
+         WordAddOp -> Just (\y -> y-lit      )
+         IntAddOp  -> Just (\y -> y-lit      )
+         WordSubOp -> Just (\y -> lit-y      )
+         IntSubOp  -> Just (\y -> lit-y      )
+         XorOp     -> Just (\y -> y `xor` lit)
+         XorIOp    -> Just (\y -> y `xor` lit)
          _         -> Nothing
 
-   -- op v
-   App (Var f) v
-      | Just op <- isPrimOpId_maybe f ->
-      case op of
-         NotOp     -> Just (v, \y -> wordResult' dflags $ complement y)
-         NotIOp    -> Just (v, \y -> intResult'  dflags $ complement y)
-         IntNegOp  -> Just (v, \y -> intResult'  dflags $ negate y    )
+
+adjustUnary :: PrimOp -> Maybe (Integer -> Integer)
+-- Given (op x) return a function 'f' s.t.  f (op x) = x
+adjustUnary op
+  = case op of
+         NotOp     -> Just (\y -> complement y)
+         NotIOp    -> Just (\y -> complement y)
+         IntNegOp  -> Just (\y -> negate y    )
          _         -> Nothing
 
-   _ -> Nothing
+tx_con_tte :: DynFlags -> AltCon -> AltCon
+tx_con_tte _      DEFAULT      = DEFAULT
+tx_con_tte dflags (DataAlt dc)
+  | tag == 0  = DEFAULT   -- See Note [caseRules for tagToEnum]
+  | otherwise = LitAlt (mkMachInt dflags (toInteger tag))
+  where
+    tag = dataConTagZ dc
+tx_con_tte _      alt          = pprPanic "caseRules" (ppr alt)
+
+tx_con_dtt :: Type -> AltCon -> AltCon
+tx_con_dtt _  DEFAULT              = DEFAULT
+tx_con_dtt ty (LitAlt (MachInt i)) = DataAlt (get_con ty (fromInteger i))
+tx_con_dtt _  alt                  = pprPanic "caseRules" (ppr alt)
+
+get_con :: Type -> ConTagZ -> DataCon
+get_con ty tag = tyConDataCons (tyConAppTyCon ty) !! tag
+
+{- Note [caseRules for tagToEnum]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We want to transform
+   case tagToEnum x of
+     False -> e1
+     True  -> e2
+into
+   case x of
+     0# -> e1
+     1# -> e1
+
+This rule eliminates a lot of boilerplate. For
+  if (x>y) then e1 else e2
+we generate
+  case tagToEnum (x ># y) of
+    False -> e2
+    True  -> e1
+and it is nice to then get rid of the tagToEnum.
+
+NB: in SimplUtils, where we invoke caseRules,
+    we convert that 0# to DEFAULT
+
+Note [caseRules for dataToTag]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We want to transform
+  case dataToTag x of
+    DEFAULT -> e1
+    1# -> e2
+into
+  case x of
+    DEFAULT -> e1
+    (:) _ _ -> e2
+
+Note the need for some wildcard binders in
+the 'cons' case.
+-}