From: William Harold Newman Date: Sun, 5 Nov 2000 21:37:59 +0000 (+0000) Subject: 0.6.8.9: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=2716573f357f204c5f546d1d34d285dd24ff43a1;p=sbcl.git 0.6.8.9: tweaked DEFCONSTANTs to be more ANSI-compliant (as required when building using an XC host incorporating changes from the previous commit) and generally cleaner got rid of DEFCONSTANT WRAPPER-LAYOUT completely, which was used only by STRUCTURE-WRAPPER, which is now gone added SB-INT:DEFCONSTANT-EQX to help ANSIfy DEFCONSTANTs merged several small files into primordial-extensions.lisp converted DEFMACRO DEFCONSTANT to use EVAL-WHEN instead of IR1 magic, in order to make it ANSI enough for DEFCONSTANT-EQX to work removed various nested EVAL-WHENs (to help cross-compiler) identified bug IR1-3, added workaround in DO-EVAL-WHEN-STUFF incremented fasl file version (because of mismatch between old IR1 magic %DEFCONSTANT/%%DEFCONSTANT behavior and new EVAL-WHEN %DEFCONSTANT behavior) deleted some unused code fixed (DEFCONSTANT X 1) (DEFVAR X) (SETF X 2) bug --- diff --git a/src/compiler/x86/backend-parms.lisp b/src/compiler/x86/backend-parms.lisp index 788370a..b891618 100644 --- a/src/compiler/x86/backend-parms.lisp +++ b/src/compiler/x86/backend-parms.lisp @@ -19,7 +19,7 @@ (setf *backend-fasl-file-type* "x86f") (setf *backend-fasl-file-implementation* :x86) -(setf *backend-fasl-file-version* 5) +(setf *backend-fasl-file-version* 6) ;;; 2 = sbcl-0.6.4 uses COMPILE-OR-LOAD-DEFGENERIC. ;;; 3 = sbcl-0.6.6 uses private symbol, not :EMPTY, for empty HASH-TABLE slot. ;;; 4 = sbcl-0.6.7 uses HAIRY-DATA-VECTOR-REF and HAIRY-DATA-VECTOR-SET @@ -29,6 +29,7 @@ ;;; fasl files would fail, because there are no DEFUNs for these ;;; operations any more.) ;;; 5 = sbcl-0.6.8 has rearranged static symbols. +;;; 6 = sbcl-0.6.9 got rid of non-ANSI %DEFCONSTANT/%%DEFCONSTANT stuff. (setf *backend-register-save-penalty* 3) diff --git a/src/compiler/x86/call.lisp b/src/compiler/x86/call.lisp index 53ca4cb..37a582c 100644 --- a/src/compiler/x86/call.lisp +++ b/src/compiler/x86/call.lisp @@ -19,7 +19,7 @@ (declare (type unsigned-byte n)) (if (< n register-arg-count) (make-wired-tn *backend-t-primitive-type* descriptor-reg-sc-number - (nth n register-arg-offsets)) + (nth n *register-arg-offsets*)) (make-wired-tn *backend-t-primitive-type* control-stack-sc-number n))) ;;; Make a passing location TN for a local call return PC. @@ -799,17 +799,19 @@ ;; of the (new) stack frame before doing the call. Therefore, ;; we have to tell the lifetime stuff that we need to use them. ,@(when variable - (mapcar #'(lambda (name offset) - `(:temporary (:sc descriptor-reg - :offset ,offset - :from (:argument 0) - :to :eval) - ,name)) - register-arg-names register-arg-offsets)) + (mapcar #'(lambda (name offset) + `(:temporary (:sc descriptor-reg + :offset ,offset + :from (:argument 0) + :to :eval) + ,name)) + *register-arg-names* *register-arg-offsets*)) ,@(when (eq return :tail) - '((:temporary (:sc unsigned-reg - :from (:argument 1) :to (:argument 2)) old-fp-tmp))) + '((:temporary (:sc unsigned-reg + :from (:argument 1) + :to (:argument 2)) + old-fp-tmp))) (:generator ,(+ (if named 5 0) (if variable 19 1) @@ -824,16 +826,18 @@ ,@(if variable - ;; For variable call, compute the number of arguments and - ;; move some of the arguments to registers. + ;; For variable call, compute the number of + ;; arguments and move some of the arguments to + ;; registers. (collect ((noise)) ;; Compute the number of arguments. (noise '(inst mov ecx new-fp)) (noise '(inst sub ecx esp-tn)) - ;; Move the necessary args to registers, this - ;; moves them all even if they are not all needed. + ;; Move the necessary args to registers, + ;; this moves them all even if they are + ;; not all needed. (loop - for name in register-arg-names + for name in *register-arg-names* for index downfrom -1 do (noise `(loadw ,name new-fp ,index))) (noise)) @@ -841,24 +845,26 @@ (inst xor ecx ecx) (inst mov ecx (fixnumize nargs))))) ,@(cond ((eq return :tail) - '(;; Python has figured out what frame we should return - ;; to so might as well use that clue. This seems - ;; really important to the implementation of things - ;; like (without-interrupts ...) - + '(;; Python has figured out what frame we should + ;; return to so might as well use that clue. + ;; This seems really important to the + ;; implementation of things like + ;; (without-interrupts ...) + ;; ;; dtc; Could be doing a tail call from a - ;; known-local-call etc in which the old-fp or ret-pc - ;; are in regs or in non-standard places. If the - ;; passing location were wired to the stack in - ;; standard locations then these moves will be - ;; un-necessary; this is probably best for the x86. + ;; known-local-call etc in which the old-fp + ;; or ret-pc are in regs or in non-standard + ;; places. If the passing location were + ;; wired to the stack in standard locations + ;; then these moves will be un-necessary; + ;; this is probably best for the x86. (sc-case old-fp ((control-stack) (unless (= ocfp-save-offset (tn-offset old-fp)) - ;; FIXME: FORMAT T for stale diagnostic - ;; output (several of them around here), - ;; ick + ;; FIXME: FORMAT T for stale + ;; diagnostic output (several of + ;; them around here), ick (format t "** tail-call old-fp not S0~%") (move old-fp-tmp old-fp) (storew old-fp-tmp @@ -870,23 +876,26 @@ ebp-tn (- (1+ ocfp-save-offset))))) - ;; For tail call, we have to push the return-pc so - ;; that it looks like we CALLed despite the fact that - ;; we are going to JMP. + ;; For tail call, we have to push the + ;; return-pc so that it looks like we CALLed + ;; despite the fact that we are going to JMP. (inst push return-pc) )) (t - ;; For non-tail call, we have to save our frame pointer - ;; and install the new frame pointer. We can't load - ;; stack tns after this point. - `(;; Python doesn't seem to allocate a frame here which - ;; doesn't leave room for the ofp/ret stuff. + ;; For non-tail call, we have to save our + ;; frame pointer and install the new frame + ;; pointer. We can't load stack tns after this + ;; point. + `(;; Python doesn't seem to allocate a frame + ;; here which doesn't leave room for the + ;; ofp/ret stuff. - ;; The variable args are on the stack and become the - ;; frame, but there may be <3 args and 3 stack slots - ;; are assumed allocate on the call. So need to - ;; ensure there are at least 3 slots. This hack just - ;; adds 3 more. + ;; The variable args are on the stack and + ;; become the frame, but there may be <3 + ;; args and 3 stack slots are assumed + ;; allocate on the call. So need to ensure + ;; there are at least 3 slots. This hack + ;; just adds 3 more. ,(if variable '(inst sub esp-tn (fixnumize 3))) @@ -1006,11 +1015,11 @@ ;; We need to stretch the lifetime of return-pc past the argument ;; registers so that we can default the argument registers without ;; trashing return-pc. - (:temporary (:sc unsigned-reg :offset (first register-arg-offsets) + (:temporary (:sc unsigned-reg :offset (first *register-arg-offsets*) :from :eval) a0) - (:temporary (:sc unsigned-reg :offset (second register-arg-offsets) + (:temporary (:sc unsigned-reg :offset (second *register-arg-offsets*) :from :eval) a1) - (:temporary (:sc unsigned-reg :offset (third register-arg-offsets) + (:temporary (:sc unsigned-reg :offset (third *register-arg-offsets*) :from :eval) a2) (:generator 6 @@ -1070,7 +1079,7 @@ (:temporary (:sc unsigned-reg :offset esi-offset :from (:argument 2)) esi) (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 3)) ecx) (:temporary (:sc unsigned-reg :offset ebx-offset :from (:eval 0)) ebx) - (:temporary (:sc descriptor-reg :offset (first register-arg-offsets) + (:temporary (:sc descriptor-reg :offset (first *register-arg-offsets*) :from (:eval 0)) a0) (:temporary (:sc unsigned-reg :from (:eval 1)) old-fp-temp) (:node-var node) diff --git a/src/compiler/x86/insts.lisp b/src/compiler/x86/insts.lisp index 8981bc4..c0d6752 100644 --- a/src/compiler/x86/insts.lisp +++ b/src/compiler/x86/insts.lisp @@ -285,12 +285,11 @@ (defun print-fp-reg (value stream dstate) (declare (ignore dstate)) (format stream "FR~D" value)) - (defun prefilter-fp-reg (value dstate) ;; just return it (declare (ignore dstate)) value) -) +) ; EVAL-WHEN (sb!disassem:define-argument-type fp-reg :prefilter #'prefilter-fp-reg :printer #'print-fp-reg) @@ -309,7 +308,7 @@ (princ (schar (symbol-name word-width) 0) stream))))) (eval-when (:compile-toplevel :load-toplevel :execute) -(defconstant conditions +(defparameter *conditions* '((:o . 0) (:no . 1) (:b . 2) (:nae . 2) (:c . 2) @@ -326,14 +325,13 @@ (:nl . 13) (:ge . 13) (:le . 14) (:ng . 14) (:nle . 15) (:g . 15))) - (defparameter *condition-name-vec* (let ((vec (make-array 16 :initial-element nil))) - (dolist (cond conditions) + (dolist (cond *conditions*) (when (null (aref vec (cdr cond))) (setf (aref vec (cdr cond)) (car cond)))) vec)) -);EVAL-WHEN +) ; EVAL-WHEN ;;; Set assembler parameters. (In CMU CL, this was done with ;;; a call to a macro DEF-ASSEMBLER-PARAMS.) @@ -344,7 +342,7 @@ :printer *condition-name-vec*) (defun conditional-opcode (condition) - (cdr (assoc condition conditions :test #'eq))) + (cdr (assoc condition *conditions* :test #'eq))) ;;;; disassembler instruction formats @@ -755,39 +753,39 @@ (defun byte-reg-p (thing) (and (tn-p thing) (eq (sb-name (sc-sb (tn-sc thing))) 'registers) - (member (sc-name (tn-sc thing)) byte-sc-names) + (member (sc-name (tn-sc thing)) *byte-sc-names*) t)) (defun byte-ea-p (thing) (typecase thing (ea (eq (ea-size thing) :byte)) (tn - (and (member (sc-name (tn-sc thing)) byte-sc-names) t)) + (and (member (sc-name (tn-sc thing)) *byte-sc-names*) t)) (t nil))) (defun word-reg-p (thing) (and (tn-p thing) (eq (sb-name (sc-sb (tn-sc thing))) 'registers) - (member (sc-name (tn-sc thing)) word-sc-names) + (member (sc-name (tn-sc thing)) *word-sc-names*) t)) (defun word-ea-p (thing) (typecase thing (ea (eq (ea-size thing) :word)) - (tn (and (member (sc-name (tn-sc thing)) word-sc-names) t)) + (tn (and (member (sc-name (tn-sc thing)) *word-sc-names*) t)) (t nil))) (defun dword-reg-p (thing) (and (tn-p thing) (eq (sb-name (sc-sb (tn-sc thing))) 'registers) - (member (sc-name (tn-sc thing)) dword-sc-names) + (member (sc-name (tn-sc thing)) *dword-sc-names*) t)) (defun dword-ea-p (thing) (typecase thing (ea (eq (ea-size thing) :dword)) (tn - (and (member (sc-name (tn-sc thing)) dword-sc-names) t)) + (and (member (sc-name (tn-sc thing)) *dword-sc-names*) t)) (t nil))) (defun register-p (thing) @@ -811,17 +809,19 @@ (defun operand-size (thing) (typecase thing (tn + ;; FIXME: might as well be COND instead of having to use #. readmacro + ;; to hack up the code (case (sc-name (tn-sc thing)) - (#.dword-sc-names + (#.*dword-sc-names* :dword) - (#.word-sc-names + (#.*word-sc-names* :word) - (#.byte-sc-names + (#.*byte-sc-names* :byte) - ;; added by jrd. float-registers is a separate size (?) - (#.float-sc-names + ;; added by jrd: float-registers is a separate size (?) + (#.*float-sc-names* :float) - (#.double-sc-names + (#.*double-sc-names* :double) (t (error "can't tell the size of ~S ~S" thing (sc-name (tn-sc thing)))))) diff --git a/src/compiler/x86/parms.lisp b/src/compiler/x86/parms.lisp index 8c558aa..af9899a 100644 --- a/src/compiler/x86/parms.lisp +++ b/src/compiler/x86/parms.lisp @@ -24,8 +24,6 @@ ;;;; machine architecture parameters -(eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant word-bits 32 #!+sb-doc "Number of bits per word where a word holds one lisp descriptor.") @@ -42,38 +40,37 @@ #!+sb-doc "Number of bytes in a word.") -) ; EVAL-WHEN - -(eval-when (:compile-toplevel :load-toplevel :execute) (defconstant float-sign-shift 31) -;; These values were taken from the alpha code. The values for -;; bias and exponent min/max are not the same as shown in the 486 book. -;; They may be correct for how Python uses them. -(defconstant single-float-bias 126) ; Intel says 127 -(defconstant single-float-exponent-byte (byte 8 23)) -(defconstant single-float-significand-byte (byte 23 0)) -;; The 486 book shows the exponent range -126 to +127. The Lisp -;; code that uses these values seems to want already biased numbers. +;;; comment from CMU CL: +;;; These values were taken from the alpha code. The values for +;;; bias and exponent min/max are not the same as shown in the 486 book. +;;; They may be correct for how Python uses them. +(defconstant single-float-bias 126) ; Intel says 127. +(defconstant-eqx single-float-exponent-byte (byte 8 23) #'equalp) +(defconstant-eqx single-float-significand-byte (byte 23 0) #'equalp) +;;; comment from CMU CL: +;;; The 486 book shows the exponent range -126 to +127. The Lisp +;;; code that uses these values seems to want already biased numbers. (defconstant single-float-normal-exponent-min 1) (defconstant single-float-normal-exponent-max 254) (defconstant single-float-hidden-bit (ash 1 23)) (defconstant single-float-trapping-nan-bit (ash 1 22)) (defconstant double-float-bias 1022) -(defconstant double-float-exponent-byte (byte 11 20)) -(defconstant double-float-significand-byte (byte 20 0)) +(defconstant-eqx double-float-exponent-byte (byte 11 20) #'equalp) +(defconstant-eqx double-float-significand-byte (byte 20 0) #'equalp) (defconstant double-float-normal-exponent-min 1) (defconstant double-float-normal-exponent-max #x7FE) (defconstant double-float-hidden-bit (ash 1 20)) (defconstant double-float-trapping-nan-bit (ash 1 19)) (defconstant long-float-bias 16382) -(defconstant long-float-exponent-byte (byte 15 0)) -(defconstant long-float-significand-byte (byte 31 0)) +(defconstant-eqx long-float-exponent-byte (byte 15 0) #'equalp) +(defconstant-eqx long-float-significand-byte (byte 31 0) #'equalp) (defconstant long-float-normal-exponent-min 1) (defconstant long-float-normal-exponent-max #x7FFE) -(defconstant long-float-hidden-bit (ash 1 31)) ; Actually not hidden +(defconstant long-float-hidden-bit (ash 1 31)) ; actually not hidden (defconstant long-float-trapping-nan-bit (ash 1 30)) (defconstant single-float-digits @@ -85,40 +82,30 @@ (defconstant long-float-digits (+ (byte-size long-float-significand-byte) word-bits 1)) -;;; pfw -- from i486 microprocessor programmers reference manual -(defconstant float-invalid-trap-bit (ash 1 0)) +;;; pfw -- from i486 microprocessor programmer's reference manual +(defconstant float-invalid-trap-bit (ash 1 0)) (defconstant float-denormal-trap-bit (ash 1 1)) (defconstant float-divide-by-zero-trap-bit (ash 1 2)) (defconstant float-overflow-trap-bit (ash 1 3)) (defconstant float-underflow-trap-bit (ash 1 4)) -(defconstant float-inexact-trap-bit (ash 1 5)) +(defconstant float-inexact-trap-bit (ash 1 5)) (defconstant float-round-to-nearest 0) (defconstant float-round-to-negative 1) (defconstant float-round-to-positive 2) (defconstant float-round-to-zero 3) -(defconstant float-rounding-mode (byte 2 10)) -(defconstant float-sticky-bits (byte 6 16)) -(defconstant float-traps-byte (byte 6 0)) -(defconstant float-exceptions-byte (byte 6 16)) -(defconstant float-precision-control (byte 2 8)) -(defconstant float-fast-bit 0) ; No fast mode on x86 - -); EVAL-WHEN +(defconstant-eqx float-rounding-mode (byte 2 10) #'equalp) +(defconstant-eqx float-sticky-bits (byte 6 16) #'equalp) +(defconstant-eqx float-traps-byte (byte 6 0) #'equalp) +(defconstant-eqx float-exceptions-byte (byte 6 16) #'equalp) +(defconstant-eqx float-precision-control (byte 2 8) #'equalp) +(defconstant float-fast-bit 0) ; no fast mode on x86 ;;;; description of the target address space ;;; where to put the different spaces ;;; -;;; FIXME: Couldn't/shouldn't these be DEFCONSTANT instead of DEFPARAMETER? -;;; -;;; FIXME: Since SBCL has a different way of distinguishing between target -;;; and host than the old CMU CL code used, the "TARGET-" prefix is -;;; redundant. Perhaps each *TARGET-FOO* should become *FOO*, probably -;;; at the same time that we unscrew the kludgy way that constants are -;;; duplicated between this file and runtime/x86-validate.h. -;;; ;;; Note: Mostly these values are black magic, inherited from CMU CL ;;; without any documentation. However, there were a few explanatory ;;; comments in the CMU CL sources: diff --git a/src/compiler/x86/static-fn.lisp b/src/compiler/x86/static-fn.lisp index ac76ea7..231e074 100644 --- a/src/compiler/x86/static-fn.lisp +++ b/src/compiler/x86/static-fn.lisp @@ -52,7 +52,7 @@ (let ((temp-name (intern (format nil "TEMP-~D" i)))) (temp-names temp-name) (temps `(:temporary (:sc descriptor-reg - :offset ,(nth i register-arg-offsets) + :offset ,(nth i *register-arg-offsets*) :from ,(if (< i num-args) `(:argument ,i) '(:eval 1)) diff --git a/src/compiler/x86/vm.lisp b/src/compiler/x86/vm.lisp index 001f5e5..8f09651 100644 --- a/src/compiler/x86/vm.lisp +++ b/src/compiler/x86/vm.lisp @@ -20,30 +20,33 @@ ;;;; register specs +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar *byte-register-names* (make-array 8 :initial-element nil)) + (defvar *word-register-names* (make-array 16 :initial-element nil)) + (defvar *dword-register-names* (make-array 16 :initial-element nil)) + (defvar *float-register-names* (make-array 8 :initial-element nil))) + (macrolet ((defreg (name offset size) (let ((offset-sym (symbolicate name "-OFFSET")) (names-vector (symbolicate "*" size "-REGISTER-NAMES*"))) `(progn - (eval-when (:compile-toplevel :execute :load-toplevel) - (defconstant ,offset-sym ,offset)) + (defconstant ,offset-sym ,offset) (setf (svref ,names-vector ,offset-sym) ,(symbol-name name))))) - ;; FIXME: It looks to me as though DEFREGSET should also define the - ;; *FOO-REGISTER-NAMES* variable. + ;; FIXME: It looks to me as though DEFREGSET should also + ;; define the related *FOO-REGISTER-NAMES* variable. (defregset (name &rest regs) - `(eval-when (:compile-toplevel :execute :load-toplevel) - (defconstant ,name + `(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter ,name (list ,@(mapcar (lambda (name) (symbolicate name "-OFFSET")) regs)))))) ;; byte registers ;; - ;; Note: the encoding here is different then that used by the chip. We - ;; use this encoding so that the compiler thinks that AX (and EAX) overlap - ;; AL and AH instead of AL and CL. - (eval-when (:compile-toplevel :load-toplevel :execute) - (defvar *byte-register-names* (make-array 8 :initial-element nil))) + ;; Note: the encoding here is different than that used by the chip. + ;; We use this encoding so that the compiler thinks that AX (and + ;; EAX) overlap AL and AH instead of AL and CL. (defreg al 0 :byte) (defreg ah 1 :byte) (defreg cl 2 :byte) @@ -52,11 +55,9 @@ (defreg dh 5 :byte) (defreg bl 6 :byte) (defreg bh 7 :byte) - (defregset byte-regs al ah cl ch dl dh bl bh) + (defregset *byte-regs* al ah cl ch dl dh bl bh) ;; word registers - (eval-when (:compile-toplevel :load-toplevel :execute) - (defvar *word-register-names* (make-array 16 :initial-element nil))) (defreg ax 0 :word) (defreg cx 2 :word) (defreg dx 4 :word) @@ -65,11 +66,9 @@ (defreg bp 10 :word) (defreg si 12 :word) (defreg di 14 :word) - (defregset word-regs ax cx dx bx si di) + (defregset *word-regs* ax cx dx bx si di) ;; double word registers - (eval-when (:compile-toplevel :load-toplevel :execute) - (defvar *dword-register-names* (make-array 16 :initial-element nil))) (defreg eax 0 :dword) (defreg ecx 2 :dword) (defreg edx 4 :dword) @@ -78,11 +77,9 @@ (defreg ebp 10 :dword) (defreg esi 12 :dword) (defreg edi 14 :dword) - (defregset dword-regs eax ecx edx ebx esi edi) + (defregset *dword-regs* eax ecx edx ebx esi edi) ;; floating point registers - (eval-when (:compile-toplevel :load-toplevel :execute) - (defvar *float-register-names* (make-array 8 :initial-element nil))) (defreg fr0 0 :float) (defreg fr1 1 :float) (defreg fr2 2 :float) @@ -91,15 +88,16 @@ (defreg fr5 5 :float) (defreg fr6 6 :float) (defreg fr7 7 :float) - (defregset float-regs fr0 fr1 fr2 fr3 fr4 fr5 fr6 fr7) + (defregset *float-regs* fr0 fr1 fr2 fr3 fr4 fr5 fr6 fr7) ;; registers used to pass arguments ;; ;; the number of arguments/return values passed in registers (defconstant register-arg-count 3) ;; names and offsets for registers used to pass arguments - (defconstant register-arg-names '(edx edi esi)) - (defregset register-arg-offsets edx edi esi)) + (eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter *register-arg-names* '(edx edi esi))) + (defregset *register-arg-offsets* edx edi esi)) ;;;; SB definitions @@ -145,23 +143,24 @@ `(progn ,@(forms)))) -;;; The DEFINE-STORAGE-CLASS call for CATCH-BLOCK refers to the size of -;;; CATCH-BLOCK. The size of CATCH-BLOCK isn't calculated until later in -;;; the build process, and the calculation is entangled with code which has -;;; lots of predependencies, including dependencies on the prior call of -;;; DEFINE-STORAGE-CLASS. The proper way to unscramble this would be to -;;; untangle the code, so that the code which calculates the size of -;;; CATCH-BLOCK can be separated from the other lots-of-dependencies code, so -;;; that the code which calculates the size of CATCH-BLOCK can be executed -;;; early, so that this value is known properly at this point in compilation. -;;; However, that would be a lot of editing of code that I (WHN 19990131) can't -;;; test until the project is complete. So instead, I set the correct value by -;;; hand here (a sort of nondeterministic guess of the right answer:-) and add -;;; an assertion later, after the value is calculated, that the original guess -;;; was correct. +;;; The DEFINE-STORAGE-CLASS call for CATCH-BLOCK refers to the size +;;; of CATCH-BLOCK. The size of CATCH-BLOCK isn't calculated until +;;; later in the build process, and the calculation is entangled with +;;; code which has lots of predependencies, including dependencies on +;;; the prior call of DEFINE-STORAGE-CLASS. The proper way to +;;; unscramble this would be to untangle the code, so that the code +;;; which calculates the size of CATCH-BLOCK can be separated from the +;;; other lots-of-dependencies code, so that the code which calculates +;;; the size of CATCH-BLOCK can be executed early, so that this value +;;; is known properly at this point in compilation. However, that +;;; would be a lot of editing of code that I (WHN 19990131) can't test +;;; until the project is complete. So instead, I set the correct value +;;; by hand here (a sort of nondeterministic guess of the right +;;; answer:-) and add an assertion later, after the value is +;;; calculated, that the original guess was correct. ;;; -;;; (What a KLUDGE! Anyone who wants to come in and clean up this mess has my -;;; gratitude.) (FIXME: Maybe this should be me..) +;;; (What a KLUDGE! Anyone who wants to come in and clean up this mess +;;; has my gratitude.) (FIXME: Maybe this should be me..) (defconstant sb!vm::kludge-nondeterministic-catch-block-size 6) (define-storage-classes @@ -213,7 +212,7 @@ ;; immediate descriptor objects. Don't have to be seen by GC, but nothing ;; bad will happen if they are. (fixnums, characters, header values, etc). (any-reg registers - :locations #.dword-regs + :locations #.*dword-regs* :element-size 2 ; :reserve-locations (#.eax-offset) :constant-scs (immediate) @@ -222,7 +221,7 @@ ;; pointer descriptor objects -- must be seen by GC (descriptor-reg registers - :locations #.dword-regs + :locations #.*dword-regs* :element-size 2 ; :reserve-locations (#.eax-offset) :constant-scs (constant immediate) @@ -231,7 +230,7 @@ ;; non-descriptor characters (base-char-reg registers - :locations #.byte-regs + :locations #.*byte-regs* :reserve-locations (#.ah-offset #.al-offset) :constant-scs (immediate) :save-p t @@ -239,7 +238,7 @@ ;; non-descriptor SAPs (arbitrary pointers into address space) (sap-reg registers - :locations #.dword-regs + :locations #.*dword-regs* :element-size 2 ; :reserve-locations (#.eax-offset) :constant-scs (immediate) @@ -248,14 +247,14 @@ ;; non-descriptor (signed or unsigned) numbers (signed-reg registers - :locations #.dword-regs + :locations #.*dword-regs* :element-size 2 ; :reserve-locations (#.eax-offset) :constant-scs (immediate) :save-p t :alternate-scs (signed-stack)) (unsigned-reg registers - :locations #.dword-regs + :locations #.*dword-regs* :element-size 2 ; :reserve-locations (#.eax-offset) :constant-scs (immediate) @@ -265,12 +264,12 @@ ;; miscellaneous objects that must not be seen by GC. Used only as ;; temporaries. (word-reg registers - :locations #.word-regs + :locations #.*word-regs* :element-size 2 ; :reserve-locations (#.ax-offset) ) (byte-reg registers - :locations #.byte-regs + :locations #.*byte-regs* ; :reserve-locations (#.al-offset #.ah-offset) ) @@ -325,20 +324,17 @@ :element-size sb!vm::kludge-nondeterministic-catch-block-size)) (eval-when (:compile-toplevel :load-toplevel :execute) - -(defconstant byte-sc-names '(base-char-reg byte-reg base-char-stack)) -(defconstant word-sc-names '(word-reg)) -(defconstant dword-sc-names +(defparameter *byte-sc-names* '(base-char-reg byte-reg base-char-stack)) +(defparameter *word-sc-names* '(word-reg)) +(defparameter *dword-sc-names* '(any-reg descriptor-reg sap-reg signed-reg unsigned-reg control-stack signed-stack unsigned-stack sap-stack single-stack constant)) - ;;; added by jrd. I guess the right thing to do is to treat floats ;;; as a separate size... ;;; ;;; These are used to (at least) determine operand size. -(defconstant float-sc-names '(single-reg)) -(defconstant double-sc-names '(double-reg double-stack)) - +(defparameter *float-sc-names* '(single-reg)) +(defparameter *double-sc-names* '(double-reg double-stack)) ) ; EVAL-WHEN ;;;; miscellaneous TNs for the various registers @@ -348,8 +344,9 @@ (dolist (reg-name reg-names) (let ((tn-name (symbolicate reg-name "-TN")) (offset-name (symbolicate reg-name "-OFFSET"))) - ;; FIXME: Couldn't shouldn't this be DEFCONSTANT - ;; instead of DEFPARAMETER? + ;; FIXME: It'd be good to have the special + ;; variables here be named with the *FOO* + ;; convention. (forms `(defparameter ,tn-name (make-random-tn :kind :normal :sc (sc-or-lose ',sc-name) @@ -366,7 +363,7 @@ (defparameter *register-arg-tns* (mapcar (lambda (register-arg-name) (symbol-value (symbolicate register-arg-name "-TN"))) - register-arg-names)) + *register-arg-names*)) ;;; FIXME: doesn't seem to be used in SBCL #| @@ -379,8 +376,8 @@ ;;; IMMEDIATE-CONSTANT-SC ;;; -;;; If value can be represented as an immediate constant, then return the -;;; appropriate SC number, otherwise return NIL. +;;; If value can be represented as an immediate constant, then return +;;; the appropriate SC number, otherwise return NIL. (def-vm-support-routine immediate-constant-sc (value) (typecase value ((or fixnum #-sb-xc-host system-area-pointer character) @@ -436,11 +433,11 @@ (ecase sb (registers (let* ((sc-name (sc-name sc)) - (name-vec (cond ((member sc-name byte-sc-names) + (name-vec (cond ((member sc-name *byte-sc-names*) *byte-register-names*) - ((member sc-name word-sc-names) + ((member sc-name *word-sc-names*) *word-register-names*) - ((member sc-name dword-sc-names) + ((member sc-name *dword-sc-names*) *dword-register-names*)))) (or (and name-vec (< -1 offset (length name-vec)) diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index faa9b0c..6c096a9 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -807,7 +807,7 @@ bootstrapping. (let* ((.slots. (get-slots-or-nil ,(car required-args+rest-arg))) (value (when .slots. (%instance-ref .slots. ,emf)))) - (if (eq value ',*slot-unbound*) + (if (eq value +slot-unbound+) (slot-unbound-internal ,(car required-args+rest-arg) ,emf) value))))) @@ -826,7 +826,7 @@ bootstrapping. (and .slots. (not (eq (%instance-ref .slots. (fast-instance-boundp-index ,emf)) - ',*slot-unbound*))))))) + +slot-unbound+))))))) ||# (t (etypecase ,emf @@ -877,7 +877,7 @@ bootstrapping. (cond ((null args) (error "1 or 2 args were expected.")) ((null (cdr args)) (let ((value (%instance-ref (get-slots (car args)) emf))) - (if (eq value *slot-unbound*) + (if (eq value +slot-unbound+) (slot-unbound-internal (car args) emf) value))) ((null (cddr args)) @@ -889,7 +889,7 @@ bootstrapping. (error "1 arg was expected.") (not (eq (%instance-ref (get-slots (car args)) (fast-instance-boundp-index emf)) - *slot-unbound*)))) + +slot-unbound+)))) (function (apply emf args)))) @@ -1422,11 +1422,11 @@ bootstrapping. (defvar *sgf-slots-init* (mapcar #'(lambda (canonical-slot) (if (memq (getf canonical-slot :name) '(arg-info source)) - *slot-unbound* + +slot-unbound+ (let ((initfunction (getf canonical-slot :initfunction))) (if initfunction (funcall initfunction) - *slot-unbound*)))) + +slot-unbound+)))) (early-collect-inheritance 'standard-generic-function))) (defvar *sgf-method-class-index* @@ -1435,7 +1435,7 @@ bootstrapping. (defun early-gf-p (x) (and (fsc-instance-p x) (eq (instance-ref (get-slots x) *sgf-method-class-index*) - *slot-unbound*))) + +slot-unbound+))) (defvar *sgf-methods-index* (bootstrap-slot-index 'standard-generic-function 'methods)) diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index bc7efc0..b331634 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -49,7 +49,7 @@ slots)) (t (make-array no-of-slots - :initial-element sb-pcl::*slot-unbound*)))) + :initial-element +slot-unbound+)))) instance)) (defmacro allocate-funcallable-instance-slots (wrapper &optional @@ -58,8 +58,8 @@ ,(if slots-init-p `(if ,slots-init-p (make-array no-of-slots :initial-contents ,slots-init) - (make-array no-of-slots :initial-element *slot-unbound*)) - `(make-array no-of-slots :initial-element *slot-unbound*)))) + (make-array no-of-slots :initial-element +slot-unbound+)) + `(make-array no-of-slots :initial-element +slot-unbound+)))) (defun allocate-funcallable-instance (wrapper &optional (slots-init nil slots-init-p)) diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp index d37796a..4bc0854 100644 --- a/src/pcl/cache.lisp +++ b/src/pcl/cache.lisp @@ -25,73 +25,75 @@ (in-package "SB-PCL") -;;; FIXME: SB-PCL should probably USE-PACKAGE SB-KERNEL, since SB-PCL is built -;;; on SB-KERNEL, and in the absence of USE-PACKAGE, it ends up using a -;;; thundering herd of explicit prefixes to get to SB-KERNEL symbols. -;;; Using the SB-INT and SB-EXT packages as well would help reduce -;;; prefixing and make it more natural to reuse things (ONCE-ONLY, -;;; *KEYWORD-PACKAGE*..) used in the main body of the system. -;;; However, that would cause a conflict between the SB-ITERATE:ITERATE -;;; macro and the SB-INT:ITERATE macro. (This could be resolved by -;;; renaming SB-INT:ITERATE to SB-INT:NAMED-LET, or with -;;; more gruntwork by punting the SB-ITERATE package and replacing -;;; calls to SB-ITERATE:ITERATE with calls to CL:LOOP. +;;; FIXME: SB-PCL should probably USE-PACKAGE SB-KERNEL, since SB-PCL +;;; is built on SB-KERNEL, and in the absence of USE-PACKAGE, it ends +;;; up using a thundering herd of explicit prefixes to get to +;;; SB-KERNEL symbols. Using the SB-INT and SB-EXT packages as well +;;; would help reduce prefixing and make it more natural to reuse +;;; things (ONCE-ONLY, *KEYWORD-PACKAGE*..) used in the main body of +;;; the system. However, that would cause a conflict between the +;;; SB-ITERATE:ITERATE macro and the SB-INT:ITERATE macro. (This could +;;; be resolved by renaming SB-INT:ITERATE to SB-INT:NAMED-LET, or +;;; with more gruntwork by punting the SB-ITERATE package and +;;; replacing calls to SB-ITERATE:ITERATE with calls to CL:LOOP. ;;; The caching algorithm implemented: ;;; ;;; << put a paper here >> ;;; -;;; For now, understand that as far as most of this code goes, a cache has -;;; two important properties. The first is the number of wrappers used as -;;; keys in each cache line. Throughout this code, this value is always -;;; called NKEYS. The second is whether or not the cache lines of a cache -;;; store a value. Throughout this code, this always called VALUEP. +;;; For now, understand that as far as most of this code goes, a cache +;;; has two important properties. The first is the number of wrappers +;;; used as keys in each cache line. Throughout this code, this value +;;; is always called NKEYS. The second is whether or not the cache +;;; lines of a cache store a value. Throughout this code, this always +;;; called VALUEP. ;;; ;;; Depending on these values, there are three kinds of caches. ;;; ;;; NKEYS = 1, VALUEP = NIL ;;; -;;; In this kind of cache, each line is 1 word long. No cache locking is -;;; needed since all read's in the cache are a single value. Nevertheless -;;; line 0 (location 0) is reserved, to ensure that invalid wrappers will -;;; not get a first probe hit. +;;; In this kind of cache, each line is 1 word long. No cache locking +;;; is needed since all read's in the cache are a single value. +;;; Nevertheless line 0 (location 0) is reserved, to ensure that +;;; invalid wrappers will not get a first probe hit. ;;; -;;; To keep the code simpler, a cache lock count does appear in location 0 -;;; of these caches, that count is incremented whenever data is written to -;;; the cache. But, the actual lookup code (see make-dlap) doesn't need to -;;; do locking when reading the cache. +;;; To keep the code simpler, a cache lock count does appear in +;;; location 0 of these caches, that count is incremented whenever +;;; data is written to the cache. But, the actual lookup code (see +;;; make-dlap) doesn't need to do locking when reading the cache. ;;; ;;; NKEYS = 1, VALUEP = T ;;; -;;; In this kind of cache, each line is 2 words long. Cache locking must -;;; be done to ensure the synchronization of cache reads. Line 0 of the -;;; cache (location 0) is reserved for the cache lock count. Location 1 -;;; of the cache is unused (in effect wasted). +;;; In this kind of cache, each line is 2 words long. Cache locking +;;; must be done to ensure the synchronization of cache reads. Line 0 +;;; of the cache (location 0) is reserved for the cache lock count. +;;; Location 1 of the cache is unused (in effect wasted). ;;; ;;; NKEYS > 1 ;;; -;;; In this kind of cache, the 0 word of the cache holds the lock count. -;;; The 1 word of the cache is line 0. Line 0 of these caches is not -;;; reserved. +;;; In this kind of cache, the 0 word of the cache holds the lock +;;; count. The 1 word of the cache is line 0. Line 0 of these caches +;;; is not reserved. ;;; -;;; This is done because in this sort of cache, the overhead of doing the -;;; cache probe is high enough that the 1+ required to offset the location -;;; is not a significant cost. In addition, because of the larger line -;;; sizes, the space that would be wasted by reserving line 0 to hold the -;;; lock count is more significant. +;;; This is done because in this sort of cache, the overhead of doing +;;; the cache probe is high enough that the 1+ required to offset the +;;; location is not a significant cost. In addition, because of the +;;; larger line sizes, the space that would be wasted by reserving +;;; line 0 to hold the lock count is more significant. ;;; caches ;;; -;;; A cache is essentially just a vector. The use of the individual `words' -;;; in the vector depends on particular properties of the cache as described -;;; above. +;;; A cache is essentially just a vector. The use of the individual +;;; `words' in the vector depends on particular properties of the +;;; cache as described above. ;;; -;;; This defines an abstraction for caches in terms of their most obvious -;;; implementation as simple vectors. But, please notice that part of the -;;; implementation of this abstraction, is the function lap-out-cache-ref. -;;; This means that most port-specific modifications to the implementation -;;; of caches will require corresponding port-specific modifications to the -;;; lap code assembler. +;;; This defines an abstraction for caches in terms of their most +;;; obvious implementation as simple vectors. But, please notice that +;;; part of the implementation of this abstraction, is the function +;;; lap-out-cache-ref. This means that most port-specific +;;; modifications to the implementation of caches will require +;;; corresponding port-specific modifications to the lap code +;;; assembler. (defmacro cache-vector-ref (cache-vector location) `(svref (the simple-vector ,cache-vector) (sb-ext:truly-the fixnum ,location))) @@ -122,29 +124,28 @@ 1 (the fixnum (1+ old-count)))))))) (deftype field-type () - '(integer 0 ;#.(position 'number wrapper-layout) - 7)) ;#.(position 'number wrapper-layout :from-end t) + '(mod #.sb-kernel:layout-clos-hash-length)) (eval-when (:compile-toplevel :load-toplevel :execute) (defun power-of-two-ceiling (x) (declare (fixnum x)) ;;(expt 2 (ceiling (log x 2))) (the fixnum (ash 1 (integer-length (1- x))))) - -(defconstant *nkeys-limit* 256) ) ; EVAL-WHEN +(defconstant +nkeys-limit+ 256) + (defstruct (cache (:constructor make-cache ()) (:copier copy-cache-internal)) (owner nil) - (nkeys 1 :type (integer 1 #.*nkeys-limit*)) + (nkeys 1 :type (integer 1 #.+nkeys-limit+)) (valuep nil :type (member nil t)) (nlines 0 :type fixnum) (field 0 :type field-type) (limit-fn #'default-limit-fn :type function) (mask 0 :type fixnum) (size 0 :type fixnum) - (line-size 1 :type (integer 1 #.(power-of-two-ceiling (1+ *nkeys-limit*)))) + (line-size 1 :type (integer 1 #.(power-of-two-ceiling (1+ +nkeys-limit+)))) (max-location 0 :type fixnum) (vector #() :type simple-vector) (overflow nil :type list)) @@ -156,15 +157,15 @@ ;;; some facilities for allocation and freeing caches as they are needed -;;; This is done on the assumption that a better port of PCL will arrange -;;; to cons these all in the same static area. Given that, the fact that -;;; PCL tries to reuse them should be a win. +;;; This is done on the assumption that a better port of PCL will +;;; arrange to cons these all in the same static area. Given that, the +;;; fact that PCL tries to reuse them should be a win. (defvar *free-cache-vectors* (make-hash-table :size 16 :test 'eql)) -;;; Return a cache that has had flush-cache-vector-internal called on it. This -;;; returns a cache of exactly the size requested, it won't ever return a -;;; larger cache. +;;; Return a cache that has had FLUSH-CACHE-VECTOR-INTERNAL called on +;;; it. This returns a cache of exactly the size requested, it won't +;;; ever return a larger cache. (defun get-cache-vector (size) (let ((entry (gethash size *free-cache-vectors*))) (without-interrupts @@ -195,8 +196,8 @@ (setf (cdr entry) cache-vector) nil))))) -;;; This is just for debugging and analysis. It shows the state of the free -;;; cache resource. +;;; This is just for debugging and analysis. It shows the state of the +;;; free cache resource. #+sb-show (defun show-free-cache-vectors () (let ((elements ())) @@ -220,17 +221,17 @@ ;;;; wrapper cache numbers -;;; The constant WRAPPER-CACHE-NUMBER-ADDS-OK controls the number of non-zero -;;; bits wrapper cache numbers will have. +;;; The constant WRAPPER-CACHE-NUMBER-ADDS-OK controls the number of +;;; non-zero bits wrapper cache numbers will have. ;;; -;;; The value of this constant is the number of wrapper cache numbers which -;;; can be added and still be certain the result will be a fixnum. This is -;;; used by all the code that computes primary cache locations from multiple -;;; wrappers. +;;; The value of this constant is the number of wrapper cache numbers +;;; which can be added and still be certain the result will be a +;;; fixnum. This is used by all the code that computes primary cache +;;; locations from multiple wrappers. ;;; -;;; The value of this constant is used to derive the next two which are the -;;; forms of this constant which it is more convenient for the runtime code -;;; to use. +;;; The value of this constant is used to derive the next two which +;;; are the forms of this constant which it is more convenient for the +;;; runtime code to use. (defconstant wrapper-cache-number-length (integer-length sb-kernel:layout-clos-hash-max)) (defconstant wrapper-cache-number-mask sb-kernel:layout-clos-hash-max) @@ -239,47 +240,47 @@ ;;;; wrappers themselves -;;; This caching algorithm requires that wrappers have more than one wrapper -;;; cache number. You should think of these multiple numbers as being in -;;; columns. That is, for a given cache, the same column of wrapper cache -;;; numbers will be used. +;;; This caching algorithm requires that wrappers have more than one +;;; wrapper cache number. You should think of these multiple numbers +;;; as being in columns. That is, for a given cache, the same column +;;; of wrapper cache numbers will be used. ;;; -;;; If at some point the cache distribution of a cache gets bad, the cache -;;; can be rehashed by switching to a different column. +;;; If at some point the cache distribution of a cache gets bad, the +;;; cache can be rehashed by switching to a different column. ;;; -;;; The columns are referred to by field number which is that number which, -;;; when used as a second argument to wrapper-ref, will return that column -;;; of wrapper cache number. +;;; The columns are referred to by field number which is that number +;;; which, when used as a second argument to wrapper-ref, will return +;;; that column of wrapper cache number. ;;; -;;; This code is written to allow flexibility as to how many wrapper cache -;;; numbers will be in each wrapper, and where they will be located. It is -;;; also set up to allow port specific modifications to `pack' the wrapper -;;; cache numbers on machines where the addressing modes make that a good -;;; idea. - -;;; In SBCL, as in CMU CL, we want to do type checking as early as possible; -;;; structures help this. -(eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant wrapper-cache-number-vector-length - sb-kernel:layout-clos-hash-length) - (defconstant wrapper-layout (make-list wrapper-cache-number-vector-length - :initial-element 'number))) +;;; This code is written to allow flexibility as to how many wrapper +;;; cache numbers will be in each wrapper, and where they will be +;;; located. It is also set up to allow port specific modifications to +;;; `pack' the wrapper cache numbers on machines where the addressing +;;; modes make that a good idea. + +;;; In SBCL, as in CMU CL, we want to do type checking as early as +;;; possible; structures help this. The structures are hard-wired to +;;; have a fixed number of cache hash values, and that number must +;;; correspond to the number of cache lines we use. +(defconstant wrapper-cache-number-vector-length + sb-kernel:layout-clos-hash-length) (unless (boundp '*the-class-t*) (setq *the-class-t* nil)) -;;; Note that for SBCL, as for CMU CL, the WRAPPER of a built-in or structure -;;; class will be some other kind of SB-KERNEL:LAYOUT, but this shouldn't -;;; matter, since the only two slots that WRAPPER adds are meaningless in those -;;; cases. +;;; Note that for SBCL, as for CMU CL, the WRAPPER of a built-in or +;;; structure class will be some other kind of SB-KERNEL:LAYOUT, but +;;; this shouldn't matter, since the only two slots that WRAPPER adds +;;; are meaningless in those cases. (defstruct (wrapper (:include sb-kernel:layout - ;; KLUDGE: In CMU CL, the initialization default for - ;; LAYOUT-INVALID was NIL. In SBCL, that has changed to - ;; :UNINITIALIZED, but PCL code might still expect NIL - ;; for the initialization default of WRAPPER-INVALID. - ;; Instead of trying to find out, I just overrode the - ;; LAYOUT default here. -- WHN 19991204 + ;; KLUDGE: In CMU CL, the initialization default + ;; for LAYOUT-INVALID was NIL. In SBCL, that has + ;; changed to :UNINITIALIZED, but PCL code might + ;; still expect NIL for the initialization + ;; default of WRAPPER-INVALID. Instead of trying + ;; to find out, I just overrode the LAYOUT + ;; default here. -- WHN 19991204 (invalid nil)) (:conc-name %wrapper-) (:constructor make-wrapper-internal)) @@ -292,31 +293,35 @@ (defmacro wrapper-no-of-instance-slots (wrapper) `(sb-kernel:layout-length ,wrapper)) -;;; WRAPPER-STATE returns T (not generalized boolean, but T exactly) iff the -;;; wrapper is valid. Any other return value denotes some invalid state. -;;; Special conventions have been set up for certain invalid states, e.g. -;;; obsoleteness or flushedness, but I (WHN 19991204) haven't been motivated to -;;; reverse engineer them from the code and document them here. +;;; WRAPPER-STATE returns T (not generalized boolean, but T exactly) +;;; iff the wrapper is valid. Any other return value denotes some +;;; invalid state. Special conventions have been set up for certain +;;; invalid states, e.g. obsoleteness or flushedness, but I (WHN +;;; 19991204) haven't been motivated to reverse engineer them from the +;;; code and document them here. ;;; ;;; FIXME: This is awkward and unmnemonic. There is a function -;;; (INVALID-WRAPPER-P) to test this return result abstractly for invalidness -;;; but it's not called consistently; the functions that need to know whether a -;;; wrapper is invalid often test (EQ (WRAPPER-STATE X) T), ick. It would be -;;; good to use the abstract test instead. It would probably be even better to -;;; switch the sense of the WRAPPER-STATE function, renaming it to -;;; WRAPPER-INVALID and making it synonymous with LAYOUT-INVALID. Then the -;;; INVALID-WRAPPER-P function would become trivial and would go away (replaced -;;; with WRAPPER-INVALID), since all the various invalid wrapper states would -;;; become generalized boolean "true" values. -- WHN 19991204 +;;; (INVALID-WRAPPER-P) to test this return result abstractly for +;;; invalidness but it's not called consistently; the functions that +;;; need to know whether a wrapper is invalid often test (EQ +;;; (WRAPPER-STATE X) T), ick. It would be good to use the abstract +;;; test instead. It would probably be even better to switch the sense +;;; of the WRAPPER-STATE function, renaming it to WRAPPER-INVALID and +;;; making it synonymous with LAYOUT-INVALID. Then the +;;; INVALID-WRAPPER-P function would become trivial and would go away +;;; (replaced with WRAPPER-INVALID), since all the various invalid +;;; wrapper states would become generalized boolean "true" values. -- +;;; WHN 19991204 #-sb-fluid (declaim (inline wrapper-state (setf wrapper-state))) (defun wrapper-state (wrapper) (let ((invalid (sb-kernel:layout-invalid wrapper))) (cond ((null invalid) t) ((atom invalid) - ;; some non-PCL object. INVALID is probably :INVALID. We should - ;; arguably compute the new wrapper here instead of returning NIL, - ;; but we don't bother, since OBSOLETE-INSTANCE-TRAP can't use it. + ;; some non-PCL object. INVALID is probably :INVALID. We + ;; should arguably compute the new wrapper here instead of + ;; returning NIL, but we don't bother, since + ;; OBSOLETE-INSTANCE-TRAP can't use it. '(:obsolete nil)) (t invalid)))) @@ -332,9 +337,9 @@ `(%wrapper-class-slots ,wrapper)) (defmacro wrapper-cache-number-vector (x) x) -;;; This is called in BRAID when we are making wrappers for classes whose slots -;;; are not initialized yet, and which may be built-in classes. We pass in the -;;; class name in addition to the class. +;;; This is called in BRAID when we are making wrappers for classes +;;; whose slots are not initialized yet, and which may be built-in +;;; classes. We pass in the class name in addition to the class. (defun boot-make-wrapper (length name &optional class) (let ((found (cl:find-class name nil))) (cond @@ -356,10 +361,10 @@ ;;; type testing and dispatch before PCL is loaded. (defvar *pcl-class-boot* nil) -;;; In SBCL, as in CMU CL, the layouts (a.k.a wrappers) for built-in and -;;; structure classes already exist when PCL is initialized, so we don't -;;; necessarily always make a wrapper. Also, we help maintain the mapping -;;; between cl:class and pcl::class objects. +;;; In SBCL, as in CMU CL, the layouts (a.k.a wrappers) for built-in +;;; and structure classes already exist when PCL is initialized, so we +;;; don't necessarily always make a wrapper. Also, we help maintain +;;; the mapping between cl:class and pcl::class objects. (defun make-wrapper (length class) (cond ((typep class 'std-class) @@ -415,17 +420,18 @@ (find-structure-class (cl:class-name (sb-kernel:layout-class wrapper)))))) -;;; The wrapper cache machinery provides general mechanism for trapping on the -;;; next access to any instance of a given class. This mechanism is used to -;;; implement the updating of instances when the class is redefined -;;; (MAKE-INSTANCES-OBSOLETE). The same mechanism is also used to update -;;; generic function caches when there is a change to the superclasses of a -;;; class. +;;; The wrapper cache machinery provides general mechanism for +;;; trapping on the next access to any instance of a given class. This +;;; mechanism is used to implement the updating of instances when the +;;; class is redefined (MAKE-INSTANCES-OBSOLETE). The same mechanism +;;; is also used to update generic function caches when there is a +;;; change to the superclasses of a class. ;;; -;;; Basically, a given wrapper can be valid or invalid. If it is invalid, -;;; it means that any attempt to do a wrapper cache lookup using the wrapper -;;; should trap. Also, methods on SLOT-VALUE-USING-CLASS check the wrapper -;;; validity as well. This is done by calling CHECK-WRAPPER-VALIDITY. +;;; Basically, a given wrapper can be valid or invalid. If it is +;;; invalid, it means that any attempt to do a wrapper cache lookup +;;; using the wrapper should trap. Also, methods on +;;; SLOT-VALUE-USING-CLASS check the wrapper validity as well. This is +;;; done by calling CHECK-WRAPPER-VALIDITY. ;;; FIXME: could become inline function (defmacro invalid-wrapper-p (wrapper) @@ -437,13 +443,14 @@ (ecase state ((:flush :obsolete) (let ((new-previous ())) - ;; First off, a previous call to invalidate-wrapper may have recorded - ;; owrapper as an nwrapper to update to. Since owrapper is about to - ;; be invalid, it no longer makes sense to update to it. + ;; First off, a previous call to INVALIDATE-WRAPPER may have + ;; recorded OWRAPPER as an NWRAPPER to update to. Since + ;; OWRAPPER is about to be invalid, it no longer makes sense to + ;; update to it. ;; - ;; We go back and change the previously invalidated wrappers so that - ;; they will now update directly to nwrapper. This corresponds to a - ;; kind of transitivity of wrapper updates. + ;; We go back and change the previously invalidated wrappers so + ;; that they will now update directly to NWRAPPER. This + ;; corresponds to a kind of transitivity of wrapper updates. (dolist (previous (gethash owrapper *previous-nwrappers*)) (when (eq state ':obsolete) (setf (car previous) ':obsolete)) @@ -451,9 +458,8 @@ (push previous new-previous)) (let ((ocnv (wrapper-cache-number-vector owrapper))) - (iterate ((type (list-elements wrapper-layout)) - (i (interval :from 0))) - (when (eq type 'number) (setf (cache-number-vector-ref ocnv i) 0)))) + (dotimes (i sb-kernel:layout-clos-hash-length) + (setf (cache-number-vector-ref ocnv i) 0))) (push (setf (wrapper-state owrapper) (list state nwrapper)) new-previous) @@ -473,14 +479,14 @@ (obsolete-instance-trap owrapper (cadr state) instance))))) ;; This little bit of error checking is superfluous. It only ;; checks to see whether the person who implemented the trap - ;; handling screwed up. Since that person is hacking internal - ;; PCL code, and is not a user, this should be needless. Also, - ;; since this directly slows down instance update and generic - ;; function cache refilling, feel free to take it out sometime - ;; soon. + ;; handling screwed up. Since that person is hacking + ;; internal PCL code, and is not a user, this should be + ;; needless. Also, since this directly slows down instance + ;; update and generic function cache refilling, feel free to + ;; take it out sometime soon. ;; - ;; FIXME: We probably need to add a #+SB-PARANOID feature to make - ;; stuff like this optional. Until then, it stays in. + ;; FIXME: We probably need to add a #+SB-PARANOID feature to + ;; make stuff like this optional. Until then, it stays in. (cond ((neq nwrapper (wrapper-of instance)) (error "wrapper returned from trap not wrapper of instance")) ((invalid-wrapper-p nwrapper) @@ -639,14 +645,14 @@ ;;; COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION ;;; -;;; This version is called on a cache line. It fetches the wrappers from -;;; the cache line and determines the primary location. Various parts of -;;; the cache filling code call this to determine whether it is appropriate -;;; to displace a given cache entry. +;;; This version is called on a cache line. It fetches the wrappers +;;; from the cache line and determines the primary location. Various +;;; parts of the cache filling code call this to determine whether it +;;; is appropriate to displace a given cache entry. ;;; -;;; If this comes across a wrapper whose cache-no is 0, it returns the symbol -;;; invalid to suggest to its caller that it would be provident to blow away -;;; the cache line in question. +;;; If this comes across a wrapper whose CACHE-NO is 0, it returns the +;;; symbol invalid to suggest to its caller that it would be provident +;;; to blow away the cache line in question. (defun compute-primary-cache-location-from-location (to-cache from-location &optional @@ -859,19 +865,17 @@ ;;;; add that having to practically write my own compiler in order to ;;;; get just this simple thing is something of a drag. ;;;; -;;;; KLUDGE: Maybe we could actually implement this as LABELS now, since AFAIK -;;;; CMU CL doesn't freak out when you have a defun with a lot of LABELS in it -;;;; (and if it does we can fix it instead of working around it). -- WHN -;;;; 19991204 +;;;; KLUDGE: Maybe we could actually implement this as LABELS now, +;;;; since AFAIK CMU CL doesn't freak out when you have a DEFUN with a +;;;; lot of LABELS in it (and if it does we can fix it instead of +;;;; working around it). -- WHN 19991204 (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *cache* nil) -;;; FIXME: -;;; (1) shouldn't be DEFCONSTANT, since it's not an EQL thing -;;; (2) should be undefined after bootstrapping -(defconstant *local-cache-functions* +;;; FIXME: should be undefined after bootstrapping +(defparameter *local-cache-functions* '((cache () .cache.) (nkeys () (cache-nkeys .cache.)) (line-size () (cache-line-size .cache.)) @@ -1055,10 +1059,10 @@ ;;; a cache ;;; a mask ;;; an absolute cache size (the size of the actual vector) -;;; It tries to re-adjust the cache every time it makes a new fill. The -;;; intuition here is that we want uniformity in the number of probes needed to -;;; find an entry. Furthermore, adjusting has the nice property of throwing out -;;; any entries that are invalid. +;;; It tries to re-adjust the cache every time it makes a new fill. +;;; The intuition here is that we want uniformity in the number of +;;; probes needed to find an entry. Furthermore, adjusting has the +;;; nice property of throwing out any entries that are invalid. (defvar *cache-expand-threshold* 1.25) (defun fill-cache (cache wrappers value &optional free-cache-p) @@ -1225,13 +1229,13 @@ ;;; Returns NIL or (values ) ;;; -;;; This is only called when it isn't possible to put the entry in the cache -;;; the easy way. That is, this function assumes that FILL-CACHE-P has been -;;; called as returned NIL. +;;; This is only called when it isn't possible to put the entry in the +;;; cache the easy way. That is, this function assumes that +;;; FILL-CACHE-P has been called as returned NIL. ;;; -;;; If this returns NIL, it means that it wasn't possible to find a wrapper -;;; field for which all of the entries could be put in the cache (within the -;;; limit). +;;; If this returns NIL, it means that it wasn't possible to find a +;;; wrapper field for which all of the entries could be put in the +;;; cache (within the limit). (defun adjust-cache (cache wrappers value free-old-cache-p) (with-local-cache-functions (cache) (let ((ncache (get-cache-from-cache cache (nlines) (field)))) @@ -1279,8 +1283,8 @@ (when free-old-cache-p (free-cache cache)) (maybe-check-cache ncache))))) -;;; This is the heart of the cache filling mechanism. It implements the -;;; decisions about where entries are placed. +;;; This is the heart of the cache filling mechanism. It implements +;;; the decisions about where entries are placed. ;;; ;;; Find a line in the cache at which a new entry can be inserted. ;;; @@ -1356,16 +1360,17 @@ (defvar *empty-cache* (make-cache)) ; for defstruct slot initial value forms -;;; Pre-allocate generic function caches. The hope is that this will put -;;; them nicely together in memory, and that that may be a win. Of course -;;; the first gc copy will probably blow that out, this really wants to be -;;; wrapped in something that declares the area static. +;;; Pre-allocate generic function caches. The hope is that this will +;;; put them nicely together in memory, and that that may be a win. Of +;;; course the first GC copy will probably blow that out, this really +;;; wants to be wrapped in something that declares the area static. ;;; -;;; This preallocation only creates about 25% more caches than PCL itself -;;; uses. Some ports may want to preallocate some more of these. +;;; This preallocation only creates about 25% more caches than PCL +;;; itself uses. Some ports may want to preallocate some more of +;;; these. ;;; -;;; KLUDGE: Isn't something very similar going on in precom1.lisp? Do we need -;;; it both here and there? Why? -- WHN 19991203 +;;; KLUDGE: Isn't something very similar going on in precom1.lisp? Do +;;; we need it both here and there? Why? -- WHN 19991203 (eval-when (:load-toplevel) (dolist (n-size '((1 513)(3 257)(3 129)(14 128)(6 65)(2 64)(7 33)(16 32) (16 17)(32 16)(64 9)(64 8)(6 5)(128 4)(35 2))) diff --git a/src/pcl/construct.lisp b/src/pcl/construct.lisp index 2675145..b711ac6 100644 --- a/src/pcl/construct.lisp +++ b/src/pcl/construct.lisp @@ -523,12 +523,12 @@ (initfn (slot-definition-initfunction slotd))) (cond ((null (memq name layout))) ((null initfn) - (push (cons name *slot-unbound*) constants)) + (push (cons name +slot-unbound+) constants)) ((constantp initform) (push (cons name (eval initform)) constants) (when (eq flag ':unsupplied) (setq flag ':constants))) (t - (push (cons name *slot-unbound*) constants) + (push (cons name +slot-unbound+) constants) (setq flag 't))))) (let* ((constants-alist (sort constants #'(lambda (x y) (memq (car y) diff --git a/src/pcl/dlisp.lisp b/src/pcl/dlisp.lisp index 9281f59..da57d57 100644 --- a/src/pcl/dlisp.lisp +++ b/src/pcl/dlisp.lisp @@ -155,7 +155,7 @@ (eq wrapper wrapper-1))))) ,@(if readp `((let ((value ,read-form)) - (unless (eq value *slot-unbound*) + (unless (eq value +slot-unbound+) (return-from access value)))) `((return-from access (setf ,read-form ,(car arglist)))))) (funcall miss-fn ,@arglist)))))) @@ -167,7 +167,7 @@ (defun emit-boundp-check (value-form miss-fn arglist) `(let ((value ,value-form)) - (if (eq value *slot-unbound*) + (if (eq value +slot-unbound+) (funcall ,miss-fn ,@arglist) value))) diff --git a/src/pcl/fast-init.lisp b/src/pcl/fast-init.lisp index ac2f9d4..45303b4 100644 --- a/src/pcl/fast-init.lisp +++ b/src/pcl/fast-init.lisp @@ -599,7 +599,7 @@ (wrapper (class-wrapper class)) (constants (when simple-p (make-list (wrapper-no-of-instance-slots wrapper) - ':initial-element *slot-unbound*))) + ':initial-element +slot-unbound+))) (slots (class-slots class)) (slot-names (mapcar #'slot-definition-name slots)) (slots-key (mapcar #'(lambda (slot) @@ -847,8 +847,8 @@ `((unless ,(if *inline-iis-instance-locations-p* (typecase location (fixnum `(not (eq (%instance-ref slots ,(const location)) - ',*slot-unbound*))) - (cons `(not (eq (cdr ,(const location)) ',*slot-unbound*))) + +slot-unbound+))) + (cons `(not (eq (cdr ,(const location)) +slot-unbound+))) (t default)) `(instance-boundp-internal pv slots ,(const pv-offset) ,default diff --git a/src/pcl/iterate.lisp b/src/pcl/iterate.lisp index dc833b9..a5b2bdf 100644 --- a/src/pcl/iterate.lisp +++ b/src/pcl/iterate.lisp @@ -23,7 +23,8 @@ (in-package "SB-ITERATE") -;;; Are warnings to be issued for iterate/gather forms that aren't optimized? +;;; Are warnings to be issued for iterate/gather forms that aren't +;;; optimized? ;;; NIL => never ;;; :USER => those resulting from user code ;;; T => always, even if it's the iteration macro that's suboptimal. @@ -33,46 +34,6 @@ (defmacro iterate (clauses &body body &environment env) (optimize-iterate-form clauses body env)) -(defun - simple-expand-iterate-form - (clauses body) - - ;; Expand ITERATE. This is the "formal semantics" expansion, which we never - ;; use. - (let* - ((block-name (gensym)) - (bound-var-lists (mapcar #'(lambda (clause) - (let ((names (first clause))) - (if (listp names) - names - (list names)))) - clauses)) - (generator-vars (mapcar #'(lambda (clause) - (declare (ignore clause)) - (gensym)) - clauses))) - `(block ,block-name - (let* - ,(mapcan #'(lambda (gvar clause var-list) - ;; For each clause, bind a generator temp to the clause, - ;; then bind the specified var(s). - (cons (list gvar (second clause)) - (copy-list var-list))) - generator-vars clauses bound-var-lists) - - ;; Note bug in formal semantics: there can be declarations in the head - ;; of BODY; they go here, rather than inside loop. - (loop - ,@(mapcar - #'(lambda (var-list gen-var) - ;; Set each bound variable (or set of vars) to the result of - ;; calling the corresponding generator. - `(multiple-value-setq ,var-list - (funcall ,gen-var #'(lambda nil (return-from - ,block-name))))) - bound-var-lists generator-vars) - ,@body))))) - ;;; temporary variable names used by ITERATE expansions (defparameter *iterate-temp-vars-list* '(iterate-temp-1 iterate-temp-2 iterate-temp-3 iterate-temp-4 diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp index 36fcbbb..6e89003 100644 --- a/src/pcl/low.lisp +++ b/src/pcl/low.lisp @@ -131,10 +131,10 @@ ;;; ;;; FIXME: Now that we're tightly integrated into SBCL, we could use the ;;; SBCL built-in unbound value token instead. -(defconstant *slot-unbound* '..slot-unbound..) +(defconstant +slot-unbound+ '..slot-unbound..) (defmacro %allocate-static-slot-storage--class (no-of-slots) - `(make-array ,no-of-slots :initial-element *slot-unbound*)) + `(make-array ,no-of-slots :initial-element +slot-unbound+)) (defmacro std-instance-class (instance) `(wrapper-class* (std-instance-wrapper ,instance))) diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp index 59463f7..7fdd212 100644 --- a/src/pcl/slots-boot.lisp +++ b/src/pcl/slots-boot.lisp @@ -84,7 +84,10 @@ `(let ,bindings ,form) form))) -(defconstant *optimize-slot-boundp* nil) +;;; FIXME: Why is this defined in two different places? And what does +;;; it mean anyway? And can we just eliminate it completely (replacing +;;; it with NIL, then hand-eliminating any resulting dead code)? +(defconstant +optimize-slot-boundp+ nil) (defmacro accessor-slot-boundp (object slot-name) (unless (constantp slot-name) @@ -92,7 +95,7 @@ 'accessor-slot-boundp)) (let* ((slot-name (eval slot-name)) (sym (slot-boundp-symbol slot-name))) - (if (not *optimize-slot-boundp*) + (if (not +optimize-slot-boundp+) `(slot-boundp-normal ,object ',slot-name) `(asv-funcall ,sym ,slot-name boundp ,object)))) @@ -103,7 +106,7 @@ (defun make-structure-slot-boundp-function (slotd) (let* ((reader (slot-definition-internal-reader-function slotd)) (fun #'(lambda (object) - (not (eq (funcall reader object) *slot-unbound*))))) + (not (eq (funcall reader object) +slot-unbound+))))) (declare (type function reader)) fun)) @@ -139,17 +142,17 @@ (fixnum (if fsc-p #'(lambda (instance) (let ((value (%instance-ref (fsc-instance-slots instance) index))) - (if (eq value *slot-unbound*) + (if (eq value +slot-unbound+) (slot-unbound (class-of instance) instance slot-name) value))) #'(lambda (instance) (let ((value (%instance-ref (std-instance-slots instance) index))) - (if (eq value *slot-unbound*) + (if (eq value +slot-unbound+) (slot-unbound (class-of instance) instance slot-name) value))))) (cons #'(lambda (instance) (let ((value (cdr index))) - (if (eq value *slot-unbound*) + (if (eq value +slot-unbound+) (slot-unbound (class-of instance) instance slot-name) value))))) `(reader ,slot-name))) @@ -176,21 +179,21 @@ #'(lambda (instance) (not (eq (%instance-ref (fsc-instance-slots instance) index) - *slot-unbound*))) + +slot-unbound+))) #'(lambda (instance) (not (eq (%instance-ref (std-instance-slots instance) index) - *slot-unbound*))))) + +slot-unbound+))))) (cons #'(lambda (instance) (declare (ignore instance)) - (not (eq (cdr index) *slot-unbound*))))) + (not (eq (cdr index) +slot-unbound+))))) `(boundp ,slot-name))) (defun make-optimized-structure-slot-value-using-class-method-function (function) (declare (type function function)) #'(lambda (class object slotd) (let ((value (funcall function object))) - (if (eq value *slot-unbound*) + (if (eq value +slot-unbound+) (slot-unbound class object (slot-definition-name slotd)) value)))) @@ -204,7 +207,7 @@ (declare (type function function)) #'(lambda (class object slotd) (declare (ignore class slotd)) - (not (eq (funcall function object) *slot-unbound*)))) + (not (eq (funcall function object) +slot-unbound+)))) (defun get-optimized-std-slot-value-using-class-method-function (class slotd name) (if (structure-class-p class) @@ -240,20 +243,20 @@ (declare (ignore slotd)) (unless (fsc-instance-p instance) (error "not fsc")) (let ((value (%instance-ref (fsc-instance-slots instance) index))) - (if (eq value *slot-unbound*) + (if (eq value +slot-unbound+) (slot-unbound class instance slot-name) value))) #'(lambda (class instance slotd) (declare (ignore slotd)) (unless (std-instance-p instance) (error "not std")) (let ((value (%instance-ref (std-instance-slots instance) index))) - (if (eq value *slot-unbound*) + (if (eq value +slot-unbound+) (slot-unbound class instance slot-name) value))))) (cons #'(lambda (class instance slotd) (declare (ignore slotd)) (let ((value (cdr index))) - (if (eq value *slot-unbound*) + (if (eq value +slot-unbound+) (slot-unbound class instance slot-name) value)))))) @@ -283,15 +286,15 @@ (declare (ignore class slotd)) (not (eq (%instance-ref (fsc-instance-slots instance) index) - *slot-unbound* ))) + +slot-unbound+ ))) #'(lambda (class instance slotd) (declare (ignore class slotd)) (not (eq (%instance-ref (std-instance-slots instance) index) - *slot-unbound* ))))) + +slot-unbound+ ))))) (cons #'(lambda (class instance slotd) (declare (ignore class instance slotd)) - (not (eq (cdr index) *slot-unbound*)))))) + (not (eq (cdr index) +slot-unbound+)))))) (defun get-accessor-from-svuc-method-function (class slotd sdfun name) (macrolet ((emf-funcall (emf &rest args) @@ -315,12 +318,12 @@ (typecase index (fixnum (let ((value (%instance-ref (get-slots instance) index))) - (if (eq value *slot-unbound*) + (if (eq value +slot-unbound+) (slot-unbound (class-of instance) instance slot-name) value))) (cons (let ((value (cdr index))) - (if (eq value *slot-unbound*) + (if (eq value +slot-unbound+) (slot-unbound (class-of instance) instance slot-name) value))) (t @@ -390,7 +393,7 @@ (gf (ensure-generic-function name))) (unless (generic-function-methods gf) (add-writer-method *the-class-slot-object* gf slot-name)))) - (when (and *optimize-slot-boundp* + (when (and +optimize-slot-boundp+ (or (null type) (eq type 'boundp))) (let* ((name (slot-boundp-symbol slot-name)) (gf (ensure-generic-function name))) diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp index 40360b7..ac09ca0 100644 --- a/src/pcl/slots.lisp +++ b/src/pcl/slots.lisp @@ -80,7 +80,7 @@ (let ((entry (assoc slot-name (wrapper-class-slots wrapper)))) (if (null entry) (slot-missing (wrapper-class wrapper) object slot-name 'slot-value) - (if (eq (cdr entry) *slot-unbound*) + (if (eq (cdr entry) +slot-unbound+) (slot-unbound (wrapper-class wrapper) object slot-name) (cdr entry))))) @@ -142,7 +142,7 @@ `(accessor-set-slot-value ,object-form ,slot-name-form ,new-value-form) `(set-slot-value-normal ,object-form ,slot-name-form ,new-value-form))) -(defconstant *optimize-slot-boundp* nil) +(defconstant +optimize-slot-boundp+ nil) (defun slot-boundp (object slot-name) (let* ((class (class-of object)) @@ -207,7 +207,7 @@ (error "The slot ~S has neither :INSTANCE nor :CLASS allocation, ~@ so it can't be read by the default ~S method." slotd 'slot-value-using-class))))) - (if (eq value *slot-unbound*) + (if (eq value +slot-unbound+) (slot-unbound class object (slot-definition-name slotd)) value))) @@ -256,7 +256,7 @@ (error "The slot ~S has neither :INSTANCE nor :CLASS allocation, ~@ so it can't be read by the default ~S method." slotd 'slot-boundp-using-class))))) - (not (eq value *slot-unbound*)))) + (not (eq value +slot-unbound+)))) (defmethod slot-makunbound-using-class ((class std-class) @@ -268,14 +268,16 @@ (cond ((std-instance-p object) (unless (eq 't (wrapper-state (std-instance-wrapper object))) (check-wrapper-validity object)) - (setf (%instance-ref (std-instance-slots object) location) *slot-unbound*)) + (setf (%instance-ref (std-instance-slots object) location) + +slot-unbound+)) ((fsc-instance-p object) (unless (eq 't (wrapper-state (fsc-instance-wrapper object))) (check-wrapper-validity object)) - (setf (%instance-ref (fsc-instance-slots object) location) *slot-unbound*)) + (setf (%instance-ref (fsc-instance-slots object) location) + +slot-unbound+)) (t (error "unrecognized instance type")))) (cons - (setf (cdr location) *slot-unbound*)) + (setf (cdr location) +slot-unbound+)) (t (error "The slot ~S has neither :INSTANCE nor :CLASS allocation, ~@ so it can't be written by the default ~S method." @@ -289,7 +291,7 @@ (let* ((function (slot-definition-internal-reader-function slotd)) (value (funcall function object))) (declare (type function function)) - (if (eq value *slot-unbound*) + (if (eq value +slot-unbound+) (slot-unbound class object (slot-definition-name slotd)) value))) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index d49be79..f8bd0bd 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -37,20 +37,20 @@ (writer (setf (slot-definition-writer-function slotd) function)) (boundp (setf (slot-definition-boundp-function slotd) function)))) -(defconstant *slotd-reader-function-std-p* 1) -(defconstant *slotd-writer-function-std-p* 2) -(defconstant *slotd-boundp-function-std-p* 4) -(defconstant *slotd-all-function-std-p* 7) +(defconstant +slotd-reader-function-std-p+ 1) +(defconstant +slotd-writer-function-std-p+ 2) +(defconstant +slotd-boundp-function-std-p+ 4) +(defconstant +slotd-all-function-std-p+ 7) (defmethod slot-accessor-std-p ((slotd effective-slot-definition) type) (let ((flags (slot-value slotd 'accessor-flags))) (declare (type fixnum flags)) (if (eq type 'all) - (eql *slotd-all-function-std-p* flags) + (eql +slotd-all-function-std-p+ flags) (let ((mask (ecase type - (reader *slotd-reader-function-std-p*) - (writer *slotd-writer-function-std-p*) - (boundp *slotd-boundp-function-std-p*)))) + (reader +slotd-reader-function-std-p+) + (writer +slotd-writer-function-std-p+) + (boundp +slotd-boundp-function-std-p+)))) (declare (type fixnum mask)) (not (zerop (the fixnum (logand mask flags)))))))) @@ -58,9 +58,9 @@ (slotd effective-slot-definition) type) (let ((mask (ecase type - (reader *slotd-reader-function-std-p*) - (writer *slotd-writer-function-std-p*) - (boundp *slotd-boundp-function-std-p*))) + (reader +slotd-reader-function-std-p+) + (writer +slotd-writer-function-std-p+) + (boundp +slotd-boundp-function-std-p+))) (flags (slot-value slotd 'accessor-flags))) (declare (type fixnum mask flags)) (setf (slot-value slotd 'accessor-flags) @@ -432,7 +432,7 @@ (gather1 (cons (slot-definition-name dslotd) (if initfunction (funcall initfunction) - *slot-unbound*)))))))) + +slot-unbound+)))))))) (setq predicate-name (if predicate-name-p (setf (slot-value class 'predicate-name) (car predicate-name)) @@ -506,31 +506,39 @@ (:constructor ,constructor ())) ,@(mapcar #'(lambda (slot) `(,(slot-definition-name slot) - *slot-unbound*)) + +slot-unbound+)) direct-slots))) - (reader-names (mapcar #'(lambda (slotd) - (intern (format nil "~A~A reader" conc-name - (slot-definition-name slotd)))) + (reader-names (mapcar (lambda (slotd) + (intern (format nil + "~A~A reader" + conc-name + (slot-definition-name + slotd)))) direct-slots)) - (writer-names (mapcar #'(lambda (slotd) - (intern (format nil "~A~A writer" conc-name - (slot-definition-name slotd)))) + (writer-names (mapcar (lambda (slotd) + (intern (format nil + "~A~A writer" + conc-name + (slot-definition-name + slotd)))) direct-slots)) (readers-init - (mapcar #'(lambda (slotd reader-name) - (let ((accessor - (slot-definition-defstruct-accessor-symbol slotd))) - `(defun ,reader-name (obj) - (declare (type ,name obj)) - (,accessor obj)))) + (mapcar (lambda (slotd reader-name) + (let ((accessor + (slot-definition-defstruct-accessor-symbol + slotd))) + `(defun ,reader-name (obj) + (declare (type ,name obj)) + (,accessor obj)))) direct-slots reader-names)) (writers-init - (mapcar #'(lambda (slotd writer-name) - (let ((accessor - (slot-definition-defstruct-accessor-symbol slotd))) - `(defun ,writer-name (nv obj) - (declare (type ,name obj)) - (setf (,accessor obj) nv)))) + (mapcar (lambda (slotd writer-name) + (let ((accessor + (slot-definition-defstruct-accessor-symbol + slotd))) + `(defun ,writer-name (nv obj) + (declare (type ,name obj)) + (setf (,accessor obj) nv)))) direct-slots writer-names)) (defstruct-form `(progn @@ -542,8 +550,10 @@ (let* ((reader (gdefinition reader-name)) (writer (when (gboundp writer-name) (gdefinition writer-name)))) - (setf (slot-value dslotd 'internal-reader-function) reader) - (setf (slot-value dslotd 'internal-writer-function) writer))) + (setf (slot-value dslotd 'internal-reader-function) + reader) + (setf (slot-value dslotd 'internal-writer-function) + writer))) direct-slots reader-names writer-names) (setf (slot-value class 'defstruct-form) defstruct-form) (setf (slot-value class 'defstruct-constructor) constructor)))) @@ -1091,7 +1101,7 @@ (setf (instance-ref nslots npos) (instance-ref oslots opos)) (progn (push name discarded) - (unless (eq (instance-ref oslots opos) *slot-unbound*) + (unless (eq (instance-ref oslots opos) +slot-unbound+) (setf (getf plist name) (instance-ref oslots opos))))))) ;; Go through all the old shared slots. @@ -1102,7 +1112,7 @@ (if npos (setf (instance-ref nslots npos) (cdr oclass-slot-and-val)) (progn (push name discarded) - (unless (eq val *slot-unbound*) + (unless (eq val +slot-unbound+) (setf (getf plist name) val))))))) ;; Go through all the new local slots to compute the added slots. diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index b4180e2..5f240ba 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -693,8 +693,8 @@ `((fixnum (%instance-ref ,slots ,index)))) ,@(when (or (null type) (eq type ':class)) `((cons (cdr ,index)))) - (t ',*slot-unbound*))) - (if (eq ,value ',*slot-unbound*) + (t +slot-unbound+))) + (if (eq ,value +slot-unbound+) ,default ,value)))))) @@ -771,9 +771,9 @@ (typecase ,index ,@(when (or (null type) (eq type ':instance)) `((fixnum (not (eq (%instance-ref ,slots ,index) - ',*slot-unbound*))))) + +slot-unbound+))))) ,@(when (or (null type) (eq type ':class)) - `((cons (not (eq (cdr ,index) ',*slot-unbound*))))) + `((cons (not (eq (cdr ,index) +slot-unbound+))))) (t ,default))))))) (defmacro instance-boundp (pv-offset parameter position slot-name class) diff --git a/tests/compiler-1.impure.lisp b/tests/compiler-1.impure.lisp index 368243c..d34e346 100644 --- a/tests/compiler-1.impure.lisp +++ b/tests/compiler-1.impure.lisp @@ -18,4 +18,15 @@ 'expected-value))) (assert (eq (bar) 'expected-value)) +(declaim (ftype (function (real) (values integer single-float)) valuesify)) +(defun valuesify (x) + (values (round x) + (coerce x 'single-float))) +(defun exercise-valuesify (x) + (multiple-value-bind (i f) (valuesify x) + (declare (type integer i)) + (declare (type single-float f)) + (+ i f))) +(assert (= (exercise-valuesify 1.25) 2.25)) + (sb-ext:quit :unix-status 104) ; success