From: Alastair Bridgewater Date: Sun, 14 Feb 2010 16:30:50 +0000 (-0500) Subject: General disentwingling of fixnums and words. X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=7e02fe01f102c9e536df701dc783149a8d76b3fc;p=sbcl.git General disentwingling of fixnums and words. * Historically, n-fixnum-tag-bits has been equal to word-shift and has been (1- n-lowtag-bits). This led to implementors using constants and calculations which happened to be right by coincidence rather than by design. * Fix all places not part of the support for a particular backend to use the defined-correct constants and calculations for the operations being performed. * Thanks to Paul Khuong for helping with the finding and fixing of many of these coincidences. --- diff --git a/src/code/bit-bash.lisp b/src/code/bit-bash.lisp index 17d0e1e..cb54b81 100644 --- a/src/code/bit-bash.lisp +++ b/src/code/bit-bash.lisp @@ -93,14 +93,14 @@ (type index offset) (values sb!vm:word) (optimize (speed 3) (safety 0) #-sb-xc-host (inhibit-warnings 3))) - (sap-ref-word sap (the index (ash offset sb!vm:n-fixnum-tag-bits)))) + (sap-ref-word sap (the index (ash offset sb!vm:word-shift)))) (defun %set-word-sap-ref (sap offset value) (declare (type system-area-pointer sap) (type index offset) (type sb!vm:word value) (values sb!vm:word) (optimize (speed 3) (safety 0) (inhibit-warnings 3))) - (setf (sap-ref-word sap (the index (ash offset sb!vm:n-fixnum-tag-bits))) + (setf (sap-ref-word sap (the index (ash offset sb!vm:word-shift))) value)) @@ -120,15 +120,21 @@ (declare (type system-area-pointer sap) (type index offset) (values system-area-pointer index)) - (let ((address (sap-int sap))) - (values (int-sap #!-alpha (word-logical-andc2 address - sb!vm:fixnum-tag-mask) - #!+alpha (ash (ash address -2) 2)) + (let ((address (sap-int sap)) + (word-mask (1- (ash 1 word-shift)))) + (values (int-sap #!-alpha (word-logical-andc2 address word-mask) + ;; KLUDGE: WORD-LOGICAL-ANDC2 is defined in + ;; terms of n-word-bits. On all systems + ;; where n-word-bits is not equal to + ;; n-machine-word-bits we have to do this + ;; another way. At this time, these + ;; systems are alphas, though there was + ;; some talk about an x86-64 build option. + #!+alpha (ash (ash address (- word-shift)) word-shift)) (+ ,(ecase bitsize - (1 '(* (logand address sb!vm:fixnum-tag-mask) n-byte-bits)) - (2 '(* (logand address sb!vm:fixnum-tag-mask) (/ n-byte-bits 2))) - (4 '(* (logand address sb!vm:fixnum-tag-mask) (/ n-byte-bits 4))) - ((8 16 32 64) '(logand address sb!vm:fixnum-tag-mask))) + ((1 2 4) `(* (logand address word-mask) + (/ n-byte-bits ,bitsize))) + ((8 16 32 64) '(logand address word-mask))) offset))))))) ;;; We cheat a little bit by using TRULY-THE in the copying function to diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 9df9a29..ef48049 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -527,11 +527,13 @@ #!-stack-grows-downward-not-upward (and (sap< x (current-sp)) (sap<= control-stack-start x) - (or (not aligned) (zerop (logand (sap-int x) sb!vm:fixnum-tag-mask)))) + (or (not aligned) (zerop (logand (sap-int x) + (1- (ash 1 sb!vm:word-shift)))))) #!+stack-grows-downward-not-upward (and (sap>= x (current-sp)) (sap> control-stack-end x) - (or (not aligned) (zerop (logand (sap-int x) sb!vm:fixnum-tag-mask)))))) + (or (not aligned) (zerop (logand (sap-int x) + (1- (ash 1 sb!vm:word-shift)))))))) (declaim (inline component-ptr-from-pc)) (sb!alien:define-alien-routine component-ptr-from-pc (system-area-pointer) diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 9203077..9dd2264 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -381,9 +381,9 @@ ;; it's hard to see how it could have been wrong, since CMU CL ;; genesis worked. It would be nice to understand how this came ;; to be.. -- WHN 19990901 - (logior (ash bits (- 1 sb!vm:n-lowtag-bits)) + (logior (ash bits (- sb!vm:n-fixnum-tag-bits)) (ash -1 (1+ sb!vm:n-positive-fixnum-bits))) - (ash bits (- 1 sb!vm:n-lowtag-bits))))) + (ash bits (- sb!vm:n-fixnum-tag-bits))))) (defun descriptor-word-sized-integer (des) ;; Extract an (unsigned-byte 32), from either its fixnum or bignum @@ -458,9 +458,9 @@ (defun make-fixnum-descriptor (num) (when (>= (integer-length num) - (1+ (- sb!vm:n-word-bits sb!vm:n-lowtag-bits))) + (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits)) (error "~W is too big for a fixnum." num)) - (make-random-descriptor (ash num (1- sb!vm:n-lowtag-bits)))) + (make-random-descriptor (ash num sb!vm:n-fixnum-tag-bits))) (defun make-other-immediate-descriptor (data type) (make-descriptor (ash data (- sb!vm:n-widetag-bits descriptor-low-bits)) @@ -768,7 +768,7 @@ core and return a descriptor to it." (defun number-to-core (number) (typecase number (integer (if (< (integer-length number) - (- (1+ sb!vm:n-word-bits) sb!vm:n-lowtag-bits)) + (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits)) (make-fixnum-descriptor number) (bignum-to-core number))) (ratio (number-pair-to-core (number-to-core (numerator number)) @@ -2308,9 +2308,9 @@ core and return a descriptor to it." (* total-elements (logior (ash (descriptor-high dim) (- descriptor-low-bits - (1- sb!vm:n-lowtag-bits))) + sb!vm:n-fixnum-tag-bits)) (ash (descriptor-low dim) - (- 1 sb!vm:n-lowtag-bits))))) + sb!vm:n-fixnum-tag-bits)))) (write-wordindexed result (+ sb!vm:array-dimensions-offset axis) dim))) diff --git a/src/compiler/generic/utils.lisp b/src/compiler/generic/utils.lisp index 3625f66..d4192d3 100644 --- a/src/compiler/generic/utils.lisp +++ b/src/compiler/generic/utils.lisp @@ -15,7 +15,7 @@ ;;; Make a fixnum out of NUM. (I.e. shift by two bits if it will fit.) (defun fixnumize (num) (if (fixnump num) - (ash num (1- n-lowtag-bits)) + (ash num n-fixnum-tag-bits) (error "~W is too big for a fixnum." num))) ;;; Determining whether a constant offset fits in an addressing mode. diff --git a/src/runtime/alloc.c b/src/runtime/alloc.c index 58c1798..f67ccd0 100644 --- a/src/runtime/alloc.c +++ b/src/runtime/alloc.c @@ -197,9 +197,9 @@ alloc_code_object (unsigned boxed, unsigned unboxed) { /* Coming in, boxed is the number of boxed words requested. * Converting it to a fixnum makes it measured in bytes. It's also * rounded up to double word along the way. */ - boxed = make_fixnum(boxed + 1 + - (offsetof(struct code, trace_table_offset) >> - WORD_SHIFT)); + boxed = (boxed + 1 + + (offsetof(struct code, trace_table_offset) >> + WORD_SHIFT)) << WORD_SHIFT; boxed &= ~LOWTAG_MASK; /* Unboxed is in bytes, round it up to double word boundary. Now @@ -216,7 +216,7 @@ alloc_code_object (unsigned boxed, unsigned unboxed) { lose("alloc_code_object called with GC enabled."); boxed = boxed << (N_WIDETAG_BITS - WORD_SHIFT); code->header = boxed | CODE_HEADER_WIDETAG; - code->code_size = unboxed; + code->code_size = unboxed >> (WORD_SHIFT - N_FIXNUM_TAG_BITS); code->entry_points = NIL; code->debug_info = NIL; return make_lispobj(code, OTHER_POINTER_LOWTAG); diff --git a/src/runtime/breakpoint.c b/src/runtime/breakpoint.c index a325693..5cada3e 100644 --- a/src/runtime/breakpoint.c +++ b/src/runtime/breakpoint.c @@ -116,7 +116,7 @@ static long compute_offset(os_context_t *context, lispobj code) return 0; else { unsigned long offset = pc - code_start; - if (offset >= codeptr->code_size) + if (offset >= (N_WORD_BYTES * fixnum_value(codeptr->code_size))) return 0; else return make_fixnum(offset);