[patch] Modified source patch

s48-64.patch (text/plain), 15.53 KB, created by Olof Frahm on 2007-09-28 16:06:36 UTC

diff -ru scheme48-1.3~/configure.in scheme48-1.3/configure.in
--- scheme48-1.3~/configure.in	Wed Apr 27 08:45:29 2005
+++ scheme48-1.3/configure.in	Fri Sep  1 05:02:39 2006
@@ -44,8 +44,9 @@
 define(S48_IEEE_ENDIANNESS, [dnl
 AC_MSG_CHECKING([IEEE floating-point endianness])
 AC_TRY_RUN([#include <stdio.h>
+#include <inttypes.h>
 
-typedef unsigned long word32_t;
+typedef uint32_t word32_t;
 
 typedef union { double d; word32_t word[2]; } double_overlay;
 
diff -ru scheme48-1.3~/c/bignumint.h scheme48-1.3/c/bignumint.h
--- scheme48-1.3~/c/bignumint.h	Wed Apr 27 08:45:24 2005
+++ scheme48-1.3/c/bignumint.h	Sun Aug 20 07:44:13 2006
@@ -52,13 +52,12 @@
    `bignum_digit_type'; deallocation is the responsibility of the
    user (in Scheme, the garbage collector handles this). */
 #define BIGNUM_ALLOCATE_TAGGED(length_in_digits)		\
-    ((long *) s48_allocate_bignum((length_in_digits + 1) *	\
-                                  sizeof(bignum_digit_type)))
+    (s48_allocate_bignum((length_in_digits + 1) *		\
+                         sizeof(bignum_digit_type)))
 #define BIGNUM_ALLOCATE(length_in_digits)			\
-    (S48_ADDRESS_AFTER_HEADER(((char *)				\
-			       BIGNUM_ALLOCATE_TAGGED((length_in_digits))), \
+    (S48_ADDRESS_AFTER_HEADER((BIGNUM_ALLOCATE_TAGGED((length_in_digits))), \
 			       long))
-extern char *	s48_allocate_bignum(long size);
+extern s48_value	s48_allocate_bignum(long size);
 
 /* BIGNUM_TO_POINTER casts a bignum object to a digit array pointer. */
 #define BIGNUM_TO_POINTER(bignum) ((bignum_digit_type *) (bignum))
diff -ru scheme48-1.3~/c/extension.c scheme48-1.3/c/extension.c
--- scheme48-1.3~/c/extension.c	Wed Apr 27 08:45:25 2005
+++ scheme48-1.3/c/extension.c	Fri Sep  1 03:59:16 2006
@@ -17,8 +17,8 @@
 
 #include "scheme48.h"
 
-#define GREATEST_FIXNUM_VALUE ((1 << 29) - 1)
-#define LEAST_FIXNUM_VALUE (-1 << 29)
+#define GREATEST_FIXNUM_VALUE ((1L << 61) - 1)
+#define LEAST_FIXNUM_VALUE (-1L << 61)
 #define CHANNEL_INDEX(x) EXTRACT_FIXNUM(STOB_REF(x, 1))
 #define FOR_INPUT 1
 #define FOR_OUTPUT 2
diff -ru scheme48-1.3~/c/free.c scheme48-1.3/c/free.c
--- scheme48-1.3~/c/free.c	Sun May 22 14:15:10 2005
+++ scheme48-1.3/c/free.c	Fri Sep  1 04:58:44 2006
@@ -24,13 +24,15 @@
 #include "sysdep.h"
 #endif
 
-typedef unsigned long word32_t;
+#include <inttypes.h>
 
+typedef uint32_t word32_t;
+
 /* It's a shame ... */
 #ifdef _WIN32
 #define UNSIGNED64 unsigned _int64
 #else
-#define UNSIGNED64 unsigned long long
+#define UNSIGNED64 uint64_t
 #endif
 
 #define U32 word32_t
diff -ru scheme48-1.3~/c/scheme48.h.in scheme48-1.3/c/scheme48.h.in
--- scheme48-1.3~/c/scheme48.h.in	Wed Apr 27 08:45:28 2005
+++ scheme48-1.3/c/scheme48.h.in	Fri Sep  1 03:59:15 2006
@@ -42,8 +42,8 @@
 /* Superceded name for the above definition, retained for compatibility. */
 #define S48_EQ(v1, v2) ((v1) == (v2)) 
 
-#define S48_MAX_FIXNUM_VALUE ((1 << 29) - 1)
-#define S48_MIN_FIXNUM_VALUE (-1 << 29)
+#define S48_MAX_FIXNUM_VALUE ((1L << 61) - 1)
+#define S48_MIN_FIXNUM_VALUE (-1L << 61)
 
 S48_EXTERN int		s48_stob_has_type(s48_value, int);
 S48_EXTERN long		s48_stob_length(s48_value, int);
diff -ru scheme48-1.3~/ps-compiler/prescheme/primop/primop.scm scheme48-1.3/ps-compiler/prescheme/primop/primop.scm
--- scheme48-1.3~/ps-compiler/prescheme/primop/primop.scm	Wed Apr 27 08:45:35 2005
+++ scheme48-1.3/ps-compiler/prescheme/primop/primop.scm	Fri Sep  1 03:42:33 2006
@@ -154,7 +154,7 @@
 ; Randomness needed by both arith.scm and c-arith.scm.
 
 ; What we will get in C.
-(define prescheme-integer-size 32)
+(define prescheme-integer-size 64)
 
 (define int-mask (- (arithmetic-shift 1 prescheme-integer-size) 1))
 
diff -ru scheme48-1.3~/scheme/link/data.scm scheme48-1.3/scheme/link/data.scm
--- scheme48-1.3~/scheme/link/data.scm	Wed Apr 27 08:45:50 2005
+++ scheme48-1.3/scheme/link/data.scm	Sun Aug 20 08:35:34 2006
@@ -20,11 +20,11 @@
 ; Essential constants
 
 (define level          17)
-(define little-endian? #t)
+(define little-endian? #f)
 (define bits-per-byte  8)
-(define bytes-per-cell 4)
+(define bytes-per-cell 8)               ; [64-bit]
 (define bits-per-cell  (* bits-per-byte bytes-per-cell))
-(define addressing-units-per-cell 4)
+(define addressing-units-per-cell 8)    ; [64-bit]
 
 ; This is actually the mimimum for the different PreScheme implementations.
 ; The Scheme version of PreScheme leaves 30 bits for PreScheme's fixnums.
@@ -32,7 +32,7 @@
 ; USEFUL-BITS-PER-WORD is not written in the image.
 (define useful-bits-per-word      30)
 
-(define unused-field-width 2)
+(define unused-field-width 3)           ; [64-bit]
 
 (define tag-field-width 2)
 
@@ -119,7 +119,13 @@
 					     header-type-field-width))))
 
 (define (make-stob-descriptor addr)
-  (make-descriptor (enum tag stob) (a-units->cells addr)))
+;;   (make-descriptor (enum tag stob) (a-units->cells addr))
+  ;++ ick
+;;   (make-descriptor (enum tag stob)
+;;                    (arithmetic-shift (a-units->cells addr)
+;;                                      (- unused-field-width
+;;                                         tag-field-width)))
+  (+ addr (enum tag stob)))
 
 (define (bytes->cells bytes)
   (quotient (+ bytes (- bytes-per-cell 1))
diff -ru scheme48-1.3~/scheme/link/generate-c-header.scm scheme48-1.3/scheme/link/generate-c-header.scm
--- scheme48-1.3~/scheme/link/generate-c-header.scm	Wed Apr 27 08:45:50 2005
+++ scheme48-1.3/scheme/link/generate-c-header.scm	Fri Sep  1 04:27:51 2006
@@ -131,7 +131,7 @@
     (c-define "S48_STOB_HEADER(x) (S48_STOB_REF((x),-1))")
     (c-define "S48_STOB_ADDRESS(x) (&(S48_STOB_HEADER(x)))")
     (c-define "S48_STOB_BYTE_LENGTH(x) (S48_STOB_HEADER(x) >> 8)")
-    (c-define "S48_STOB_DESCRIPTOR_LENGTH(x) (S48_STOB_HEADER(x) >> 10)")
+    (c-define "S48_STOB_DESCRIPTOR_LENGTH(x) (S48_STOB_HEADER(x) >> 11)")
     (c-define "S48_STOB_IMMUTABLEP(x) ((S48_STOB_HEADER(x)>>7) & 1)")
     (c-define "S48_STOB_MAKE_IMMUTABLE(x) ((S48_STOB_HEADER(x)) |= (1<<7))")
     (newline)
diff -ru scheme48-1.3~/scheme/prescheme/memory.scm scheme48-1.3/scheme/prescheme/memory.scm
--- scheme48-1.3~/scheme/prescheme/memory.scm	Wed Apr 27 08:46:08 2005
+++ scheme48-1.3/scheme/prescheme/memory.scm	Sun Jan  8 00:43:59 2006
@@ -129,12 +129,16 @@
   (let ((address (address-index address)))
     (let ((vector (address->vector address))
 	  (byte-address (address->vector-index address)))
-      (if (not (= 0 (bitwise-and byte-address 3)))
+      (if (not (= 0 (bitwise-and byte-address 5))) ; [64-bit]
 	  (error "unaligned address error" address)
-	  (+ (+ (arithmetic-shift (signed-code-vector-ref vector byte-address) 24)
-		(arithmetic-shift (code-vector-ref vector (+ byte-address 1)) 16))
-	     (+ (arithmetic-shift (code-vector-ref vector (+ byte-address 2))  8)
-		(code-vector-ref vector (+ byte-address 3))))))))
+          (+ (arithmetic-shift (signed-code-vector-ref vector byte-address) 56)
+             (arithmetic-shift (code-vector-ref vector (+ byte-address 1))  48)
+             (arithmetic-shift (code-vector-ref vector (+ byte-address 2))  40)
+             (arithmetic-shift (code-vector-ref vector (+ byte-address 3))  32)
+             (arithmetic-shift (code-vector-ref vector (+ byte-address 4))  24)
+             (arithmetic-shift (code-vector-ref vector (+ byte-address 5))  16)
+             (arithmetic-shift (code-vector-ref vector (+ byte-address 6))   8)
+                               (code-vector-ref vector (+ byte-address 7)))))))
   
 (define (unsigned-byte-set! address value)
   (let ((address (address-index address)))
@@ -149,12 +153,20 @@
       (if (not (= 0 (bitwise-and byte-address 3)))
 	  (error "unaligned address error" address))
       (code-vector-set! vector    byte-address
-			(bitwise-and 255 (arithmetic-shift value -24)))
+                        (bitwise-and 255 (arithmetic-shift value -56)))
       (code-vector-set! vector (+ byte-address 1)
-			(bitwise-and 255 (arithmetic-shift value -16)))
+                        (bitwise-and 255 (arithmetic-shift value -48)))
       (code-vector-set! vector (+ byte-address 2)
-			(bitwise-and 255 (arithmetic-shift value -8)))
+                        (bitwise-and 255 (arithmetic-shift value -40)))
       (code-vector-set! vector (+ byte-address 3)
+                        (bitwise-and 255 (arithmetic-shift value -32)))
+      (code-vector-set! vector (+ byte-address 4)
+			(bitwise-and 255 (arithmetic-shift value -24)))
+      (code-vector-set! vector (+ byte-address 5)
+			(bitwise-and 255 (arithmetic-shift value -16)))
+      (code-vector-set! vector (+ byte-address 6)
+			(bitwise-and 255 (arithmetic-shift value -8)))
+      (code-vector-set! vector (+ byte-address 7)
 			(bitwise-and 255 value)))))
 
 ; With the right access to the flonum bits we could actually make these
@@ -190,12 +202,11 @@
 	   (let ((vector (address->vector address))
 		 (byte-address (address->vector-index address)))
 	     (let loop ((i 0))
-	       (if (or (= i count)
-		       (not (byte-ready? port)))
+	       (if (= i count)
 		   (values i #f (enum errors no-errors))
		   (let ((b (read-byte port)))
 		     (cond ((eof-object? b)
-			    (values i #f (enum errors no-errors)))
+			    (values i #t (enum errors no-errors)))
 			   (else
 			    (code-vector-set! vector
 					      (+ i byte-address)
diff -ru scheme48-1.3~/scheme/prescheme/package-defs.scm scheme48-1.3/scheme/prescheme/package-defs.scm
--- scheme48-1.3~/scheme/prescheme/package-defs.scm	Wed Apr 27 08:46:08 2005
+++ scheme48-1.3/scheme/prescheme/package-defs.scm	Sat Jan  7 05:13:53 2006
@@ -21,7 +21,7 @@
   (optimize auto-integrate)
   (begin
     ; What we will get in C on many machines
-    (define pre-scheme-integer-size 32))
+    (define pre-scheme-integer-size 64)) ; [64-bit]
   (files ps-defenum prescheme memory))
 
 (define-structure ps-record-types (export define-record-type)
diff -ru scheme48-1.3~/scheme/vm/interfaces.scm scheme48-1.3/scheme/vm/interfaces.scm
--- scheme48-1.3~/scheme/vm/interfaces.scm	Wed Apr 27 08:45:43 2005
+++ scheme48-1.3/scheme/vm/interfaces.scm	Sat Jan  7 05:11:42 2006
@@ -36,6 +36,7 @@
 	  address-after-header
 	  stob-header stob-header-set!
 	  stob-overhead
+          reverse-descriptor-byte-order!
 	  ))
 
 ; Low-level data structures
diff -ru scheme48-1.3~/scheme/vm/package-defs.scm scheme48-1.3/scheme/vm/package-defs.scm
--- scheme48-1.3~/scheme/vm/package-defs.scm	Wed Apr 27 08:45:41 2005
+++ scheme48-1.3/scheme/vm/package-defs.scm	Thu Aug 31 04:41:24 2006
@@ -547,7 +547,8 @@
   (files (arith bignum-arith)))
 
 (define-structure integer-arithmetic integer-arithmetic-interface
-  (open prescheme 
+  (open prescheme
+        system-spec
 	fixnum-arithmetic
 	bignum-arithmetic
 	external
diff -ru scheme48-1.3~/scheme/vm/ps-package-defs.scm scheme48-1.3/scheme/vm/ps-package-defs.scm
--- scheme48-1.3~/scheme/vm/ps-package-defs.scm	Wed Apr 27 08:45:44 2005
+++ scheme48-1.3/scheme/vm/ps-package-defs.scm	Sun Aug 20 07:07:51 2006
@@ -111,6 +111,6 @@
 (define-structures ((system-spec (export useful-bits-per-word)))
   (open prescheme)
   (begin
-    (define useful-bits-per-word 32)   ; when compiled
+    (define useful-bits-per-word 64)   ; when compiled [64-bit]
     ))
 
diff -ru scheme48-1.3~/scheme/vm/arith/bignum-low.scm scheme48-1.3/scheme/vm/arith/bignum-low.scm
--- scheme48-1.3~/scheme/vm/arith/bignum-low.scm	Wed Apr 27 08:45:44 2005
+++ scheme48-1.3/scheme/vm/arith/bignum-low.scm	Thu Aug 31 03:56:50 2006
@@ -17,7 +17,7 @@
 (define (bignum-digits->size n)
   (bignum-size (cells->bytes (+ n 1))))
 
-(define bignum-digit-bits 30)		; BIGNUM_DIGIT_LENGTH in bignumint.h
+(define bignum-digit-bits 62)		; BIGNUM_DIGIT_LENGTH in bignumint.h
 
 (define (bignum-bits-to-digits n)
   (quotient (+ n (- bignum-digit-bits 1))
diff -ru scheme48-1.3~/scheme/vm/arith/integer.scm scheme48-1.3/scheme/vm/arith/integer.scm
--- scheme48-1.3~/scheme/vm/arith/integer.scm	Wed Apr 27 08:45:44 2005
+++ scheme48-1.3/scheme/vm/arith/integer.scm	Thu Aug 31 04:41:38 2006
@@ -67,4 +67,4 @@
        (long->bignum x key)
        (enter-fixnum x)))
 
-(define long-as-integer-size (bignum-bits-to-size 32))
+(define long-as-integer-size (bignum-bits-to-size useful-bits-per-word))
diff -ru scheme48-1.3~/scheme/vm/data/data.scm scheme48-1.3/scheme/vm/data/data.scm
--- scheme48-1.3~/scheme/vm/data/data.scm	Wed Apr 27 08:45:44 2005
+++ scheme48-1.3/scheme/vm/data/data.scm	Sun Aug 20 08:01:29 2006
@@ -13,7 +13,7 @@
 ; Fundamental parameters
 
 (define bits-per-byte 8)
-(define bytes-per-cell 4)
+(define bytes-per-cell 8)               ; [64-bit]
 (define bits-per-cell (* bits-per-byte bytes-per-cell))
 
 (define (bytes->cells bytes)
@@ -20,7 +20,7 @@
   ; using shift instead of quotient for speed
   ; (quotient (+ bytes (- bytes-per-cell 1)) bytes-per-cell)
   (arithmetic-shift-right (+ bytes (- bytes-per-cell 1))
-			  2))  ; log(bytes-per-cell)
+			  3))  ; log(bytes-per-cell) [64-bit]
 
 (define (cells->bytes cells)
   (* cells bytes-per-cell))
@@ -40,9 +40,9 @@
 ;  number of "unused bits" at its low end.  On a byte-addressable machine with
 ;  32 bit addresses, there are two.
 
-(define unused-field-width 2)
+(define unused-field-width 3)           ; [64-bit]
 
-(define addressing-units-per-cell 4)
+(define addressing-units-per-cell 8)    ; [64-bit]
 
 (define (cells->a-units cells)
   (adjoin-bits cells 0 unused-field-width))
@@ -74,10 +74,6 @@
 (define (unsigned-descriptor-data descriptor)
   (unsigned-high-bits descriptor tag-field-width))
 
-(define (set-descriptor-tag proto-descriptor tag)
-  (assert (= 0 (descriptor-tag proto-descriptor)))
-  (+ proto-descriptor tag))
-
 (define vm-eq? =)
 
 ; The four tags are: fixnum, immediate (character, boolean, etc.),
@@ -294,7 +290,7 @@
 ;  cell number of the first cell after the object's header cell.
 
 (define (add-stob-tag address-as-integer)
-  (set-descriptor-tag address-as-integer (enum tag stob)))
+  (+ address-as-integer (enum tag stob)))
 
 (define (remove-stob-tag stob)
   (- stob (enum tag stob)))
diff -ru scheme48-1.3~/scheme/vm/data/memory.scm scheme48-1.3/scheme/vm/data/memory.scm
--- scheme48-1.3~/scheme/vm/data/memory.scm	Wed Apr 27 08:45:44 2005
+++ scheme48-1.3/scheme/vm/data/memory.scm	Sat Jan 14 23:16:20 2006
@@ -26,7 +26,7 @@
 	   (if (not (= *memory-end* 0))
 	       (deallocate-memory *memory*))
            (set! *memory* (allocate-memory size))
-	   (if (= -1 *memory*)
+	   (if (null-address? *memory*)
 	       (error "out of memory, unable to continue"))
 	   (set! *memory-begin* *memory*)
            (set! *memory-end* (+ *memory* size))))))
@@ -61,3 +61,14 @@
 
 (define (stob-header-set! stob header)
   (store! (address-at-header stob) header))
+
+(define (reverse-descriptor-byte-order! address)
+  (do ((i 0 (+ i 1))
+       (j (- bytes-per-cell 1) (- j 1)))
+      ((>= i j))
+    (let ((addr-a (address+ address i))
+          (addr-b (address+ address j)))
+      (let ((byte-a (fetch-byte addr-a))
+            (byte-b (fetch-byte addr-b)))
+        (store-byte! addr-a byte-b)
+        (store-byte! addr-b byte-a)))))
diff -ru scheme48-1.3~/scheme/vm/heap/read-image.scm scheme48-1.3/scheme/vm/heap/read-image.scm
--- scheme48-1.3~/scheme/vm/heap/read-image.scm	Wed Apr 27 08:45:45 2005
+++ scheme48-1.3/scheme/vm/heap/read-image.scm	Sat Jan  7 05:11:37 2006
@@ -224,18 +224,6 @@
 	(unspecific)))
   -1)
 
-; ABCD => DCBA
-
-; memory intensive, but independent of Scheme's integer size
-
-(define (reverse-descriptor-byte-order! addr)
-  (let ((x (fetch-byte addr)))
-    (store-byte! addr (fetch-byte (address+ addr 3)))
-    (store-byte! (address+ addr 3) x))
-  (let ((x (fetch-byte (address+ addr 1))))
-    (store-byte! (address+ addr 1) (fetch-byte (address+ addr 2)))
-    (store-byte! (address+ addr 2) x)))
-
 (define (s48-reverse-byte-order! start end)
   (error-message "Correcting byte order of resumed image.")
   (let loop ((ptr start))