Follow changes in comparison primops (see #6135)
authorJan Stolarek <jan.stolarek@p.lodz.pl>
Mon, 16 Sep 2013 14:16:37 +0000 (15:16 +0100)
committerJan Stolarek <jan.stolarek@p.lodz.pl>
Wed, 18 Sep 2013 11:00:38 +0000 (12:00 +0100)
libraries/ghc-prim/GHC/CString.hs
libraries/ghc-prim/GHC/Classes.hs
libraries/ghc-prim/GHC/IntWord64.hs
libraries/ghc-prim/GHC/PrimWrappers.hs [deleted file]
libraries/ghc-prim/GHC/Types.hs
libraries/ghc-prim/ghc-prim.cabal

index cbafae0..ef9223e 100644 (file)
@@ -22,7 +22,6 @@ module GHC.CString (
 
 import GHC.Types
 import GHC.Prim
-import GHC.PrimWrappers
 
 -----------------------------------------------------------------------------
 -- Unpacking C strings}
@@ -44,8 +43,8 @@ unpackCString# addr
   = unpack 0#
   where
     unpack nh
-      | ch `eqChar#` '\0'# = []
-      | True               = C# ch : unpack (nh +# 1#)
+      | isTrue# (ch `eqChar#` '\0'#) = []
+      | True                         = C# ch : unpack (nh +# 1#)
       where
         !ch = indexCharOffAddr# addr nh
 
@@ -56,8 +55,8 @@ unpackAppendCString# addr rest
   = unpack 0#
   where
     unpack nh
-      | ch `eqChar#` '\0'# = rest
-      | True               = C# ch : unpack (nh +# 1#)
+      | isTrue# (ch `eqChar#` '\0'#) = rest
+      | True                         = C# ch : unpack (nh +# 1#)
       where
         !ch = indexCharOffAddr# addr nh
 
@@ -81,8 +80,8 @@ unpackFoldrCString# addr f z
   = unpack 0#
   where
     unpack nh
-      | ch `eqChar#` '\0'# = z
-      | True               = C# ch `f` unpack (nh +# 1#)
+      | isTrue# (ch `eqChar#` '\0'#) = z
+      | True                         = C# ch `f` unpack (nh +# 1#)
       where
         !ch = indexCharOffAddr# addr nh
 
@@ -91,18 +90,18 @@ unpackCStringUtf8# addr
   = unpack 0#
   where
     unpack nh
-      | ch `eqChar#` '\0'#   = []
-      | ch `leChar#` '\x7F'# = C# ch : unpack (nh +# 1#)
-      | ch `leChar#` '\xDF'# =
+      | isTrue# (ch `eqChar#` '\0'#  ) = []
+      | isTrue# (ch `leChar#` '\x7F'#) = C# ch : unpack (nh +# 1#)
+      | isTrue# (ch `leChar#` '\xDF'#) =
           C# (chr# (((ord# ch                                  -# 0xC0#) `uncheckedIShiftL#`  6#) +#
                      (ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#))) :
           unpack (nh +# 2#)
-      | ch `leChar#` '\xEF'# =
+      | isTrue# (ch `leChar#` '\xEF'#) =
           C# (chr# (((ord# ch                                  -# 0xE0#) `uncheckedIShiftL#` 12#) +#
                     ((ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#) `uncheckedIShiftL#`  6#) +#
                      (ord# (indexCharOffAddr# addr (nh +# 2#)) -# 0x80#))) :
           unpack (nh +# 3#)
-      | True                 =
+      | True                           =
           C# (chr# (((ord# ch                                  -# 0xF0#) `uncheckedIShiftL#` 18#) +#
                     ((ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#) `uncheckedIShiftL#` 12#) +#
                     ((ord# (indexCharOffAddr# addr (nh +# 2#)) -# 0x80#) `uncheckedIShiftL#`  6#) +#
@@ -116,8 +115,8 @@ unpackNBytes# _addr 0#   = []
 unpackNBytes#  addr len# = unpack [] (len# -# 1#)
     where
      unpack acc i#
-      | i# <# 0#  = acc
-      | True      =
+      | isTrue# (i# <# 0#)  = acc
+      | True                =
          case indexCharOffAddr# addr i# of
             ch -> unpack (C# ch : acc) (i# -# 1#)
 
index cf95cf8..f1c3fb0 100644 (file)
@@ -23,7 +23,6 @@ module GHC.Classes where
 -- GHC.Magic is used in some derived instances
 import GHC.Magic ()
 import GHC.Prim
-import GHC.PrimWrappers
 import GHC.Tuple
 import GHC.Types
 
@@ -95,14 +94,14 @@ deriving instance Eq Ordering
 deriving instance Eq Word
 
 instance Eq Char where
-    (C# c1) == (C# c2) = c1 `eqChar#` c2
-    (C# c1) /= (C# c2) = c1 `neChar#` c2
+    (C# c1) == (C# c2) = isTrue# (c1 `eqChar#` c2)
+    (C# c1) /= (C# c2) = isTrue# (c1 `neChar#` c2)
 
 instance Eq Float where
-    (F# x) == (F# y) = x `eqFloat#` y
+    (F# x) == (F# y) = isTrue# (x `eqFloat#` y)
 
 instance Eq Double where
-    (D# x) == (D# y) = x ==## y
+    (D# x) == (D# y) = isTrue# (x ==## y)
 
 instance Eq Int where
     (==) = eqInt
@@ -111,8 +110,8 @@ instance Eq Int where
 {-# INLINE eqInt #-}
 {-# INLINE neInt #-}
 eqInt, neInt :: Int -> Int -> Bool
-(I# x) `eqInt` (I# y) = x ==# y
-(I# x) `neInt` (I# y) = x /=# y
+(I# x) `eqInt` (I# y) = isTrue# (x ==# y)
+(I# x) `neInt` (I# y) = isTrue# (x /=# y)
 
 -- | The 'Ord' class is used for totally ordered datatypes.
 --
@@ -199,32 +198,32 @@ deriving instance Ord Word
 -- instance defines only compare, which takes two primops.  Then
 -- '>' uses compare, and therefore takes two primops instead of one.
 instance Ord Char where
-    (C# c1) >  (C# c2) = c1 `gtChar#` c2
-    (C# c1) >= (C# c2) = c1 `geChar#` c2
-    (C# c1) <= (C# c2) = c1 `leChar#` c2
-    (C# c1) <  (C# c2) = c1 `ltChar#` c2
+    (C# c1) >  (C# c2) = isTrue# (c1 `gtChar#` c2)
+    (C# c1) >= (C# c2) = isTrue# (c1 `geChar#` c2)
+    (C# c1) <= (C# c2) = isTrue# (c1 `leChar#` c2)
+    (C# c1) <  (C# c2) = isTrue# (c1 `ltChar#` c2)
 
 instance Ord Float where
     (F# x) `compare` (F# y)
-        = if      x `ltFloat#` y then LT
-          else if x `eqFloat#` y then EQ
-          else                        GT
+        = if      isTrue# (x `ltFloat#` y) then LT
+          else if isTrue# (x `eqFloat#` y) then EQ
+          else                                  GT
 
-    (F# x) <  (F# y) = x `ltFloat#`  y
-    (F# x) <= (F# y) = x `leFloat#`  y
-    (F# x) >= (F# y) = x `geFloat#`  y
-    (F# x) >  (F# y) = x `gtFloat#`  y
+    (F# x) <  (F# y) = isTrue# (x `ltFloat#` y)
+    (F# x) <= (F# y) = isTrue# (x `leFloat#` y)
+    (F# x) >= (F# y) = isTrue# (x `geFloat#` y)
+    (F# x) >  (F# y) = isTrue# (x `gtFloat#` y)
 
 instance Ord Double where
     (D# x) `compare` (D# y)
-        = if      x <##  y then LT
-          else if x ==## y then EQ
-          else                  GT
+        = if      isTrue# (x <##  y) then LT
+          else if isTrue# (x ==## y) then EQ
+          else                            GT
 
-    (D# x) <  (D# y) = x <##  y
-    (D# x) <= (D# y) = x <=## y
-    (D# x) >= (D# y) = x >=## y
-    (D# x) >  (D# y) = x >##  y
+    (D# x) <  (D# y) = isTrue# (x <##  y)
+    (D# x) <= (D# y) = isTrue# (x <=## y)
+    (D# x) >= (D# y) = isTrue# (x >=## y)
+    (D# x) >  (D# y) = isTrue# (x >##  y)
 
 instance Ord Int where
     compare = compareInt
@@ -238,19 +237,19 @@ instance Ord Int where
 {-# INLINE ltInt #-}
 {-# INLINE leInt #-}
 gtInt, geInt, ltInt, leInt :: Int -> Int -> Bool
-(I# x) `gtInt` (I# y) = x >#  y
-(I# x) `geInt` (I# y) = x >=# y
-(I# x) `ltInt` (I# y) = x <#  y
-(I# x) `leInt` (I# y) = x <=# y
+(I# x) `gtInt` (I# y) = isTrue# (x >#  y)
+(I# x) `geInt` (I# y) = isTrue# (x >=# y)
+(I# x) `ltInt` (I# y) = isTrue# (x <#  y)
+(I# x) `leInt` (I# y) = isTrue# (x <=# y)
 
 compareInt :: Int -> Int -> Ordering
 (I# x#) `compareInt` (I# y#) = compareInt# x# y#
 
 compareInt# :: Int# -> Int# -> Ordering
 compareInt# x# y#
-    | x# <#  y# = LT
-    | x# ==# y# = EQ
-    | True      = GT
+    | isTrue# (x# <#  y#) = LT
+    | isTrue# (x# ==# y#) = EQ
+    | True                = GT
 
 -- OK, so they're technically not part of a class...:
 
@@ -283,15 +282,15 @@ x# `divInt#` y#
         -- code has problems with overflow:
 --    | (x# ># 0#) && (y# <# 0#) = ((x# -# y#) -# 1#) `quotInt#` y#
 --    | (x# <# 0#) && (y# ># 0#) = ((x# -# y#) +# 1#) `quotInt#` y#
-    =      if (x# ># 0#) && (y# <# 0#) then ((x# -# 1#) `quotInt#` y#) -# 1#
-      else if (x# <# 0#) && (y# ># 0#) then ((x# +# 1#) `quotInt#` y#) -# 1#
+    =      if isTrue# (x# ># 0#) && isTrue# (y# <# 0#) then ((x# -# 1#) `quotInt#` y#) -# 1#
+      else if isTrue# (x# <# 0#) && isTrue# (y# ># 0#) then ((x# +# 1#) `quotInt#` y#) -# 1#
       else x# `quotInt#` y#
 
 modInt# :: Int# -> Int# -> Int#
 x# `modInt#` y#
-    = if (x# ># 0#) && (y# <# 0#) ||
-         (x# <# 0#) && (y# ># 0#)
-      then if r# /=# 0# then r# +# y# else 0#
+    = if isTrue# (x# ># 0#) && isTrue# (y# <# 0#) ||
+         isTrue# (x# <# 0#) && isTrue# (y# ># 0#)
+      then if isTrue# (r# /=# 0#) then r# +# y# else 0#
       else r#
     where
     !r# = x# `remInt#` y#
index 5b5b9a3..c86b229 100644 (file)
@@ -26,61 +26,34 @@ module GHC.IntWord64 (
 
 #if WORD_SIZE_IN_BITS < 64
 import GHC.Prim
-import GHC.Types
 
-eqWord64# :: Word64# -> Word64# -> Bool
-eqWord64# a b = tagToEnum# (eqWord64## a b)
-neWord64# :: Word64# -> Word64# -> Bool
-neWord64# a b = tagToEnum# (neWord64## a b)
-ltWord64# :: Word64# -> Word64# -> Bool
-ltWord64# a b = tagToEnum# (ltWord64## a b)
-leWord64# :: Word64# -> Word64# -> Bool
-leWord64# a b = tagToEnum# (leWord64## a b)
-gtWord64# :: Word64# -> Word64# -> Bool
-gtWord64# a b = tagToEnum# (gtWord64## a b)
-geWord64# :: Word64# -> Word64# -> Bool
-geWord64# a b = tagToEnum# (geWord64## a b)
+foreign import ccall unsafe "hs_eqWord64"    eqWord64#     :: Word64# -> Word64# -> Int#
+foreign import ccall unsafe "hs_neWord64"    neWord64#     :: Word64# -> Word64# -> Int#
+foreign import ccall unsafe "hs_ltWord64"    ltWord64#     :: Word64# -> Word64# -> Int#
+foreign import ccall unsafe "hs_leWord64"    leWord64#     :: Word64# -> Word64# -> Int#
+foreign import ccall unsafe "hs_gtWord64"    gtWord64#     :: Word64# -> Word64# -> Int#
+foreign import ccall unsafe "hs_geWord64"    geWord64#     :: Word64# -> Word64# -> Int#
 
-eqInt64# :: Int64# -> Int64# -> Bool
-eqInt64# a b = tagToEnum# (eqInt64## a b)
-neInt64# :: Int64# -> Int64# -> Bool
-neInt64# a b = tagToEnum# (neInt64## a b)
-ltInt64# :: Int64# -> Int64# -> Bool
-ltInt64# a b = tagToEnum# (ltInt64## a b)
-leInt64# :: Int64# -> Int64# -> Bool
-leInt64# a b = tagToEnum# (leInt64## a b)
-gtInt64# :: Int64# -> Int64# -> Bool
-gtInt64# a b = tagToEnum# (gtInt64## a b)
-geInt64# :: Int64# -> Int64# -> Bool
-geInt64# a b = tagToEnum# (geInt64## a b)
+foreign import ccall unsafe "hs_eqInt64"     eqInt64#      :: Int64# -> Int64# -> Int#
+foreign import ccall unsafe "hs_neInt64"     neInt64#      :: Int64# -> Int64# -> Int#
+foreign import ccall unsafe "hs_ltInt64"     ltInt64#      :: Int64# -> Int64# -> Int#
+foreign import ccall unsafe "hs_leInt64"     leInt64#      :: Int64# -> Int64# -> Int#
+foreign import ccall unsafe "hs_gtInt64"     gtInt64#      :: Int64# -> Int64# -> Int#
+foreign import ccall unsafe "hs_geInt64"     geInt64#      :: Int64# -> Int64# -> Int#
+foreign import ccall unsafe "hs_quotInt64"   quotInt64#    :: Int64# -> Int64# -> Int64#
+foreign import ccall unsafe "hs_remInt64"    remInt64#     :: Int64# -> Int64# -> Int64#
 
-foreign import ccall unsafe "hs_eqWord64"    eqWord64##     :: Word64# -> Word64# -> Int#
-foreign import ccall unsafe "hs_neWord64"    neWord64##     :: Word64# -> Word64# -> Int#
-foreign import ccall unsafe "hs_ltWord64"    ltWord64##     :: Word64# -> Word64# -> Int#
-foreign import ccall unsafe "hs_leWord64"    leWord64##     :: Word64# -> Word64# -> Int#
-foreign import ccall unsafe "hs_gtWord64"    gtWord64##     :: Word64# -> Word64# -> Int#
-foreign import ccall unsafe "hs_geWord64"    geWord64##     :: Word64# -> Word64# -> Int#
+foreign import ccall unsafe "hs_plusInt64"   plusInt64#    :: Int64# -> Int64# -> Int64#
+foreign import ccall unsafe "hs_minusInt64"  minusInt64#   :: Int64# -> Int64# -> Int64#
+foreign import ccall unsafe "hs_timesInt64"  timesInt64#   :: Int64# -> Int64# -> Int64#
+foreign import ccall unsafe "hs_negateInt64" negateInt64#  :: Int64# -> Int64#
+foreign import ccall unsafe "hs_quotWord64"  quotWord64#   :: Word64# -> Word64# -> Word64#
+foreign import ccall unsafe "hs_remWord64"   remWord64#    :: Word64# -> Word64# -> Word64#
 
-foreign import ccall unsafe "hs_eqInt64"     eqInt64##      :: Int64# -> Int64# -> Int#
-foreign import ccall unsafe "hs_neInt64"     neInt64##      :: Int64# -> Int64# -> Int#
-foreign import ccall unsafe "hs_ltInt64"     ltInt64##      :: Int64# -> Int64# -> Int#
-foreign import ccall unsafe "hs_leInt64"     leInt64##      :: Int64# -> Int64# -> Int#
-foreign import ccall unsafe "hs_gtInt64"     gtInt64##      :: Int64# -> Int64# -> Int#
-foreign import ccall unsafe "hs_geInt64"     geInt64##      :: Int64# -> Int64# -> Int#
-foreign import ccall unsafe "hs_quotInt64"   quotInt64#     :: Int64# -> Int64# -> Int64#
-foreign import ccall unsafe "hs_remInt64"    remInt64#      :: Int64# -> Int64# -> Int64#
-
-foreign import ccall unsafe "hs_plusInt64"   plusInt64#     :: Int64# -> Int64# -> Int64#
-foreign import ccall unsafe "hs_minusInt64"  minusInt64#    :: Int64# -> Int64# -> Int64#
-foreign import ccall unsafe "hs_timesInt64"  timesInt64#    :: Int64# -> Int64# -> Int64#
-foreign import ccall unsafe "hs_negateInt64" negateInt64#   :: Int64# -> Int64#
-foreign import ccall unsafe "hs_quotWord64"  quotWord64#    :: Word64# -> Word64# -> Word64#
-foreign import ccall unsafe "hs_remWord64"   remWord64#     :: Word64# -> Word64# -> Word64#
-
-foreign import ccall unsafe "hs_and64"       and64#         :: Word64# -> Word64# -> Word64#
-foreign import ccall unsafe "hs_or64"        or64#          :: Word64# -> Word64# -> Word64#
-foreign import ccall unsafe "hs_xor64"       xor64#         :: Word64# -> Word64# -> Word64#
-foreign import ccall unsafe "hs_not64"       not64#         :: Word64# -> Word64#
+foreign import ccall unsafe "hs_and64"       and64#        :: Word64# -> Word64# -> Word64#
+foreign import ccall unsafe "hs_or64"        or64#         :: Word64# -> Word64# -> Word64#
+foreign import ccall unsafe "hs_xor64"       xor64#        :: Word64# -> Word64# -> Word64#
+foreign import ccall unsafe "hs_not64"       not64#        :: Word64# -> Word64#
 
 foreign import ccall unsafe "hs_uncheckedShiftL64"   uncheckedShiftL64#   :: Word64# -> Int# -> Word64#
 foreign import ccall unsafe "hs_uncheckedShiftRL64"  uncheckedShiftRL64#  :: Word64# -> Int# -> Word64#
diff --git a/libraries/ghc-prim/GHC/PrimWrappers.hs b/libraries/ghc-prim/GHC/PrimWrappers.hs
deleted file mode 100644 (file)
index 15580f7..0000000
+++ /dev/null
@@ -1,136 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude, MagicHash #-}
-{-# OPTIONS_HADDOCK hide #-}
-
------------------------------------------------------------------------------
--- |
--- Module      :  GHC.PrimWrappers
--- Copyright   :  (c) Lodz University of Technology 2013
--- License     :  see libraries/base/LICENSE
---
--- Maintainer  :  ghc-devs@haskell.org
--- Stability   :  internal
--- Portability :  non-portable (GHC extensions)
---
--- Wrappers for comparison primops
---
------------------------------------------------------------------------------
-
-module GHC.PrimWrappers (
-    gtChar#, geChar#, eqChar#,
-    neChar#, ltChar#, leChar#,
-
-    (>#), (>=#), (==#), (/=#), (<#), (<=#),
-
-    gtWord#, geWord#, eqWord#,
-    neWord#, ltWord#, leWord#,
-
-    (>##), (>=##), (==##), (/=##), (<##), (<=##),
-
-    gtFloat#, geFloat#, eqFloat#,
-    neFloat#, ltFloat#, leFloat#,
-
-    gtAddr#, geAddr#, eqAddr#,
-    neAddr#, ltAddr#, leAddr#,
-
-    sameMutableArray, sameMutableByteArray, sameMutableArrayArray,
-    sameMutVar, sameTVar, sameMVar
-  ) where
-
-import GHC.Prim
-import GHC.Types
-
-gtChar# :: Char# -> Char# -> Bool
-gtChar# a b = tagToEnum# (a `gtCharI#` b)
-geChar# :: Char# -> Char# -> Bool
-geChar# a b = tagToEnum# (a `geCharI#` b)
-eqChar# :: Char# -> Char# -> Bool
-eqChar# a b = tagToEnum# (a `eqCharI#` b)
-neChar# :: Char# -> Char# -> Bool
-neChar# a b = tagToEnum# (a `neCharI#` b)
-ltChar# :: Char# -> Char# -> Bool
-ltChar# a b = tagToEnum# (a `ltCharI#` b)
-leChar# :: Char# -> Char# -> Bool
-leChar# a b = tagToEnum# (a `leCharI#` b)
-
-infix 4 >#, >=#, ==#, /=#, <#, <=#
-
-(>#) :: Int# -> Int# -> Bool
-(>#) a b = tagToEnum# (a >$# b)
-(>=#) :: Int# -> Int# -> Bool
-(>=#) a b = tagToEnum# (a >=$# b)
-(==#) :: Int# -> Int# -> Bool
-(==#) a b = tagToEnum# (a ==$# b)
-(/=#) :: Int# -> Int# -> Bool
-(/=#) a b = tagToEnum# (a /=$# b)
-(<#)  :: Int# -> Int# -> Bool
-(<#) a b = tagToEnum# (a <$# b)
-(<=#) :: Int# -> Int# -> Bool
-(<=#) a b = tagToEnum# (a <=$# b)
-
-gtWord# :: Word# -> Word# -> Bool
-gtWord# a b = tagToEnum# (a `gtWordI#` b)
-geWord# :: Word# -> Word# -> Bool
-geWord# a b = tagToEnum# (a `geWordI#` b)
-eqWord# :: Word# -> Word# -> Bool
-eqWord# a b = tagToEnum# (a `eqWordI#` b)
-neWord# :: Word# -> Word# -> Bool
-neWord# a b = tagToEnum# (a `neWordI#` b)
-ltWord# :: Word# -> Word# -> Bool
-ltWord# a b = tagToEnum# (a `ltWordI#` b)
-leWord# :: Word# -> Word# -> Bool
-leWord# a b = tagToEnum# (a `leWordI#` b)
-
-infix 4 >##, >=##, ==##, /=##, <##, <=##
-
-(>##)  :: Double# -> Double# -> Bool
-(>##) a b = tagToEnum# (a >$## b)
-(>=##) :: Double# -> Double# -> Bool
-(>=##) a b = tagToEnum# (a >=$## b)
-(==##) :: Double# -> Double# -> Bool
-(==##) a b = tagToEnum# (a ==$## b)
-(/=##) :: Double# -> Double# -> Bool
-(/=##) a b = tagToEnum# (a /=$## b)
-(<##)  :: Double# -> Double# -> Bool
-(<##) a b = tagToEnum# (a <$## b)
-(<=##) :: Double# -> Double# -> Bool
-(<=##) a b = tagToEnum# (a <=$## b)
-
-gtFloat# :: Float# -> Float# -> Bool
-gtFloat# a b = tagToEnum# (a `gtFloatI#` b)
-geFloat# :: Float# -> Float# -> Bool
-geFloat# a b = tagToEnum# (a `geFloatI#` b)
-eqFloat# :: Float# -> Float# -> Bool
-eqFloat# a b = tagToEnum# (a `eqFloatI#` b)
-neFloat# :: Float# -> Float# -> Bool
-neFloat# a b = tagToEnum# (a `neFloatI#` b)
-ltFloat# :: Float# -> Float# -> Bool
-ltFloat# a b = tagToEnum# (a `ltFloatI#` b)
-leFloat# :: Float# -> Float# -> Bool
-leFloat# a b = tagToEnum# (a `leFloatI#` b)
-
-gtAddr# :: Addr# -> Addr# -> Bool
-gtAddr# a b = tagToEnum# (a `gtAddrI#` b)
-geAddr# :: Addr# -> Addr# -> Bool
-geAddr# a b = tagToEnum# (a `geAddrI#` b)
-eqAddr# :: Addr# -> Addr# -> Bool
-eqAddr# a b = tagToEnum# (a `eqAddrI#` b)
-neAddr# :: Addr# -> Addr# -> Bool
-neAddr# a b = tagToEnum# (a `neAddrI#` b)
-ltAddr# :: Addr# -> Addr# -> Bool
-ltAddr# a b = tagToEnum# (a `ltAddrI#` b)
-leAddr# :: Addr# -> Addr# -> Bool
-leAddr# a b = tagToEnum# (a `leAddrI#` b)
-
-sameMutableArray :: MutableArray# s a -> MutableArray# s a -> Bool
-sameMutableArray a b = tagToEnum# (sameMutableArray# a b)
-sameMutableByteArray :: MutableByteArray# s -> MutableByteArray# s -> Bool
-sameMutableByteArray a b = tagToEnum# (sameMutableByteArray# a b)
-sameMutableArrayArray :: MutableArrayArray# s -> MutableArrayArray# s -> Bool
-sameMutableArrayArray a b = tagToEnum# (sameMutableArrayArray# a b)
-
-sameMutVar :: MutVar# s a -> MutVar# s a -> Bool
-sameMutVar a b = tagToEnum# (sameMutVar# a b)
-sameTVar :: TVar# s a -> TVar# s a -> Bool
-sameTVar a b = tagToEnum# (sameTVar# a b)
-sameMVar :: MVar# s a -> MVar# s a -> Bool
-sameMVar a b = tagToEnum# (sameMVar# a b)
index 1a582bf..690e8a3 100644 (file)
@@ -18,7 +18,8 @@
 module GHC.Types (
         Bool(..), Char(..), Int(..), Word(..),
         Float(..), Double(..),
-        Ordering(..), IO(..)
+        Ordering(..), IO(..),
+        isTrue#
     ) where
 
 import GHC.Prim
@@ -90,3 +91,65 @@ data (~) a b = Eq# ((~#) a b)
 -- The type constructor is special as GHC pretends the field of EqR# has type
 -- (a ~R# b), which is not representable in Haskell, and turns it into a class.
 data Coercible a b = MkCoercible ((~#) a b)
+
+-- | Alias for tagToEnum#. Returns True of its parameter is 1# and False
+--   if it is 0#.
+
+{-# INLINE isTrue# #-}
+isTrue# :: Int# -> Bool   -- See Note [Optimizing isTrue#]
+isTrue# x = tagToEnum# x
+
+-- Note [Optimizing isTrue#]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- Current definition of isTrue# is a temporary workaround. We would like to
+-- have functions isTrue# and isFalse# defined like this:
+--
+--     isTrue# :: Int# -> Bool
+--     isTrue# 1# = True
+--     isTrue# _  = False
+--
+--     isFalse# :: Int# -> Bool
+--     isFalse# 0# = True
+--     isFalse# _  = False
+--
+-- These functions would allow us to safely check if a tag can represent True
+-- or False. Using isTrue# and isFalse# as defined above will not introduce
+-- additional case into the code. When we scrutinize return value of isTrue#
+-- or isFalse#, either explicitly in a case expression or implicitly in a guard,
+-- the result will always be a single case expression (given that optimizations
+-- are turned on). This results from case-of-case transformation. Consider this
+-- code (this is both valid Haskell and Core):
+--
+-- case isTrue# (a ># b) of
+--     True  -> e1
+--     False -> e2
+--
+-- Inlining isTrue# gives:
+--
+-- case (case (a ># b) of { 1# -> True; _ -> False } ) of
+--     True  -> e1
+--     False -> e2
+--
+-- Case-of-case transforms that to:
+--
+-- case (a ># b) of
+--   1# -> case True of
+--           True  -> e1
+--           False -> e2
+--   _  -> case False of
+--           True  -> e1
+--           False -> e2
+--
+-- Which is then simplified by case-of-known-constructor:
+--
+-- case (a ># b) of
+--   1# -> e1
+--   _  -> e2
+--
+-- While we get good Core here, the code generator will generate very bad Cmm
+-- if e1 or e2 do allocation. It will push heap checks into case alternatives
+-- which results in about 2.5% increase in code size. Until this is improved we
+-- just make isTrue# an alias to tagToEnum#. This is a temporary solution (if
+-- you're reading this in 2023 then things went wrong).
+--
index 698d18c..6793adb 100644 (file)
@@ -28,7 +28,6 @@ Library {
         GHC.Debug
         GHC.Magic
         GHC.PrimopWrappers
-        GHC.PrimWrappers
         GHC.IntWord64
         GHC.Tuple
         GHC.Types