Add GHC.IntWord32 and GHC.IntWord64 (from base)
authorIan Lynagh <igloo@earth.li>
Tue, 25 Mar 2008 20:29:10 +0000 (20:29 +0000)
committerIan Lynagh <igloo@earth.li>
Tue, 25 Mar 2008 20:29:10 +0000 (20:29 +0000)
GHC/IntWord32.hs [new file with mode: 0644]
GHC/IntWord64.hs [new file with mode: 0644]
cbits/longlong.c [new file with mode: 0644]
ghc-prim.cabal

diff --git a/GHC/IntWord32.hs b/GHC/IntWord32.hs
new file mode 100644 (file)
index 0000000..c83585a
--- /dev/null
@@ -0,0 +1,72 @@
+{-# OPTIONS_GHC -fno-implicit-prelude #-}
+{-# OPTIONS_HADDOCK hide #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  GHC.IntWord32
+-- Copyright   :  (c) The University of Glasgow, 1997-2008
+-- License     :  see libraries/ghc-prim/LICENSE
+--
+-- Maintainer  :  cvs-ghc@haskell.org
+-- Stability   :  internal
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Primitive operations on Int32# and Word32# on platforms where
+-- WORD_SIZE_IN_BITS < 32.
+--
+-----------------------------------------------------------------------------
+
+#include "MachDeps.h"
+
+-- #hide
+module GHC.IntWord32 (
+#if WORD_SIZE_IN_BITS < 32
+    Int32#, Word32#, module GHC.IntWord32
+#endif
+ ) where
+
+import GHC.Bool
+import GHC.Prim
+
+#if WORD_SIZE_IN_BITS < 32
+
+foreign import unsafe "stg_eqWord32"      eqWord32#      :: Word32# -> Word32# -> Bool
+foreign import unsafe "stg_neWord32"      neWord32#      :: Word32# -> Word32# -> Bool
+foreign import unsafe "stg_ltWord32"      ltWord32#      :: Word32# -> Word32# -> Bool
+foreign import unsafe "stg_leWord32"      leWord32#      :: Word32# -> Word32# -> Bool
+foreign import unsafe "stg_gtWord32"      gtWord32#      :: Word32# -> Word32# -> Bool
+foreign import unsafe "stg_geWord32"      geWord32#      :: Word32# -> Word32# -> Bool
+
+foreign import unsafe "stg_eqInt32"       eqInt32#       :: Int32# -> Int32# -> Bool
+foreign import unsafe "stg_neInt32"       neInt32#       :: Int32# -> Int32# -> Bool
+foreign import unsafe "stg_ltInt32"       ltInt32#       :: Int32# -> Int32# -> Bool
+foreign import unsafe "stg_leInt32"       leInt32#       :: Int32# -> Int32# -> Bool
+foreign import unsafe "stg_gtInt32"       gtInt32#       :: Int32# -> Int32# -> Bool
+foreign import unsafe "stg_geInt32"       geInt32#       :: Int32# -> Int32# -> Bool
+
+foreign import unsafe "stg_int32ToWord32" int32ToWord32# :: Int32# -> Word32#
+foreign import unsafe "stg_word32ToInt32" word32ToInt32# :: Word32# -> Int32#
+foreign import unsafe "stg_intToInt32"    intToInt32#    :: Int# -> Int32#
+foreign import unsafe "stg_wordToWord32"  wordToWord32#  :: Word# -> Word32#
+foreign import unsafe "stg_word32ToWord"  word32ToWord#  :: Word32# -> Word#
+
+foreign import unsafe "stg_plusInt32"     plusInt32#     :: Int32# -> Int32# -> Int32#
+foreign import unsafe "stg_minusInt32"    minusInt32#    :: Int32# -> Int32# -> Int32#
+foreign import unsafe "stg_timesInt32"    timesInt32#    :: Int32# -> Int32# -> Int32#
+foreign import unsafe "stg_negateInt32"   negateInt32#   :: Int32# -> Int32#
+foreign import unsafe "stg_quotInt32"     quotInt32#     :: Int32# -> Int32# -> Int32#
+foreign import unsafe "stg_remInt32"      remInt32#      :: Int32# -> Int32# -> Int32#
+foreign import unsafe "stg_quotWord32"    quotWord32#    :: Word32# -> Word32# -> Word32#
+foreign import unsafe "stg_remWord32"     remWord32#     :: Word32# -> Word32# -> Word32#
+
+foreign import unsafe "stg_and32"         and32#         :: Word32# -> Word32# -> Word32#
+foreign import unsafe "stg_or32"          or32#          :: Word32# -> Word32# -> Word32#
+foreign import unsafe "stg_xor32"         xor32#         :: Word32# -> Word32# -> Word32#
+foreign import unsafe "stg_not32"         not32#         :: Word32# -> Word32#
+
+foreign import unsafe "stg_iShiftL32"     iShiftL32#     :: Int32# -> Int# -> Int32#
+foreign import unsafe "stg_iShiftRA32"    iShiftRA32#    :: Int32# -> Int# -> Int32#
+foreign import unsafe "stg_shiftL32"      shiftL32#      :: Word32# -> Int# -> Word32#
+foreign import unsafe "stg_shiftRL32"     shiftRL32#     :: Word32# -> Int# -> Word32#
+
+#endif
+
diff --git a/GHC/IntWord64.hs b/GHC/IntWord64.hs
new file mode 100644 (file)
index 0000000..17002d8
--- /dev/null
@@ -0,0 +1,76 @@
+{-# OPTIONS_GHC -fno-implicit-prelude #-}
+{-# OPTIONS_HADDOCK hide #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  GHC.IntWord64
+-- Copyright   :  (c) The University of Glasgow, 1997-2008
+-- License     :  see libraries/ghc-prim/LICENSE
+--
+-- Maintainer  :  cvs-ghc@haskell.org
+-- Stability   :  internal
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Primitive operations on Int64# and Word64# on platforms where
+-- WORD_SIZE_IN_BITS < 64.
+--
+-----------------------------------------------------------------------------
+
+#include "MachDeps.h"
+
+-- #hide
+module GHC.IntWord64 (
+#if WORD_SIZE_IN_BITS < 64
+    Int64#, Word64#, module GHC.IntWord64
+#endif
+ ) where
+
+import GHC.Bool
+import GHC.Prim
+
+#if WORD_SIZE_IN_BITS < 64
+
+foreign import ccall unsafe "hs_eqWord64"    eqWord64#      :: Word64# -> Word64# -> Bool
+foreign import ccall unsafe "hs_neWord64"    neWord64#      :: Word64# -> Word64# -> Bool
+foreign import ccall unsafe "hs_ltWord64"    ltWord64#      :: Word64# -> Word64# -> Bool
+foreign import ccall unsafe "hs_leWord64"    leWord64#      :: Word64# -> Word64# -> Bool
+foreign import ccall unsafe "hs_gtWord64"    gtWord64#      :: Word64# -> Word64# -> Bool
+foreign import ccall unsafe "hs_geWord64"    geWord64#      :: Word64# -> Word64# -> Bool
+
+foreign import ccall unsafe "hs_eqInt64"     eqInt64#       :: Int64# -> Int64# -> Bool
+foreign import ccall unsafe "hs_neInt64"     neInt64#       :: Int64# -> Int64# -> Bool
+foreign import ccall unsafe "hs_ltInt64"     ltInt64#       :: Int64# -> Int64# -> Bool
+foreign import ccall unsafe "hs_leInt64"     leInt64#       :: Int64# -> Int64# -> Bool
+foreign import ccall unsafe "hs_gtInt64"     gtInt64#       :: Int64# -> Int64# -> Bool
+foreign import ccall unsafe "hs_geInt64"     geInt64#       :: Int64# -> Int64# -> Bool
+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_uncheckedShiftL64"   uncheckedShiftL64#   :: Word64# -> Int# -> Word64#
+foreign import ccall unsafe "hs_uncheckedShiftRL64"  uncheckedShiftRL64#  :: Word64# -> Int# -> Word64#
+foreign import ccall unsafe "hs_uncheckedIShiftL64"  uncheckedIShiftL64#  :: Int64# -> Int# -> Int64#
+foreign import ccall unsafe "hs_uncheckedIShiftRA64" uncheckedIShiftRA64# :: Int64# -> Int# -> Int64#
+foreign import ccall unsafe "hs_uncheckedIShiftRL64" uncheckedIShiftRL64# :: Int64# -> Int# -> Int64#
+
+foreign import ccall unsafe "hs_integerToWord64" integerToWord64# :: Int# -> ByteArray# -> Word64#
+foreign import ccall unsafe "hs_integerToInt64"  integerToInt64#  :: Int# -> ByteArray# -> Int64#
+foreign import ccall unsafe "hs_int64ToWord64"   int64ToWord64#   :: Int64# -> Word64#
+foreign import ccall unsafe "hs_word64ToInt64"   word64ToInt64#   :: Word64# -> Int64#
+foreign import ccall unsafe "hs_intToInt64"      intToInt64#      :: Int# -> Int64#
+foreign import ccall unsafe "hs_int64ToInt"      int64ToInt#      :: Int64# -> Int#
+foreign import ccall unsafe "hs_wordToWord64"    wordToWord64#    :: Word# -> Word64#
+foreign import ccall unsafe "hs_word64ToWord"    word64ToWord#    :: Word64# -> Word#
+
+#endif
+
diff --git a/cbits/longlong.c b/cbits/longlong.c
new file mode 100644 (file)
index 0000000..c814773
--- /dev/null
@@ -0,0 +1,129 @@
+/* -----------------------------------------------------------------------------
+ * $Id: longlong.c,v 1.4 2002/12/13 14:23:42 simonmar Exp $
+ *
+ * (c) The GHC Team, 1998-1999
+ *
+ * Primitive operations over (64-bit) long longs
+ * (only used on 32-bit platforms.)
+ *
+ * ---------------------------------------------------------------------------*/
+
+
+/*
+Miscellaneous primitive operations on HsInt64 and HsWord64s.
+N.B. These are not primops!
+
+Instead of going the normal (boring) route of making the list
+of primitive operations even longer to cope with operations
+over 64-bit entities, we implement them instead 'out-of-line'.
+
+The primitive ops get their own routine (in C) that implements
+the operation, requiring the caller to _ccall_ out. This has
+performance implications of course, but we currently don't
+expect intensive use of either Int64 or Word64 types.
+
+The exceptions to the rule are primops that cast to and from
+64-bit entities (these are defined in PrimOps.h)
+*/
+
+#include "Rts.h"
+
+#ifdef SUPPORT_LONG_LONGS
+
+/* Relational operators */
+
+static inline HsBool mkBool(int b) { return b ? HS_BOOL_TRUE : HS_BOOL_FALSE; }
+
+HsBool hs_gtWord64 (HsWord64 a, HsWord64 b) {return mkBool(a >  b);}
+HsBool hs_geWord64 (HsWord64 a, HsWord64 b) {return mkBool(a >= b);}
+HsBool hs_eqWord64 (HsWord64 a, HsWord64 b) {return mkBool(a == b);}
+HsBool hs_neWord64 (HsWord64 a, HsWord64 b) {return mkBool(a != b);}
+HsBool hs_ltWord64 (HsWord64 a, HsWord64 b) {return mkBool(a <  b);}
+HsBool hs_leWord64 (HsWord64 a, HsWord64 b) {return mkBool(a <= b);}
+
+HsBool hs_gtInt64 (HsInt64 a, HsInt64 b) {return mkBool(a >  b);}
+HsBool hs_geInt64 (HsInt64 a, HsInt64 b) {return mkBool(a >= b);}
+HsBool hs_eqInt64 (HsInt64 a, HsInt64 b) {return mkBool(a == b);}
+HsBool hs_neInt64 (HsInt64 a, HsInt64 b) {return mkBool(a != b);}
+HsBool hs_ltInt64 (HsInt64 a, HsInt64 b) {return mkBool(a <  b);}
+HsBool hs_leInt64 (HsInt64 a, HsInt64 b) {return mkBool(a <= b);}
+
+/* Arithmetic operators */
+
+HsWord64 hs_remWord64  (HsWord64 a, HsWord64 b) {return a % b;}
+HsWord64 hs_quotWord64 (HsWord64 a, HsWord64 b) {return a / b;}
+
+HsInt64 hs_remInt64    (HsInt64 a, HsInt64 b)   {return a % b;}
+HsInt64 hs_quotInt64   (HsInt64 a, HsInt64 b)   {return a / b;}
+HsInt64 hs_negateInt64 (HsInt64 a)              {return -a;}
+HsInt64 hs_plusInt64   (HsInt64 a, HsInt64 b)   {return a + b;}
+HsInt64 hs_minusInt64  (HsInt64 a, HsInt64 b)   {return a - b;}
+HsInt64 hs_timesInt64  (HsInt64 a, HsInt64 b)   {return a * b;}
+
+/* Logical operators: */
+
+HsWord64 hs_and64      (HsWord64 a, HsWord64 b) {return a & b;}
+HsWord64 hs_or64       (HsWord64 a, HsWord64 b) {return a | b;}
+HsWord64 hs_xor64      (HsWord64 a, HsWord64 b) {return a ^ b;}
+HsWord64 hs_not64      (HsWord64 a)             {return ~a;}
+
+HsWord64 hs_uncheckedShiftL64   (HsWord64 a, HsInt b)    {return a << b;}
+HsWord64 hs_uncheckedShiftRL64  (HsWord64 a, HsInt b)    {return a >> b;}
+/* Right shifting of signed quantities is not portable in C, so
+   the behaviour you'll get from using these primops depends
+   on the whatever your C compiler is doing. ToDo: fix. -- sof 8/98
+*/
+HsInt64  hs_uncheckedIShiftL64  (HsInt64 a,  HsInt b)    {return a << b;}
+HsInt64  hs_uncheckedIShiftRA64 (HsInt64 a,  HsInt b)    {return a >> b;}
+HsInt64  hs_uncheckedIShiftRL64 (HsInt64 a,  HsInt b)
+                                    {return (HsInt64) ((HsWord64) a >> b);}
+
+/* Casting between longs and longer longs.
+   (the primops that cast from long longs to Integers
+   expressed as macros, since these may cause some heap allocation).
+*/
+
+HsInt64  hs_intToInt64    (HsInt    i) {return (HsInt64)  i;}
+HsInt    hs_int64ToInt    (HsInt64  i) {return (HsInt)    i;}
+HsWord64 hs_int64ToWord64 (HsInt64  i) {return (HsWord64) i;}
+HsWord64 hs_wordToWord64  (HsWord   w) {return (HsWord64) w;}
+HsWord   hs_word64ToWord  (HsWord64 w) {return (HsWord)   w;}
+HsInt64  hs_word64ToInt64 (HsWord64 w) {return (HsInt64)  w;}
+
+HsWord64 hs_integerToWord64 (HsInt sa, StgByteArray /* Really: mp_limb_t* */ da)
+{ 
+  mp_limb_t* d;
+  HsInt s;
+  HsWord64 res;
+  d = (mp_limb_t *)da;
+  s = sa;
+  switch (s) {
+    case  0: res = 0;     break;
+    case  1: res = d[0];  break;
+    case -1: res = -(HsWord64)d[0]; break;
+    default:
+      res = (HsWord64)d[0] + ((HsWord64)d[1] << (BITS_IN (mp_limb_t)));
+      if (s < 0) res = -res;
+  }
+  return res;
+}
+
+HsInt64 hs_integerToInt64 (HsInt sa, StgByteArray /* Really: mp_limb_t* */ da)
+{ 
+  mp_limb_t* d;
+  HsInt s;
+  HsInt64 res;
+  d = (mp_limb_t *)da;
+  s = (sa);
+  switch (s) {
+    case  0: res = 0;     break;
+    case  1: res = d[0];  break;
+    case -1: res = -(HsInt64)d[0]; break;
+    default:
+      res = (HsInt64)d[0] + ((HsWord64)d[1] << (BITS_IN (mp_limb_t)));
+      if (s < 0) res = -res;
+  }
+  return res;
+}
+
+#endif /* SUPPORT_LONG_LONGS */
index 7bec732..74c5705 100644 (file)
@@ -14,7 +14,11 @@ Library {
         GHC.Bool
         GHC.Generics
         GHC.PrimopWrappers
-    extensions: CPP, MagicHash
+        GHC.IntWord32
+        GHC.IntWord64
+    c-sources:
+        cbits/longlong.c
+    extensions: CPP, MagicHash, ForeignFunctionInterface, UnliftedFFITypes
     -- We need to set the package name to ghc-prim (without a version number)
     -- as it's magic.
     ghc-options: -package-name ghc-prim