Commit d888cbcb authored by ken's avatar ken
Browse files

[project @ 2001-07-24 06:31:35 by ken]

Innocent changes to resurrect/add 64-bit support.
parent f6709386
/* -----------------------------------------------------------------------------
* $Id: PrimOps.h,v 1.78 2001/07/14 00:06:14 sof Exp $
* $Id: PrimOps.h,v 1.79 2001/07/24 06:31:35 ken Exp $
*
* (c) The GHC Team, 1998-2000
*
......@@ -99,8 +99,8 @@
* plugging into a new J#.
*/
#define addIntCzh(r,c,a,b) \
{ r = a + b; \
c = ((StgWord)(~(a^b) & (a^r))) \
{ r = (I_)a + (I_)b; \
c = ((StgWord)(~((I_)a^(I_)b) & ((I_)a^r))) \
>> (BITS_IN (I_) - 1); \
}
......@@ -171,13 +171,13 @@ typedef union {
#else
#define HALF_INT (1 << (BITS_IN (I_) / 2))
#define HALF_INT (1LL << (BITS_IN (I_) / 2))
#define stg_abs(a) ((a) < 0 ? -(a) : (a))
#define mulIntCzh(r,c,a,b) \
{ \
if (stg_abs(a) >= HALF_INT \
if (stg_abs(a) >= HALF_INT || \
stg_abs(b) >= HALF_INT) { \
c = 1; \
} else { \
......
/* -----------------------------------------------------------------------------
* $Id: StgMacros.h,v 1.37 2000/12/04 12:31:20 simonmar Exp $
* $Id: StgMacros.h,v 1.38 2001/07/24 06:31:35 ken Exp $
*
* (c) The GHC Team, 1998-1999
*
......@@ -611,6 +611,29 @@ static inline StgInt64 PK_Int64(W_ p_src[])
y.iu.dlo = p_src[1];
return(y.i);
}
#elif SIZEOF_VOID_P == 8
static inline void ASSIGN_Word64(W_ p_dest[], StgWord64 src)
{
p_dest[0] = src;
}
static inline StgWord64 PK_Word64(W_ p_src[])
{
return p_src[0];
}
static inline void ASSIGN_Int64(W_ p_dest[], StgInt64 src)
{
p_dest[0] = src;
}
static inline StgInt64 PK_Int64(W_ p_src[])
{
return p_src[0];
}
#endif
/* -----------------------------------------------------------------------------
......
% -----------------------------------------------------------------------------
% $Id: PrelEnum.lhs,v 1.13 2001/02/18 14:45:15 qrczak Exp $
% $Id: PrelEnum.lhs,v 1.14 2001/07/24 06:31:35 ken Exp $
%
% (c) The University of Glasgow, 1992-2000
%
......@@ -314,7 +314,7 @@ instance Enum Int where
fromEnum x = x
{-# INLINE enumFrom #-}
enumFrom (I# x) = eftInt x 2147483647#
enumFrom (I# x) = case maxInt of I# y -> eftInt x y
-- Blarg: technically I guess enumFrom isn't strict!
{-# INLINE enumFromTo #-}
......@@ -374,14 +374,14 @@ efdtIntList x1 x2 y
lim = y -# delta
efdIntFB c n x1 x2
| delta >=# 0# = go_up_int_fb c n x1 delta ( 2147483647# -# delta)
| otherwise = go_dn_int_fb c n x1 delta ((-2147483648#) -# delta)
| delta >=# 0# = case maxInt of I# y -> go_up_int_fb c n x1 delta (y -# delta)
| otherwise = case minInt of I# y -> go_dn_int_fb c n x1 delta (y -# delta)
where
delta = x2 -# x1
efdIntList x1 x2
| delta >=# 0# = go_up_int_list x1 delta ( 2147483647# -# delta)
| otherwise = go_dn_int_list x1 delta ((-2147483648#) -# delta)
| delta >=# 0# = case maxInt of I# y -> go_up_int_list x1 delta (y -# delta)
| otherwise = case minInt of I# y -> go_dn_int_list x1 delta (y -# delta)
where
delta = x2 -# x1
......
......@@ -573,7 +573,7 @@ instance Bits Int64 where
isSigned _ = True
{-# RULES
"fromIntegral/a->Int64" fromIntegral = \x -> case fromIntegral x of I# x# -> I64# (intToInt64# x#)
"fromIntegral/a->Int64" fromIntegral = \x -> case fromIntegral x of I# x# -> I64# x#
"fromIntegral/Int64->a" fromIntegral = \(I64# x#) -> fromIntegral (I# x#)
#-}
......
% ------------------------------------------------------------------------------
% $Id: PrelNum.lhs,v 1.39 2001/04/14 22:28:22 qrczak Exp $
% $Id: PrelNum.lhs,v 1.40 2001/07/24 06:31:35 ken Exp $
%
% (c) The University of Glasgow, 1994-2000
%
......@@ -18,6 +18,15 @@ and the type
\begin{code}
{-# OPTIONS -fno-implicit-prelude #-}
#include "MachDeps.h"
#if WORD_SIZE_IN_BYTES == 4
#define LEFTMOST_BIT 2147483648
#elif WORD_SIZE_IN_BYTES == 8
#define LEFTMOST_BIT 9223372036854775808
#else
#error Please define LEFTMOST_BIT to be 2^(WORD_SIZE_IN_BYTES*8-1)
#endif
module PrelNum where
import {-# SOURCE #-} PrelErr
......@@ -130,7 +139,7 @@ toBig i@(J# _ _) = i
\begin{code}
quotRemInteger :: Integer -> Integer -> (Integer, Integer)
quotRemInteger a@(S# (-2147483648#)) b = quotRemInteger (toBig a) b
quotRemInteger a@(S# (-LEFTMOST_BIT#)) b = quotRemInteger (toBig a) b
quotRemInteger (S# i) (S# j)
= case quotRemInt (I# i) (I# j) of ( I# i, I# j ) -> ( S# i, S# j )
quotRemInteger i1@(J# _ _) i2@(S# _) = quotRemInteger i1 (toBig i2)
......@@ -140,7 +149,7 @@ quotRemInteger (J# s1 d1) (J# s2 d2)
(# s3, d3, s4, d4 #)
-> (J# s3 d3, J# s4 d4)
divModInteger a@(S# (-2147483648#)) b = divModInteger (toBig a) b
divModInteger a@(S# (-LEFTMOST_BIT#)) b = divModInteger (toBig a) b
divModInteger (S# i) (S# j)
= case divModInt (I# i) (I# j) of ( I# i, I# j ) -> ( S# i, S# j)
divModInteger i1@(J# _ _) i2@(S# _) = divModInteger i1 (toBig i2)
......@@ -153,7 +162,7 @@ divModInteger (J# s1 d1) (J# s2 d2)
remInteger :: Integer -> Integer -> Integer
remInteger ia 0
= error "Prelude.Integral.rem{Integer}: divide by 0"
remInteger a@(S# (-2147483648#)) b = remInteger (toBig a) b
remInteger a@(S# (-LEFTMOST_BIT#)) b = remInteger (toBig a) b
remInteger (S# a) (S# b) = S# (remInt# a b)
{- Special case doesn't work, because a 1-element J# has the range
-(2^32-1) -- 2^32-1, whereas S# has the range -2^31 -- (2^31-1)
......@@ -174,7 +183,7 @@ remInteger (J# sa a) (J# sb b)
quotInteger :: Integer -> Integer -> Integer
quotInteger ia 0
= error "Prelude.Integral.quot{Integer}: divide by 0"
quotInteger a@(S# (-2147483648#)) b = quotInteger (toBig a) b
quotInteger a@(S# (-LEFTMOST_BIT#)) b = quotInteger (toBig a) b
quotInteger (S# a) (S# b) = S# (quotInt# a b)
{- Special case disabled, see remInteger above
quotInteger (S# a) (J# sb b)
......@@ -195,8 +204,8 @@ quotInteger (J# sa a) (J# sb b)
\begin{code}
gcdInteger :: Integer -> Integer -> Integer
-- SUP: Do we really need the first two cases?
gcdInteger a@(S# (-2147483648#)) b = gcdInteger (toBig a) b
gcdInteger a b@(S# (-2147483648#)) = gcdInteger a (toBig b)
gcdInteger a@(S# (-LEFTMOST_BIT#)) b = gcdInteger (toBig a) b
gcdInteger a b@(S# (-LEFTMOST_BIT#)) = gcdInteger a (toBig b)
gcdInteger (S# a) (S# b) = case gcdInt (I# a) (I# b) of { I# c -> S# c }
gcdInteger ia@(S# 0#) ib@(J# 0# _) = error "PrelNum.gcdInteger: gcd 0 0 is undefined"
gcdInteger ia@(S# a) ib@(J# sb b)
......@@ -221,7 +230,7 @@ lcmInteger a b
ab = abs b
divExact :: Integer -> Integer -> Integer
divExact a@(S# (-2147483648#)) b = divExact (toBig a) b
divExact a@(S# (-LEFTMOST_BIT#)) b = divExact (toBig a) b
divExact (S# a) (S# b) = S# (quotInt# a b)
divExact (S# a) (J# sb b)
= S# (quotInt# a (integer2Int# sb b))
......@@ -310,7 +319,7 @@ instance Num Integer where
fromInteger x = x
-- ORIG: abs n = if n >= 0 then n else -n
abs (S# (-2147483648#)) = 2147483648
abs (S# (-LEFTMOST_BIT#)) = LEFTMOST_BIT
abs (S# i) = case abs (I# i) of I# j -> S# j
abs n@(J# s d) = if (s >=# 0#) then n else J# (negateInt# s) d
......@@ -344,7 +353,7 @@ timesInteger i1@(J# _ _) i2@(S# _) = i1 * toBig i2
timesInteger i1@(S# _) i2@(J# _ _) = toBig i1 * i2
timesInteger (J# s1 d1) (J# s2 d2) = case timesInteger# s1 d1 s2 d2 of (# s, d #) -> J# s d
negateInteger (S# (-2147483648#)) = 2147483648
negateInteger (S# (-LEFTMOST_BIT#)) = LEFTMOST_BIT
negateInteger (S# i) = S# (negateInt# i)
negateInteger (J# s d) = J# (negateInt# s) d
\end{code}
......
% -----------------------------------------------------------------------------
% $Id: PrelStorable.lhs,v 1.7 2001/05/18 16:54:05 simonmar Exp $
% $Id: PrelStorable.lhs,v 1.8 2001/07/24 06:31:35 ken Exp $
%
% (c) The FFI task force, 2000
%
......@@ -224,16 +224,26 @@ readInt16OffPtr (Ptr a) (I# i)
= IO $ \s -> case readInt16OffAddr# a i s of (# s2, x #) -> (# s2, I16# x #)
readInt32OffPtr (Ptr a) (I# i)
= IO $ \s -> case readInt32OffAddr# a i s of (# s2, x #) -> (# s2, I32# x #)
#if WORD_SIZE_IN_BYTES == 4
readInt64OffPtr (Ptr a) (I# i)
= IO $ \s -> case readInt64OffAddr# a i s of (# s2, x #) -> (# s2, I64# x #)
#else
readInt64OffPtr (Ptr a) (I# i)
= IO $ \s -> case readIntOffAddr# a i s of (# s2, x #) -> (# s2, I64# x #)
#endif
readWord8OffPtr (Ptr a) (I# i)
= IO $ \s -> case readWord8OffAddr# a i s of (# s2, x #) -> (# s2, W8# x #)
readWord16OffPtr (Ptr a) (I# i)
= IO $ \s -> case readWord16OffAddr# a i s of (# s2, x #) -> (# s2, W16# x #)
readWord32OffPtr (Ptr a) (I# i)
= IO $ \s -> case readWord32OffAddr# a i s of (# s2, x #) -> (# s2, W32# x #)
#if WORD_SIZE_IN_BYTES == 4
readWord64OffPtr (Ptr a) (I# i)
= IO $ \s -> case readWord64OffAddr# a i s of (# s2, x #) -> (# s2, W64# x #)
#else
readWord64OffPtr (Ptr a) (I# i)
= IO $ \s -> case readWordOffAddr# a i s of (# s2, x #) -> (# s2, W64# x #)
#endif
writeWideCharOffPtr :: Ptr Char -> Int -> Char -> IO ()
writeIntOffPtr :: Ptr Int -> Int -> Int -> IO ()
......@@ -274,16 +284,26 @@ writeInt16OffPtr (Ptr a) (I# i) (I16# x)
= IO $ \s -> case writeInt16OffAddr# a i x s of s2 -> (# s2, () #)
writeInt32OffPtr (Ptr a) (I# i) (I32# x)
= IO $ \s -> case writeInt32OffAddr# a i x s of s2 -> (# s2, () #)
#if WORD_SIZE_IN_BYTES == 4
writeInt64OffPtr (Ptr a) (I# i) (I64# x)
= IO $ \s -> case writeInt64OffAddr# a i x s of s2 -> (# s2, () #)
#else
writeInt64OffPtr (Ptr a) (I# i) (I64# x)
= IO $ \s -> case writeIntOffAddr# a i x s of s2 -> (# s2, () #)
#endif
writeWord8OffPtr (Ptr a) (I# i) (W8# x)
= IO $ \s -> case writeWord8OffAddr# a i x s of s2 -> (# s2, () #)
writeWord16OffPtr (Ptr a) (I# i) (W16# x)
= IO $ \s -> case writeWord16OffAddr# a i x s of s2 -> (# s2, () #)
writeWord32OffPtr (Ptr a) (I# i) (W32# x)
= IO $ \s -> case writeWord32OffAddr# a i x s of s2 -> (# s2, () #)
#if WORD_SIZE_IN_BYTES == 4
writeWord64OffPtr (Ptr a) (I# i) (W64# x)
= IO $ \s -> case writeWord64OffAddr# a i x s of s2 -> (# s2, () #)
#else
writeWord64OffPtr (Ptr a) (I# i) (W64# x)
= IO $ \s -> case writeWordOffAddr# a i x s of s2 -> (# s2, () #)
#endif
#endif /* __GLASGOW_HASKELL__ */
\end{code}
/* -----------------------------------------------------------------------------
* $Id: GC.c,v 1.105 2001/07/24 05:04:58 ken Exp $
* $Id: GC.c,v 1.106 2001/07/24 06:31:36 ken Exp $
*
* (c) The GHC Team 1998-1999
*
......@@ -40,6 +40,7 @@
#if defined(RTS_GTK_FRONTPANEL)
#include "FrontPanel.h"
#endif
#include <stddef.h>
/* STATIC OBJECT LIST.
*
......@@ -527,10 +528,11 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
// scavenge each step in generations 0..maxgen
{
int gen, st;
long gen;
int st;
loop2:
for (gen = RtsFlags.GcFlags.generations-1; gen >= 0; gen--) {
for (st = generations[gen].n_steps-1; st >= 0 ; st--) {
for (gen = RtsFlags.GcFlags.generations; --gen >= 0; ) {
for (st = generations[gen].n_steps; --st >= 0; ) {
if (gen == 0 && st == 0 && RtsFlags.GcFlags.generations > 1) {
continue;
}
......@@ -791,7 +793,7 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
if ( blocks * RtsFlags.GcFlags.oldGenFactor * 2 >
RtsFlags.GcFlags.maxHeapSize ) {
int adjusted_blocks; // signed on purpose
long adjusted_blocks; // signed on purpose
int pc_free;
adjusted_blocks = (RtsFlags.GcFlags.maxHeapSize - 2 * blocks);
......@@ -817,7 +819,7 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
*/
if (RtsFlags.GcFlags.heapSizeSuggestion) {
int blocks;
long blocks;
nat needed = calcNeeded(); // approx blocks needed at next GC
/* Guess how much will be live in generation 0 step 0 next time.
......@@ -841,10 +843,10 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
* collection for collecting all steps except g0s0.
*/
blocks =
(((int)RtsFlags.GcFlags.heapSizeSuggestion - (int)needed) * 100) /
(100 + (int)g0s0_pcnt_kept);
(((long)RtsFlags.GcFlags.heapSizeSuggestion - (long)needed) * 100) /
(100 + (long)g0s0_pcnt_kept);
if (blocks < (int)RtsFlags.GcFlags.minAllocAreaSize) {
if (blocks < (long)RtsFlags.GcFlags.minAllocAreaSize) {
blocks = RtsFlags.GcFlags.minAllocAreaSize;
}
......@@ -1548,7 +1550,7 @@ loop:
case CONSTR_0_2:
case CONSTR_STATIC:
{
StgWord32 offset = info->layout.selector_offset;
StgWord offset = info->layout.selector_offset;
// check that the size is in range
ASSERT(offset <
......@@ -1842,7 +1844,7 @@ loop:
void
move_TSO(StgTSO *src, StgTSO *dest)
{
int diff;
ptrdiff_t diff;
// relocate the stack pointers...
diff = (StgPtr)dest - (StgPtr)src; // In *words*
......@@ -1859,7 +1861,7 @@ move_TSO(StgTSO *src, StgTSO *dest)
-------------------------------------------------------------------------- */
StgTSO *
relocate_stack(StgTSO *dest, int diff)
relocate_stack(StgTSO *dest, ptrdiff_t diff)
{
StgUpdateFrame *su;
StgCatchFrame *cf;
......@@ -2736,7 +2738,7 @@ scavenge_mut_once_list(generation *gen)
} else {
size = gen->steps[0].scan - start;
}
fprintf(stderr,"evac IND_OLDGEN: %d bytes\n", size * sizeof(W_));
fprintf(stderr,"evac IND_OLDGEN: %ld bytes\n", size * sizeof(W_));
}
#endif
......@@ -3438,7 +3440,7 @@ gcCAFs(void)
ASSERT(info->type == IND_STATIC);
if (STATIC_LINK(info,p) == NULL) {
IF_DEBUG(gccafs, fprintf(stderr, "CAF gc'd at 0x%04x\n", (int)p));
IF_DEBUG(gccafs, fprintf(stderr, "CAF gc'd at 0x%04lx\n", (long)p));
// black hole it
SET_INFO(p,&stg_BLACKHOLE_info);
p = STATIC_LINK2(info,p);
......
/* -----------------------------------------------------------------------------
* $Id: MBlock.c,v 1.21 2001/01/16 11:54:25 simonmar Exp $
* $Id: MBlock.c,v 1.22 2001/07/24 06:31:36 ken Exp $
*
* (c) The GHC Team 1998-1999
*
......@@ -85,7 +85,7 @@ getMBlocks(nat n)
barf("GetMBlock: misaligned block %p returned when allocating %d megablock(s) at %p", ret, n, next_request);
}
IF_DEBUG(gc,fprintf(stderr,"Allocated %d megablock(s) at %x\n",n,(nat)ret));
IF_DEBUG(gc,fprintf(stderr,"Allocated %d megablock(s) at %p\n",n,ret));
next_request += size;
......
/* -----------------------------------------------------------------------------
* $Id: Printer.c,v 1.41 2001/07/23 17:23:19 simonmar Exp $
* $Id: Printer.c,v 1.42 2001/07/24 06:31:36 ken Exp $
*
* (c) The GHC Team, 1994-2000.
*
......@@ -287,7 +287,7 @@ void printClosure( StgClosure *obj )
putchar(arrWordsGetChar(obj,i));
} */
for (i=0; i<((StgArrWords *)obj)->words; i++)
fprintf(stderr, "%d", ((StgArrWords *)obj)->payload[i]);
fprintf(stderr, "%ld", ((StgArrWords *)obj)->payload[i]);
fprintf(stderr,"\")\n");
break;
}
......@@ -399,7 +399,7 @@ StgPtr printStackObj( StgPtr sp )
void printStackChunk( StgPtr sp, StgPtr spBottom )
{
StgWord32 bitmap;
StgWord bitmap;
const StgInfoTable *info;
ASSERT(sp <= spBottom);
......@@ -442,12 +442,12 @@ void printStackChunk( StgPtr sp, StgPtr spBottom )
sp++;
small_bitmap:
while (bitmap != 0) {
fprintf(stderr," stk[%d] (%p) = ", spBottom-sp, sp);
fprintf(stderr," stk[%ld] (%p) = ", spBottom-sp, sp);
if ((bitmap & 1) == 0) {
printPtr((P_)*sp);
fprintf(stderr,"\n");
} else {
fprintf(stderr,"Word# %d\n", *sp++);
fprintf(stderr,"Word# %ld\n", *sp++);
}
sp++;
bitmap = bitmap >> 1;
......@@ -462,7 +462,7 @@ void printStackChunk( StgPtr sp, StgPtr spBottom )
break;
}
}
fprintf(stderr,"Stack[%d] (%p) = ", spBottom-sp, sp);
fprintf(stderr,"Stack[%ld] (%p) = ", spBottom-sp, sp);
sp = printStackObj(sp);
}
}
......
/* -----------------------------------------------------------------------------
* $Id: RtsUtils.c,v 1.18 2001/02/13 11:10:28 rrt Exp $
* $Id: RtsUtils.c,v 1.19 2001/07/24 06:31:36 ken Exp $
*
* (c) The GHC Team, 1998-1999
*
......@@ -113,7 +113,7 @@ stgReallocWords (void *p, int n, char *msg)
}
void
_stgAssert (char *filename, nat linenum)
_stgAssert (char *filename, unsigned int linenum)
{
fflush(stdout);
fprintf(stderr, "ASSERTION FAILED: file %s, line %u\n", filename, linenum);
......
/* ---------------------------------------------------------------------------
* $Id: Schedule.c,v 1.97 2001/07/23 17:23:19 simonmar Exp $
* $Id: Schedule.c,v 1.98 2001/07/24 06:31:36 ken Exp $
*
* (c) The GHC Team, 1998-2000
*
......@@ -2920,7 +2920,7 @@ raiseAsync(StgTSO *tso, StgClosure *exception)
}
while (1) {
int words = ((P_)su - (P_)sp) - 1;
nat words = ((P_)su - (P_)sp) - 1;
nat i;
StgAP_UPD * ap;
......
/* -----------------------------------------------------------------------------
* $Id: Storage.h,v 1.34 2001/07/23 17:23:20 simonmar Exp $
* $Id: Storage.h,v 1.35 2001/07/24 06:31:36 ken Exp $
*
* (c) The GHC Team, 1998-1999
*
......@@ -497,16 +497,13 @@ extern int is_heap_alloced(const void* x);
Macros for calculating how big a closure will be (used during allocation)
-------------------------------------------------------------------------- */
/* ToDo: replace unsigned int by nat. The only fly in the ointment is that
* nat comes from Rts.h which many folk dont include. Sigh!
*/
static __inline__ StgOffset AP_sizeW ( unsigned int n_args )
static __inline__ StgOffset AP_sizeW ( nat n_args )
{ return sizeofW(StgAP_UPD) + n_args; }
static __inline__ StgOffset PAP_sizeW ( unsigned int n_args )
static __inline__ StgOffset PAP_sizeW ( nat n_args )
{ return sizeofW(StgPAP) + n_args; }
static __inline__ StgOffset CONSTR_sizeW( unsigned int p, unsigned int np )
static __inline__ StgOffset CONSTR_sizeW( nat p, nat np )
{ return sizeofW(StgHeader) + p + np; }
static __inline__ StgOffset THUNK_SELECTOR_sizeW ( void )
......
/* -----------------------------------------------------------------------------
* $Id: Updates.hc,v 1.33 2001/03/23 16:36:21 simonmar Exp $
* $Id: Updates.hc,v 1.34 2001/07/24 06:31:36 ken Exp $
*
* (c) The GHC Team, 1998-1999
*
......@@ -306,7 +306,7 @@ EXTFUN(stg_update_PAP)
/* Now fill in the closure fields */
p = Hp;
for (i = Words-1; i >= 0; i--) {
for (i = Words; --i >= 0; ) {
*p-- = (W_) Sp[i];
}
}
......@@ -384,7 +384,7 @@ EXTFUN(stg_update_PAP)
/*
* Squeeze out update frame from stack.
*/
for (i = Words-1; i >= 0; i--) {
for (i = Words; --i >= 0; ) {
Sp[i+(sizeofW(StgUpdateFrame))] = Sp[i];
}
Sp += sizeofW(StgUpdateFrame);
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment