[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
PCL on the VAX
- To: CommonLoops.pa@Xerox.COM
- Subject: PCL on the VAX
- From: Jacky Combs <combs@STC.LOCKHEED.COM>
- Date: Thu, 2 Mar 89 14:23:38 CST
- Redistributed: CommonLoops.pa
I have the following "fixes" for using PCL on a VAX/VMS with VAX Common Lisp.
The EXPAND-DCODE-CACHE function should replace the one in the dcode.lisp file
prior to compiling PCL. There is still a problem with the generic function
representation when printing a description to the screen or when you end up in
the debugger, but at least this code will keep you from ending up in an
infinite loop.
;;; Modified expand-dcode-cache function for VAX Common Lisp.
(defun expand-dcode-cache (generic-function
old-cache
old-size
line-size
nkeys
next-scan-limit
dcode-constructor)
(let* ((new-size (* old-size 2))
(new-number-of-lines (floor new-size line-size))
(new-mask (make-wrapper-cache-mask new-number-of-lines))
(new-cache (get-generic-function-cache new-size))
(new-dcode nil)
(wrappers ())
(value nil))
(flet ((collect-wrappers (loc)
(block collect-wrappers ; need to explicitly create a
; collect-wrappers block for
; VAX Common Lisp in order to do a
; return-from collect-wrappers in the
; following if statement
(when (%svref old-cache loc)
(setq wrappers ())
(dotimes (i nkeys)
(let ((wrapper (%svref old-cache (+ i loc))))
(if (zerop (wrapper-cache-no wrapper))
;; This wrapper is obsolete, we don't have an instance
;; so there is no related trap. Just drop this line
;; on the floor.
(return-from collect-wrappers nil) ; here is the return that
; was causing a problem in
; VAX CL
(push wrapper wrappers))))
(setq wrappers (nreverse wrappers)
value (and (< nkeys line-size)
(%svref old-cache (+ loc nkeys))))
t))))
(flush-generic-function-caches-internal new-cache)
(do ((old-location line-size (+ old-location line-size)))
((= old-location old-size))
(when (collect-wrappers old-location)
(apply #'dcode-cache-miss generic-function
#'(lambda (&rest ignore)
(declare (ignore ignore))
value)
new-cache
new-size
new-mask
line-size
nkeys
next-scan-limit
nil ;Means don't allow another
;expand while filling the
;new cache. This can only
;happen in one pathological
;case, but prevent it anyways.
dcode-constructor
wrappers)))
(setq new-dcode (funcall dcode-constructor generic-function new-cache))
(setf (generic-function-cache generic-function) new-cache)
(install-discriminating-function generic-function new-dcode)
(free-generic-function-cache old-cache)
new-cache)))
;;;
;;; No methods??
;;;
(defun make-no-methods-dcode (generic-function)
#'(lambda (&rest ignore)
(declare (ignore ignore))
(error "There are no methods on the generic-function ~S,~%~
so it is an error to call it."
generic-function)))
;;;
;;; Default method only is pretty easy.
;;;
(defun make-default-method-only-dcode (generic-function)
(cddar (generic-function-combined-methods generic-function)))
;;;
;;; Individuals are a total loss.
;;;
(defun make-individual-method-dcode (generic-function)
#'(lambda (&rest args)
(let ((m (apply #'lookup-method-internal
generic-function
(slot-value--fsc generic-function 'combined-methods)
#'car
args)))
(if m
(apply (cddr m) args)
(apply #'no-applicable-method generic-function args)))))
;;;
;;; In the case where all the methods on a generic function are either writers
;;; or readers, we can win by pulling the slot-lookup caching that the methods
;;; would do when they are called directly into the discriminator code and its
;;; cache.
;;; For this case, the generic function cache is used as follows:
;;;
;;; -------------------
;;; . | . |
;;; . | . |
;;; | |
;;; class-i --> | <wrapper for FOO> |
;;; index-i --> | 3 |
;;; | |
;;; . | . |
;;; . | . |
;;; | |
;;; class-j --> | <wrapper for BAR> |
;;; index-j --> | 1 |
;;; | |
;;; . | . |
;;; . | . |
;;; | |
;;; -------------------
;;;
;;; It is a one key cache, the keys are the class-wrapper of the
;;; specialized argument. Writer methods only specialize the object
;;; argument.
;;;
;;;
;;;
(defvar *all-std-class-accessors-default-number-of-cache-lines* 8)
(defvar *all-std-class-accessors-default-cache-mask* *8-cache-mask*)
(defvar *all-std-class-accessors-next-scan-limit* 4)
(defvar *all-std-class-accessors-max-cache-size* 64)
(defun make-all-std-class-readers-dcode (generic-function &optional cache)
(let ((cache-size nil)
(cache-mask nil))
(if cache
(setq cache-size (generic-function-cache-size cache)
cache-mask (make-wrapper-cache-mask (floor cache-size 2)))
(progn
(setq cache-size
(* *all-std-class-accessors-default-number-of-cache-lines* 2))
(setq cache-mask
*all-std-class-accessors-default-cache-mask*)
(setq cache
(ensure-generic-function-cache generic-function cache-size))))
(funcall (get-templated-function-constructor 'all-std-class-readers-dcode
cache-size
cache-mask)
generic-function
cache
*all-std-class-accessors-next-scan-limit*)))
(defun make-all-std-class-writers-dcode (generic-function &optional cache)
(let ((cache-size nil)
(cache-mask nil))
(if cache
(setq cache-size (generic-function-cache-size cache)
cache-mask (make-wrapper-cache-mask (floor cache-size 2)))
(progn
(setq cache-size
(* *all-std-class-accessors-default-number-of-cache-lines* 2))
(setq cache-mask
*all-std-class-accessors-default-cache-mask*)
(setq cache
(ensure-generic-function-cache generic-function cache-size))))
(funcall (get-templated-function-constructor 'all-std-class-writers-dcode
cache-size
cache-mask)
generic-function
cache
*all-std-class-accessors-next-scan-limit*)))
(define-function-template all-std-class-readers-dcode
(cache-size cache-mask)
'(.GENERIC-FUNCTION. .CACHE. .NEXT-SCAN-LIMIT.)
(let ()
`(function
(lambda (arg)
(declare (optimize (speed 3) (safety 0)))
(let ((value nil))
(all-std-class-accessors-dcode-internal
nil
index
,cache-size
,cache-mask
#'all-std-class-readers-tertiary-miss
#'make-all-std-class-readers-dcode
(progn
(setq value (%svref (iwmc-class-static-slots arg) index))
(if (eq value ',*slot-unbound*)
(go miss)
(return-from accessor-dcode value)))
(return-from accessor-dcode (slot-value arg index))))))))
(define-function-template all-std-class-writers-dcode
(cache-size cache-mask)
'(.GENERIC-FUNCTION. .CACHE. .NEXT-SCAN-LIMIT.)
(let ()
`(function
(lambda (new-value arg)
(declare (optimize (speed 3) (safety 0)))
(all-std-class-accessors-dcode-internal
t
index
,cache-size
,cache-mask
#'all-std-class-writers-tertiary-miss
#'make-all-std-class-writers-dcode
(setf (%svref (iwmc-class-static-slots arg) index) new-value)
(setf (slot-value arg index) new-value))))))
(defmacro all-std-class-accessors-dcode-internal (writerp
index
cache-size
cache-mask
tertiary-miss
dcode-constructor
fast-form
slow-form)
`(block accessor-dcode
(macrolet ((r/w-cache-key () '(%svref .CACHE. location))
(r/w-cache-val () '(%svref .CACHE. (%1+ location))))
(let* ((wrapper (and (iwmc-class-p arg)
(iwmc-class-class-wrapper arg)))
(location 0)
(,index nil))
(if (null wrapper)
(no-applicable-method .GENERIC-FUNCTION. arg)
(with-cache-locked .CACHE.
(tagbody
(setq location
(compute-wrapper-cache-location ,cache-mask 2 wrapper))
(cond ((eq (r/w-cache-key) wrapper)
(setq ,index (r/w-cache-val))
(go hit))
(t
(setq location (%- (- ,cache-size 2) location))
(cond ((eq (r/w-cache-key) wrapper)
(setq ,index (r/w-cache-val))
(go hit))
(t
(go miss)))))
hit
(return-from accessor-dcode ,fast-form)
miss
(progn
(unlock-cache)
(setq ,index
(dcode-cache-miss
.GENERIC-FUNCTION.
,tertiary-miss
.CACHE.
,cache-size
,cache-mask
2 ;line size
1 ;nkeys
.NEXT-SCAN-LIMIT.
(< ,cache-size
*all-std-class-accessors-max-cache-size*)
,dcode-constructor
wrapper
,@(and writerp '(new-value))
arg))
(cond ((eq ,index '..no-applicable-method..)
(return-from accessor-dcode
(no-applicable-method .GENERIC-FUNCTION. arg)))
((not (symbolp ,index))
(go hit))
(t
(return-from accessor-dcode ,slow-form)))))))))))
(defun all-std-class-readers-tertiary-miss (generic-function arg)
(let ((method (lookup-method-1 generic-function arg)))
(if (null method)
'..no-applicable-method..
(let* ((wrapper (wrapper-of arg))
(class (wrapper-class wrapper))
(slot-name (reader/writer-method-slot-name method))
(slot-pos (all-std-class-readers-miss-1 class
wrapper
slot-name))
(slots (iwmc-class-static-slots arg)))
(if (and (not (null slot-pos))
(neq (svref slots slot-pos) *slot-unbound*))
slot-pos
slot-name)))))
(defun all-std-class-writers-tertiary-miss (generic-function new-value arg)
(let ((method (lookup-method-1 generic-function new-value arg)))
(if (null method)
'..no-applicable-method..
(let* ((wrapper (wrapper-of arg))
(class (wrapper-class wrapper))
(slot-name (reader/writer-method-slot-name method))
(slot-pos (all-std-class-readers-miss-1 class
wrapper
slot-name)))
(if (not (null slot-pos))
slot-pos
slot-name)))))
(defmethod all-std-class-readers-miss-1
((class standard-class) wrapper slot-name)
(instance-slot-position wrapper slot-name))
(defmacro pre-make-all-std-class-accessor-dcodes (&rest lines)
(let ((forms ()))
(dolist (nlines lines)
(push (pre-make-all-std-class-accessors-1 nlines) forms))
`(progn ,.forms)))
(defun pre-make-all-std-class-accessors-1 (nlines)
(let ((cache-mask (make-wrapper-cache-mask nlines))
(cache-size (* nlines 2)))
`(progn
(pre-make-templated-function-constructor all-std-class-readers-dcode
,cache-size
,cache-mask)
(pre-make-templated-function-constructor all-std-class-writers-dcode
,cache-size
,cache-mask))))
;;;
;;; In the case where there is only one method on a generic function, we can
;;; use a cache which has no values, only keys. The existence of a set of
;;; keys in the cache means that that one method is in fact applicable. The
;;; advantage to this kind of cache is that we can save cache space.
;;;
(defvar *checking-dcode-default-number-of-cache-lines* 8)
(defvar *checking-dcode-default-next-scan-limit* 4)
(defvar *checking-dcode-max-cache-size* 256)
(defun checking-dcode-default-cache-size (nkeys)
(declare (values size mask line-size))
(let* ((nlines *checking-dcode-default-number-of-cache-lines*)
(line-size (compute-line-size nkeys))
(cache-size (* nlines line-size)))
(values cache-size
(case nlines
((8) *8-cache-mask*)
((16) *16-cache-mask*)
((32) *32-cache-mask*)
(otherwise (make-wrapper-cache-mask nlines)))
line-size)))
(defun make-checking-dcode (generic-function &optional cache)
(multiple-value-bind (required restp specialized-positions)
(compute-discriminating-function-arglist-info generic-function)
(let ((nkeys (length specialized-positions))
(cache-size nil)
(cache-mask nil)
(nlines nil)
(line-size nil))
(cond ((null cache)
(multiple-value-setq (cache-size cache-mask line-size)
(checking-dcode-default-cache-size nkeys))
(setq cache
(ensure-generic-function-cache generic-function
cache-size)))
(t
(setq cache-size (generic-function-cache-size cache)
line-size (compute-line-size nkeys)
nlines (floor cache-size line-size)
cache-mask (case nlines
((8) *8-cache-mask*)
((16) *16-cache-mask*)
((32) *32-cache-mask*)
(otherwise
(make-wrapper-cache-mask nlines))))))
(funcall (get-templated-function-constructor 'checking-dcode
required
restp
specialized-positions
cache-size
cache-mask
line-size)
generic-function
cache
*checking-dcode-default-next-scan-limit*
(cddar (generic-function-combined-methods generic-function))))))
(defmacro pre-make-checking-dcode (specs)
`(progn
,@(gathering ((forms (collecting)))
(dolist (spec specs)
(destructuring-bind (required restp specialized-positions . lines)
spec
(let* ((nkeys (length specialized-positions))
(line-size (compute-line-size nkeys)))
(dolist (nlines lines)
(let ((size (* nlines line-size))
(mask (make-wrapper-cache-mask nlines)))
(gather `(pre-make-templated-function-constructor
checking-dcode
,required
,restp
,specialized-positions
,size
,mask
,line-size)
forms)))))))))
(defun checking-dcode-tertiary-miss (generic-function &rest required-args)
(if (not (null (apply #'lookup-method-2 generic-function required-args)))
1
'..no-applicable-method..))
(define-function-template checking-dcode (required
restp
specialized-positions
cache-size
cache-mask
line-size)
'(.GENERIC-FUNCTION.
.CACHE.
.NEXT-SCAN-LIMIT.
.METHOD-FUNCTION.)
(let* ((nkeys (length specialized-positions))
(args (gathering ((args (collecting)))
(dotimes (i required)
(gather (dcode-arg-symbol i) args))))
(wrapper-bindings (gathering ((bindings (collecting)))
(dolist (pos specialized-positions)
(gather (list (dcode-wrapper-symbol pos)
`(wrapper-of-2 ,(nth pos args)))
bindings))))
(wrappers (mapcar #'car wrapper-bindings)))
(flet ((make-call (fn &rest extra-args)
(when (eq fn 'probe) (setq fn '.METHOD-FUNCTION.))
(if restp
`(apply ,fn ,@extra-args ,@args rest-arg)
`(funcall ,fn ,@extra-args ,@args)))
(make-probe (loc)
`(and ,@(gathering1 (collecting)
(iterate ((wrapper (list-elements wrappers))
(key-no (interval :from 0)))
(gather1 `(eq (%svref .CACHE. (%+ ,loc ,key-no))
,wrapper)))))))
`(function
(lambda (,@args ,@(and restp '(&rest rest-arg)))
(declare (optimize (speed 3) (safety 0)))
#+genera-release-7-2
(declare (dbg:invisible-frame :clos-discriminator))
(let ,wrapper-bindings
,(make-caching-dcode-internal #'make-call
#'make-probe
'#'checking-dcode-tertiary-miss
wrappers
args
cache-size
cache-mask
line-size
nkeys
'*checking-dcode-max-cache-size*
'#'make-checking-dcode)))))))
;;;
;;; This is the case where there multiple methods. In this case the values
;;; are the actual method function.
;;;
(defvar *caching-dcode-default-number-of-cache-lines* 8)
(defvar *caching-dcode-default-next-scan-limit* 3)
(defvar *caching-dcode-max-cache-size* 256)
(defun caching-dcode-default-cache-size (nkeys)
(declare (values size mask line-size))
(let* ((nlines *caching-dcode-default-number-of-cache-lines*)
(line-size (compute-line-size (1+ nkeys)))
(cache-size (* nlines line-size)))
(values cache-size
(case nlines
((8) *8-cache-mask*)
((16) *16-cache-mask*)
((32) *32-cache-mask*)
(otherwise (make-wrapper-cache-mask nlines)))
line-size)))
(defun make-caching-dcode (generic-function &optional cache)
(multiple-value-bind (required restp specialized-positions)
(compute-discriminating-function-arglist-info generic-function)
(let ((nkeys (length specialized-positions))
(cache-size nil)
(cache-mask nil)
(nlines nil)
(line-size nil))
(cond ((null cache)
(multiple-value-setq (cache-size cache-mask line-size)
(caching-dcode-default-cache-size nkeys))
(setq cache
(ensure-generic-function-cache generic-function
cache-size)))
(t
(setq cache-size (generic-function-cache-size cache)
line-size (compute-line-size (1+ nkeys))
nlines (floor cache-size line-size)
cache-mask (case nlines
((8) *8-cache-mask*)
((16) *16-cache-mask*)
((32) *32-cache-mask*)
(otherwise
(make-wrapper-cache-mask nlines))))))
(funcall (get-templated-function-constructor 'caching-dcode
required
restp
specialized-positions
cache-size
cache-mask
line-size)
generic-function
cache
*caching-dcode-default-next-scan-limit*))))
(defmacro pre-make-caching-dcode (specs)
`(progn
,@(gathering ((forms (collecting)))
(dolist (spec specs)
(destructuring-bind (required restp specialized-positions . lines)
spec
(let* ((nkeys (length specialized-positions))
(line-size (compute-line-size (1+ nkeys))))
(dolist (nlines lines)
(let* ((size (* nlines line-size))
(mask (make-wrapper-cache-mask nlines)))
(gather `(pre-make-templated-function-constructor
caching-dcode
,required
,restp
,specialized-positions
,size
,mask
,line-size)
forms)))))))))
(defun caching-dcode-tertiary-miss (generic-function &rest required-args)
(or (apply #'lookup-method-2 generic-function required-args)
'..no-applicable-method..))
(define-function-template caching-dcode (required
restp
specialized-positions
cache-size
cache-mask
line-size)
'(.GENERIC-FUNCTION.
.CACHE.
.NEXT-SCAN-LIMIT.)
(let* ((nkeys (length specialized-positions))
(args (gathering ((args (collecting)))
(dotimes (i required)
(gather (dcode-arg-symbol i) args))))
(wrapper-bindings (gathering ((bindings (collecting)))
(dolist (pos specialized-positions)
(gather (list (dcode-wrapper-symbol pos)
`(wrapper-of-2 ,(nth pos args)))
bindings))))
(wrappers (mapcar #'car wrapper-bindings)))
(flet ((make-call (fn &rest extra-args)
(if restp
`(apply ,fn ,@extra-args ,@args rest-arg)
`(funcall ,fn ,@extra-args ,@args)))
(make-probe (loc)
`(and ,@(gathering1 (collecting)
(iterate ((wrapper (list-elements wrappers))
(key-no (interval :from 0)))
(gather1 `(eq (%svref .CACHE. (%+ ,loc ,key-no))
,wrapper))))
(%svref .CACHE. (%+ ,loc ,(length wrappers))))))
`(function
(lambda (,@args ,@(and restp '(&rest rest-arg)))
(declare (optimize (speed 3) (safety 0)))
#+genera-release-7-2
(declare (dbg:invisible-frame :clos-discriminator))
(let ,wrapper-bindings
,(make-caching-dcode-internal #'make-call
#'make-probe
'#'caching-dcode-tertiary-miss
wrappers
args
cache-size
cache-mask
line-size
nkeys
'*caching-dcode-max-cache-size*
'#'make-caching-dcode)))))))
(defun make-caching-dcode-internal (make-call
make-probe
tertiary-miss
wrappers
args
cache-size
cache-mask
line-size
nkeys
max-cache-size
dcode-constructor)
`(prog ((probe nil)
(location (compute-wrapper-cache-location ,cache-mask
,line-size
,@wrappers)))
(with-cache-locked .CACHE.
(tagbody
(if (setq probe ,(funcall make-probe 'location))
(progn (unlock-cache) (go hit))
(progn
(setq location (%- ,(- cache-size line-size) location))
(if (setq probe ,(funcall make-probe 'location))
(progn (unlock-cache) (go hit))
(progn
(unlock-cache)
(setq probe
(dcode-cache-miss .generic-function.
,tertiary-miss
.CACHE.
,cache-size
,cache-mask
,line-size
,nkeys
.NEXT-SCAN-LIMIT.
(< ,cache-size ,max-cache-size)
,dcode-constructor
,@wrappers
,@args))
(if (eq probe '..no-applicable-method..)
(return ,(funcall make-call
'#'no-applicable-method
'.GENERIC-FUNCTION.))
(go hit))))))
hit (return ,(funcall make-call 'probe))))))
;;; The following is to correct the problem with printing generic function
;;; stuff
(setq *print-pretty* t)
(setq *print-level* 2)
(setq *print-length* 5)
(setq *debug-print-level* 2)
(setq *debug-print-length* 5)
(define-list-print-function system::%compiled-closure%
(alist stream)
(if (generic-function-p alist)
(write (generic-function-name alist) :stream stream)
(write alist :stream stream)))
;; For VAX Common Lisp we have to define a different DESCRIBE-INSTANCE function
;; in order to printout the description of a generic function without
;; getting into an infinite loop.
(defun describe-instance (object &optional (stream t))
(let* ((class (class-of object))
(slotds (slots-to-inspect class object))
(max-slot-name-length 0)
(instance-slotds ())
(class-slotds ())
(other-slotds ()))
(flet ((adjust-slot-name-length (name)
(setq max-slot-name-length
(max max-slot-name-length
(length (the string (symbol-name name))))))
(describe-slot (name value &optional (allocation () alloc-p))
(if alloc-p
(format stream
"~% ~A ~S ~VT ~S"
name allocation (+ max-slot-name-length 7) value)
(format stream
"~% ~A~VT ~S"
name max-slot-name-length value))))
;; Figure out a good width for the slot-name column.
(dolist (slotd slotds)
;; VAX Comon Lisp fix - don't print out DISCRIMINATOR-CODE slot,
;; it is a circular list
(if (equalp (slotd-name slotd) 'discriminator-code)
()
(progn
(adjust-slot-name-length (slotd-name slotd))
(case (slotd-allocation slotd)
(:instance (push slotd instance-slotds))
(:class (push slotd class-slotds))
(otherwise (push slotd other-slotds))))))
(setq max-slot-name-length (min (+ max-slot-name-length 3) 30))
(format stream "~%~S is an instance of class ~S:" object class)
(when instance-slotds
(format stream "~% The following slots have :INSTANCE allocation:")
(dolist (slotd (nreverse instance-slotds))
(describe-slot (slotd-name slotd)
(slot-value-or-default object (slotd-name slotd)))))
(when class-slotds
(format stream "~% The following slots have :CLASS allocation:")
(dolist (slotd (nreverse class-slotds))
(describe-slot (slotd-name slotd)
(slot-value-or-default object (slotd-name slotd)))))
(when other-slotds
(format stream "~% The following slots have allocation as shown:")
(dolist (slotd (nreverse other-slotds))
(describe-slot (slotd-name slotd)
(slot-value-or-default object (slotd-name slotd))
(slotd-allocation slotd))))
(values))))