Commit 449deb80 authored by simonm's avatar simonm
Browse files

[project @ 1999-02-17 15:57:20 by simonm]

Fast Integers.  The rep. of Integers is now

	data Integer = S# Int#
		     | J# Int# ByteArray#

- several new primops added for overflow-detecting arithmetic
- negateInteger# removed; it can be done directly
- integer_0, integer_1 etc. removed.
- the compiler now uses S# where it previously used int2Integer.
- the compiler generates small integers for -2^32 .. 2^32-1, instead
  of -2^29 .. -2^29-1.

- PrelST.State datatype moved to LazyST (its only use).
- some library code (in Time.lhs) still needs cleaning up, it depends
  on the Integer rep.
parent 58f9684c
......@@ -107,7 +107,8 @@ module Unique (
int64DataConKey,
int64PrimTyConKey,
int64TyConKey,
integerDataConKey,
smallIntegerDataConKey,
largeIntegerDataConKey,
integerMinusOneIdKey,
integerPlusOneIdKey,
integerPlusTwoIdKey,
......@@ -559,12 +560,13 @@ int8DataConKey = mkPreludeDataConUnique 8
int16DataConKey = mkPreludeDataConUnique 9
int32DataConKey = mkPreludeDataConUnique 10
int64DataConKey = mkPreludeDataConUnique 11
integerDataConKey = mkPreludeDataConUnique 12
foreignObjDataConKey = mkPreludeDataConUnique 13
nilDataConKey = mkPreludeDataConUnique 14
ratioDataConKey = mkPreludeDataConUnique 15
stablePtrDataConKey = mkPreludeDataConUnique 16
stableNameDataConKey = mkPreludeDataConUnique 17
smallIntegerDataConKey = mkPreludeDataConUnique 12
largeIntegerDataConKey = mkPreludeDataConUnique 13
foreignObjDataConKey = mkPreludeDataConUnique 14
nilDataConKey = mkPreludeDataConUnique 15
ratioDataConKey = mkPreludeDataConUnique 16
stablePtrDataConKey = mkPreludeDataConUnique 17
stableNameDataConKey = mkPreludeDataConUnique 18
trueDataConKey = mkPreludeDataConUnique 34
wordDataConKey = mkPreludeDataConUnique 35
word8DataConKey = mkPreludeDataConUnique 36
......
......@@ -124,10 +124,20 @@ mIN_UPD_SIZE = (MIN_UPD_SIZE::Int)
mIN_SIZE_NonUpdHeapObject = (MIN_NONUPD_SIZE::Int)
\end{code}
If we're compiling with GHC (and we're not cross-compiling), then we
know that minBound and maxBound :: Int are the right values for the
target architecture. Otherwise, we assume -2^31 and 2^31-1
respectively (which will be wrong on a 64-bit machine).
\begin{code}
tARGET_MIN_INT, tARGET_MAX_INT :: Integer
tARGET_MIN_INT = -536870912
tARGET_MAX_INT = 536870912
#if __GLASGOW_HASKELL__
tARGET_MIN_INT = toInteger (minBound :: Int)
tARGET_MAX_INT = toInteger (maxBound :: Int)
#else
tARGET_MIN_INT = -2147483648
tARGET_MAX_INT = 2147483647
#endif
\end{code}
Constants for semi-tagging; the tags associated with the data
......
......@@ -25,8 +25,7 @@ module PrelInfo (
-- Here are the thin-air Ids themselves
int2IntegerId, addr2IntegerId,
integerMinusOneId, integerZeroId, integerPlusOneId, integerPlusTwoId,
addr2IntegerId,
packStringForCId, unpackCStringId, unpackCString2Id,
unpackCStringAppendId, unpackCStringFoldrId,
foldrId,
......@@ -258,16 +257,7 @@ thinAirIdNames
= map mkKnownKeyGlobal
[
-- Needed for converting literals to Integers (used in tidyCoreExpr)
(varQual pREL_BASE SLIT("int2Integer"), int2IntegerIdKey)
, (varQual pREL_BASE SLIT("addr2Integer"), addr2IntegerIdKey)
-- OK, this is Will's idea: we should have magic values for Integers 0,
-- +1, +2, and -1 (go ahead, fire me):
, (varQual pREL_BASE SLIT("integer_0"), integerZeroIdKey)
, (varQual pREL_BASE SLIT("integer_1"), integerPlusOneIdKey)
, (varQual pREL_BASE SLIT("integer_2"), integerPlusTwoIdKey)
, (varQual pREL_BASE SLIT("integer_m1"), integerMinusOneIdKey)
(varQual pREL_BASE SLIT("addr2Integer"), addr2IntegerIdKey)
-- String literals
, (varQual pREL_PACK SLIT("packCString#"), packCStringIdKey)
......@@ -282,19 +272,12 @@ thinAirIdNames
thinAirModules = [pREL_PACK] -- See notes with RnIfaces.findAndReadIface
noRepIntegerIds = [integerZeroId, integerPlusOneId, integerPlusTwoId, integerMinusOneId,
int2IntegerId, addr2IntegerId]
noRepIntegerIds = [addr2IntegerId]
noRepStrIds = [unpackCString2Id, unpackCStringId]
int2IntegerId = lookupThinAirId int2IntegerIdKey
addr2IntegerId = lookupThinAirId addr2IntegerIdKey
integerMinusOneId = lookupThinAirId integerMinusOneIdKey
integerZeroId = lookupThinAirId integerZeroIdKey
integerPlusOneId = lookupThinAirId integerPlusOneIdKey
integerPlusTwoId = lookupThinAirId integerPlusTwoIdKey
packStringForCId = lookupThinAirId packCStringIdKey
unpackCStringId = lookupThinAirId unpackCStringIdKey
unpackCString2Id = lookupThinAirId unpackCString2IdKey
......
This diff is collapsed.
......@@ -44,7 +44,8 @@ module TysWiredIn (
integerTy,
integerTyCon,
integerDataCon,
smallIntegerDataCon,
largeIntegerDataCon,
isIntegerTy,
listTyCon,
......@@ -409,10 +410,13 @@ foreignObjTyCon
integerTy :: Type
integerTy = mkTyConTy integerTyCon
integerTyCon = pcNonRecDataTyCon integerTyConKey pREL_BASE SLIT("Integer") [] [integerDataCon]
integerTyCon = pcNonRecDataTyCon integerTyConKey pREL_BASE SLIT("Integer") [] [smallIntegerDataCon, largeIntegerDataCon]
smallIntegerDataCon = pcDataCon smallIntegerDataConKey pREL_BASE SLIT("S#")
[] [] [intPrimTy] integerTyCon
largeIntegerDataCon = pcDataCon largeIntegerDataConKey pREL_BASE SLIT("J#")
[] [] [intPrimTy, byteArrayPrimTy] integerTyCon
integerDataCon = pcDataCon integerDataConKey pREL_BASE SLIT("J#")
[] [] [intPrimTy, intPrimTy, byteArrayPrimTy] integerTyCon
isIntegerTy :: Type -> Bool
isIntegerTy ty
......
......@@ -44,18 +44,14 @@ import Name ( mkLocalName, tidyOccName, tidyTopName, initTidyOccEnv, isExported
)
import TyCon ( TyCon, isDataTyCon )
import PrimOp ( PrimOp(..) )
import PrelInfo ( unpackCStringId, unpackCString2Id,
integerZeroId, integerPlusOneId,
integerPlusTwoId, integerMinusOneId,
int2IntegerId, addr2IntegerId
)
import PrelInfo ( unpackCStringId, unpackCString2Id, addr2IntegerId )
import Type ( Type, splitAlgTyConApp_maybe,
isUnLiftedType,
tidyType, tidyTypes, tidyTopType, tidyTyVar, tidyTyVars,
Type
)
import Class ( Class, classSelIds )
import TysWiredIn ( isIntegerTy )
import TysWiredIn ( smallIntegerDataCon, isIntegerTy )
import LiberateCase ( liberateCase )
import SAT ( doStaticArgs )
import Specialise ( specProgram)
......@@ -634,20 +630,15 @@ litToRep (NoRepStr s ty)
If an Integer is small enough (Haskell implementations must support
Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
otherwise, wrap with @litString2Integer@.
otherwise, wrap with @addr2Integer@.
\begin{code}
litToRep (NoRepInteger i integer_ty)
= returnPM (integer_ty, rhs)
where
rhs | i == 0 = Var integerZeroId -- Extremely convenient to look out for
| i == 1 = Var integerPlusOneId -- a few very common Integer literals!
| i == 2 = Var integerPlusTwoId
| i == (-1) = Var integerMinusOneId
| i > tARGET_MIN_INT && -- Small enough, so start from an Int
rhs | i > tARGET_MIN_INT && -- Small enough, so start from an Int
i < tARGET_MAX_INT
= App (Var int2IntegerId) (Con (Literal (mkMachInt i)) [])
= Con (DataCon smallIntegerDataCon) [Con (Literal (mkMachInt i)) []]
| otherwise -- Big, so start from a string
= App (Var addr2IntegerId) (Con (Literal (MachStr (_PK_ (show i)))) [])
......
......@@ -298,7 +298,8 @@ showTypeCategory ty
else if utc == intDataConKey then 'I'
else if utc == floatDataConKey then 'F'
else if utc == doubleDataConKey then 'D'
else if utc == integerDataConKey then 'J'
else if utc == smallIntegerDataConKey ||
utc == largeIntegerDataConKey then 'J'
else if utc == charPrimTyConKey then 'c'
else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
|| utc == addrPrimTyConKey) then 'i'
......
......@@ -11,4 +11,10 @@
<item> <tt/mkWeak/ now takes a <tt/Maybe (IO ())/ for the finalizer,
and <tt/mkWeakNoFinalizer/ is removed.
<itemize>
<item> Changed representation of <tt/Integer/ type to speed up
computations on small integers. The performance of <tt/Integer/ is now
only slightly slower than <tt/Int/ for values between <tt/minBound :: Int/
and <tt/maxBound :: Int/.
</itemize>
/* -----------------------------------------------------------------------------
* $Id: PrimOps.h,v 1.18 1999/02/11 17:15:20 simonm Exp $
* $Id: PrimOps.h,v 1.19 1999/02/17 15:57:30 simonm Exp $
*
* (c) The GHC Team, 1998-1999
*
......@@ -82,15 +82,64 @@ I_ stg_div (I_ a, I_ b);
#define remIntzh(r,a,b) r=(a)%(b)
#define negateIntzh(r,a) r=-(a)
/* The following operations are the standard add,subtract and multiply
* except that they return a carry if the operation overflows.
/* -----------------------------------------------------------------------------
* Int operations with carry.
* -------------------------------------------------------------------------- */
/* With some bit-twiddling, we can define int{Add,Sub}Czh portably in
* C, and without needing any comparisons. This may not be the
* fastest way to do it - if you have better code, please send it! --SDM
*
* Return : r = a + b, c = 0 if no overflow, 1 on overflow.
*
* We currently don't make use of the r value if c is != 0 (i.e.
* overflow), we just convert to big integers and try again. This
* could be improved by making r and c the correct values for
* plugging into a new J#.
*/
#define addIntCzh(r,c,a,b) \
{ r = a + b; \
c = ((StgWord)(~(a^b) & (a^r))) \
>> (BITS_PER_BYTE * sizeof(I_) - 1); \
}
#define subIntCzh(r,c,a,b) \
{ r = a - b; \
c = ((StgWord)((a^b) & (a^r))) \
>> (BITS_PER_BYTE * sizeof(I_) - 1); \
}
/* Multiply with overflow checking.
*
* This is slightly more tricky - the usual sign rules for add/subtract
* don't apply.
*
* They are all defined in terms of 32-bit integers and use the GCC
* 'long long' extension to get a 64-bit result. We'd like to use
* 64-bit integers on 64-bit architectures, but it seems that gcc's
* 'long long' type is set at 64-bits even on a 64-bit machine.
* On x86 hardware we use a hand-crafted assembly fragment to do the job.
*
* On other 32-bit machines we use gcc's 'long long' types, finding
* overflow with some careful bit-twiddling.
*
* On 64-bit machines where gcc's 'long long' type is also 64-bits,
* we use a crude approximation, testing whether either operand is
* larger than 32-bits; if neither is, then we go ahead with the
* multiplication.
*/
#if i386_TARGET_ARCH
#define mulIntCzh(r,c,a,b) \
{ \
__asm__("xor %1,%1\n\t \
imull %2,%3\n\t \
jno 1f\n\t \
movl $1,%1\n\t \
1:" \
: "=r" (r), "=r" (c) : "r" (a), "0" (b)); \
}
#elif SIZEOF_VOID_P == 4
#ifdef WORDS_BIGENDIAN
#define C 0
#define R 1
......@@ -104,27 +153,37 @@ typedef union {
StgInt32 i[2];
} long_long_u ;
#define addWithCarryzh(r,c,a,b) \
{ long_long_u z; \
z.l = a + b; \
r = z.i[R]; \
c = z.i[C]; \
#define mulIntCzh(r,c,a,b) \
long_long_u z; \
z.l = (StgInt64)a * (StgInt64)b; \
r = z.i[R]; \
c = z.i[C]; \
if (c == 0 || c == -1) { \
c = ((StgWord)((a^b) ^ r)) \
>> (BITS_PER_BYTE * sizeof(I_) - 1); \
} \
}
/* Careful: the carry calculation above is extremely delicate. Make sure
* you test it thoroughly after changing it.
*/
#else
#define subWithCarryzh(r,c,a,b) \
{ long_long_u z; \
z.l = a + b; \
r = z.i[R]; \
c = z.i[C]; \
}
#define HALF_INT (1 << (BITS_PER_BYTE * sizeof(I_) / 2))
#define stg_abs(a) ((a) < 0 ? -(a) : (a))
#define mulWithCarryzh(r,c,a,b) \
{ long_long_u z; \
z.l = a * b; \
r = z.i[R]; \
c = z.i[C]; \
#define mulIntCzh(r,c,a,b) \
{ \
if (stg_abs(a) >= HALF_INT \
stg_abs(b) >= HALF_INT) { \
c = 1; \
} else { \
r = a * b; \
c = 0; \
} \
}
#endif
/* -----------------------------------------------------------------------------
Word PrimOps.
......@@ -248,50 +307,48 @@ typedef union {
* to allocate any memory.
*/
#define integer2Intzh(r, aa,sa,da) \
{ MP_INT arg; \
\
arg._mp_alloc = (aa); \
arg._mp_size = (sa); \
arg._mp_d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
\
(r) = RET_PRIM_STGCALL1(I_,mpz_get_si,&arg); \
#define integer2Intzh(r, sa,da) \
{ MP_INT arg; \
\
arg._mp_size = (sa); \
arg._mp_alloc = ((StgArrWords *)da)->words; \
arg._mp_d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
\
(r) = RET_PRIM_STGCALL1(I_,mpz_get_si,&arg); \
}
#define integer2Wordzh(r, aa,sa,da) \
{ MP_INT arg; \
\
arg._mp_alloc = (aa); \
arg._mp_size = (sa); \
arg._mp_d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
\
(r) = RET_PRIM_STGCALL1(I_,mpz_get_ui,&arg); \
#define integer2Wordzh(r, sa,da) \
{ MP_INT arg; \
\
arg._mp_size = (sa); \
arg._mp_alloc = ((StgArrWords *)da)->words; \
arg._mp_d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
\
(r) = RET_PRIM_STGCALL1(I_,mpz_get_ui,&arg); \
}
#define cmpIntegerzh(r, a1,s1,d1, a2,s2,d2) \
{ MP_INT arg1; \
MP_INT arg2; \
\
arg1._mp_alloc= (a1); \
arg1._mp_size = (s1); \
arg1._mp_d = (unsigned long int *) (BYTE_ARR_CTS(d1)); \
arg2._mp_alloc= (a2); \
arg2._mp_size = (s2); \
arg2._mp_d = (unsigned long int *) (BYTE_ARR_CTS(d2)); \
\
(r) = RET_PRIM_STGCALL2(I_,mpz_cmp,&arg1,&arg2); \
#define cmpIntegerzh(r, s1,d1, s2,d2) \
{ MP_INT arg1; \
MP_INT arg2; \
\
arg1._mp_size = (s1); \
arg1._mp_alloc= ((StgArrWords *)d1)->words; \
arg1._mp_d = (unsigned long int *) (BYTE_ARR_CTS(d1)); \
arg2._mp_size = (s2); \
arg2._mp_alloc= ((StgArrWords *)d2)->words; \
arg2._mp_d = (unsigned long int *) (BYTE_ARR_CTS(d2)); \
\
(r) = RET_PRIM_STGCALL2(I_,mpz_cmp,&arg1,&arg2); \
}
/* A glorious hack: calling mpz_neg would entail allocation and
* copying, but by looking at what mpz_neg actually does, we can
* derive a better version:
*/
#define negateIntegerzh(ra, rs, rd, a, s, d) \
{ \
(ra) = (a); \
(rs) = -(s); \
(rd) = d; \
#define cmpIntegerIntzh(r, s,d, i) \
{ MP_INT arg; \
\
arg._mp_size = (s); \
arg._mp_alloc = ((StgArrWords *)d)->words; \
arg._mp_d = (unsigned long int *) (BYTE_ARR_CTS(d)); \
\
(r) = RET_PRIM_STGCALL2(I_,mpz_cmp_si,&arg,i); \
}
/* The rest are all out-of-line: -------- */
......@@ -309,11 +366,8 @@ EF_(int2Integerzh_fast);
EF_(word2Integerzh_fast);
EF_(addr2Integerzh_fast);
/* Floating-point encodings/decodings */
EF_(encodeFloatzh_fast);
/* Floating-point decodings */
EF_(decodeFloatzh_fast);
EF_(encodeDoublezh_fast);
EF_(decodeDoublezh_fast);
/* -----------------------------------------------------------------------------
......@@ -322,37 +376,41 @@ EF_(decodeDoublezh_fast);
#ifdef SUPPORT_LONG_LONGS
#define integerToWord64zh(r, aa,sa,da) \
{ unsigned long int* d; \
StgNat64 res; \
\
d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
if ( (aa) == 0 ) { \
res = (LW_)0; \
} else if ( (aa) == 1) { \
res = (LW_)d[0]; \
} else { \
res = (LW_)d[0] + (LW_)d[1] * 0x100000000ULL; \
} \
(r) = res; \
#define integerToWord64zh(r, sa,da) \
{ unsigned long int* d; \
I_ aa; \
StgNat64 res; \
\
d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
aa = ((StgArrWords *)da)->words; \
if ( (aa) == 0 ) { \
res = (LW_)0; \
} else if ( (aa) == 1) { \
res = (LW_)d[0]; \
} else { \
res = (LW_)d[0] + (LW_)d[1] * 0x100000000ULL; \
} \
(r) = res; \
}
#define integerToInt64zh(r, aa,sa,da) \
{ unsigned long int* d; \
StgInt64 res; \
\
d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
if ( (aa) == 0 ) { \
res = (LI_)0; \
} else if ( (aa) == 1) { \
res = (LI_)d[0]; \
} else { \
res = (LI_)d[0] + (LI_)d[1] * 0x100000000LL; \
if ( sa < 0 ) { \
res = (LI_)-res; \
} \
} \
(r) = res; \
#define integerToInt64zh(r, sa,da) \
{ unsigned long int* d; \
I_ aa; \
StgInt64 res; \
\
d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
aa = ((StgArrWords *)da)->words; \
if ( (aa) == 0 ) { \
res = (LI_)0; \
} else if ( (aa) == 1) { \
res = (LI_)d[0]; \
} else { \
res = (LI_)d[0] + (LI_)d[1] * 0x100000000LL; \
if ( sa < 0 ) { \
res = (LI_)-res; \
} \
} \
(r) = res; \
}
/* Conversions */
......@@ -539,29 +597,29 @@ EF_(newArrayzh_fast);
#include "ieee-flpt.h"
#if FLOATS_AS_DOUBLES /* i.e. 64-bit machines */
#define encodeFloatzh(r, aa,sa,da, expon) encodeDoublezh(r, aa,sa,da, expon)
#define encodeFloatzh(r, sa,da, expon) encodeDoublezh(r, sa,da, expon)
#else
#define encodeFloatzh(r, aa,sa,da, expon) \
{ MP_INT arg; \
/* Does not allocate memory */ \
\
arg._mp_alloc = aa; \
arg._mp_size = sa; \
arg._mp_d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
\
r = RET_PRIM_STGCALL2(StgFloat, __encodeFloat,&arg,(expon));\
#define encodeFloatzh(r, sa,da, expon) \
{ MP_INT arg; \
/* Does not allocate memory */ \
\
arg._mp_size = sa; \
arg._mp_alloc = ((StgArrWords *)da)->words; \
arg._mp_d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
\
r = RET_PRIM_STGCALL2(StgFloat, __encodeFloat,&arg,(expon)); \
}
#endif /* FLOATS_AS_DOUBLES */
#define encodeDoublezh(r, aa,sa,da, expon) \
{ MP_INT arg; \
/* Does not allocate memory */ \
\
arg._mp_alloc = aa; \
arg._mp_size = sa; \
arg._mp_d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
\
r = RET_PRIM_STGCALL2(StgDouble, __encodeDouble,&arg,(expon));\
#define encodeDoublezh(r, sa,da, expon) \
{ MP_INT arg; \
/* Does not allocate memory */ \
\
arg._mp_size = sa; \
arg._mp_alloc = ((StgArrWords *)da)->words; \
arg._mp_d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
\
r = RET_PRIM_STGCALL2(StgDouble, __encodeDouble,&arg,(expon)); \
}
/* The decode operations are out-of-line because they need to allocate
......
......@@ -209,8 +209,8 @@ instance Num Int8 where
abs = absReal
signum = signumReal
fromInteger (J# a# s# d#)
= case (integer2Int# a# s# d#) of { i# -> I8# (intToInt8# i#) }
fromInteger (J# s# d#)
= case (integer2Int# s# d#) of { i# -> I8# (intToInt8# i#) }
fromInt = intToInt8
instance Bounded Int8 where
......@@ -360,8 +360,8 @@ instance Num Int16 where
else I16# (0x10000# -# x#)
abs = absReal
signum = signumReal
fromInteger (J# a# s# d#)
= case (integer2Int# a# s# d#) of { i# -> I16# (intToInt16# i#) }
fromInteger (J# s# d#)
= case (integer2Int# s# d#) of { i# -> I16# (intToInt16# i#) }
fromInt = intToInt16
instance Bounded Int16 where
......@@ -519,8 +519,8 @@ instance Num Int32 where
#endif
abs = absReal
signum = signumReal
fromInteger (J# a# s# d#)
= case (integer2Int# a# s# d#) of { i# -> I32# (intToInt32# i#) }
fromInteger (J# s# d#)
= case (integer2Int# s# d#) of { i# -> I32# (intToInt32# i#) }
fromInt = intToInt32
instance Bounded Int32 where
......@@ -664,7 +664,7 @@ instance Num Int64 where
negate w@(I64# x) = I64# (negateInt# x)
abs x = absReal
signum = signumReal
fromInteger (J# a# s# d#) = case (integer2Int# a# s# d#) of { i# -> I64# i# }
fromInteger (J# s# d#) = case (integer2Int# s# d#) of { i# -> I64# i# }
fromInt = intToInt64
instance Bounded Int64 where
......@@ -757,10 +757,10 @@ int64ToInt32 (I64# i#) = I32# (int64ToInt# i#)
int64ToInteger :: Int64 -> Integer
int64ToInteger (I64# x#) =
case int64ToInteger# x# of
(# a#, s#, p# #) -> J# a# s# p#
(# s#, p# #) -> J# s# p#
integerToInt64 :: Integer -> Int64
integerToInt64 (J# a# s# d#) = I64# (integerToInt64# a# s# d#)
integerToInt64 (J# s# d#) = I64# (integerToInt64# s# d#)
instance Eq Int64 where
(I64# x) == (I64# y) = x `eqInt64#` y
......
......@@ -39,7 +39,9 @@ import Monad
import Ix
import PrelGHC
newtype ST s a = ST (PrelST.State s -> (a,PrelST.State s))
newtype ST s a = ST (State s -> (a, State s))
data State s = S# (State# s)
instance Functor (ST s) where
fmap f m = ST $ \ s ->
......@@ -65,7 +67,7 @@ instance Monad (ST s) where
{-# NOINLINE runST #-}
runST :: (forall s. ST s a) -> a
runST st = case st of ST the_st -> let (r,_) = the_st (PrelST.S# realWorld#) in r
runST st = case st of ST the_st -> let (r,_) = the_st (S# realWorld#) in r
\end{code}
%*********************************************************
......@@ -119,15 +121,15 @@ unsafeFreezeSTArray (STArray arr) = strictToLazyST (unsafeFreezeArray arr)
strictToLazyST :: PrelST.ST s a -> ST s a
strictToLazyST m = ST $ \s ->
let
pr = case s of { PrelST.S# s# -> PrelST.liftST m s# }
pr = case s of { S# s# -> PrelST.liftST m s# }
r = case pr of { PrelST.STret _ v -> v }
s' = case pr of { PrelST.STret s2# _ -> PrelST.S# s2# }
s' = case pr of { PrelST.STret s2# _ -> S# s2# }
in
(r, s')
lazyToStrictST :: ST s a -> PrelST.ST s a
lazyToStrictST (ST m) = PrelST.ST $ \s ->
case (m (PrelST.S# s)) of (a, PrelST.S# s') -> (# s', a #)
case (m (S# s)) of (a, S# s') -> (# s', a #)
unsafeInterleaveST :: ST s a -> ST s a
unsafeInterleaveST = strictToLazyST . ST.unsafeInterleaveST . lazyToStrictST
......
......@@ -168,9 +168,6 @@ word32ToInteger (W32# x) = word2Integer x
integerToWord32 :: Integer -> Word32
integerToWord32 = fromInteger
wordToInt :: Word -> Int