(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
;;; 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)
(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.
;; 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)
,@(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))
(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
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)))
;; 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
(: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)
(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)
(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)
(: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.)
:printer *condition-name-vec*)
(defun conditional-opcode (condition)
- (cdr (assoc condition conditions :test #'eq)))
+ (cdr (assoc condition *conditions* :test #'eq)))
\f
;;;; disassembler instruction formats
(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)
(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))))))
\f
;;;; 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.")
#!+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
(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
\f
;;;; 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:
(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))
\f
;;;; 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)
(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)
(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)
(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)
(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))
\f
;;;; SB definitions
`(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
;; 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)
;; 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)
;; 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
;; 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)
;; 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)
;; 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)
)
: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
\f
;;;; miscellaneous TNs for the various registers
(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)
(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
#|
\f
;;; 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)
(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))
(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)))))
(and .slots.
(not (eq (%instance-ref
.slots. (fast-instance-boundp-index ,emf))
- ',*slot-unbound*)))))))
+ +slot-unbound+)))))))
||#
(t
(etypecase ,emf
(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))
(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))))
(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*
(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))
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
,(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))
(in-package "SB-PCL")
\f
-;;; 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.
\f
;;; 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)))
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))
\f
;;; 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
(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 ()))
\f
;;;; 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)
\f
;;;; 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))
(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))))
`(%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
;;; 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)
(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)
(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))
(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)
(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)
;;; 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
;;;; 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.))
;;; 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)
;;; Returns NIL or (values <field> <cache-vector>)
;;;
-;;; 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))))
(when free-old-cache-p (free-cache cache))
(maybe-check-cache ncache)))))
\f
-;;; 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.
;;;
(defvar *empty-cache* (make-cache)) ; for defstruct slot initial value forms
\f
-;;; 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)))
(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)
(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))))))
(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)))
(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)
`((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
(in-package "SB-ITERATE")
\f
-;;; 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.
(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
;;;
;;; 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)))
`(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)
'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))))
(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))
(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)))
#'(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))))
(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)
(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))))))
(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)
(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
(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)))
(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)))))
`(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))
(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)))
(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)
(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."
(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)))
(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))))))))
(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)
(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))
(: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
(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))))
(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.
(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.
`((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))))))
(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)
'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
projects / sbcl.git / commitdiff