From 9850cccb116575f3a47d91bed0031050094f87e2 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Tue, 25 Mar 2008 20:29:10 +0000 Subject: [PATCH] Add GHC.IntWord32 and GHC.IntWord64 (from base) --- GHC/IntWord32.hs | 72 ++++++++++++++++++++++++++++++ GHC/IntWord64.hs | 76 ++++++++++++++++++++++++++++++++ cbits/longlong.c | 129 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ ghc-prim.cabal | 6 ++- 4 files changed, 282 insertions(+), 1 deletion(-) create mode 100644 GHC/IntWord32.hs create mode 100644 GHC/IntWord64.hs create mode 100644 cbits/longlong.c diff --git a/GHC/IntWord32.hs b/GHC/IntWord32.hs new file mode 100644 index 0000000..c83585a --- /dev/null +++ b/GHC/IntWord32.hs @@ -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 index 0000000..17002d8 --- /dev/null +++ b/GHC/IntWord64.hs @@ -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 index 0000000..c814773 --- /dev/null +++ b/cbits/longlong.c @@ -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 */ diff --git a/ghc-prim.cabal b/ghc-prim.cabal index 7bec732..74c5705 100644 --- a/ghc-prim.cabal +++ b/ghc-prim.cabal @@ -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 -- 1.7.10.4