;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
;;;
;;; *************************************************************************
;;; Copyright (c) 1985, 1986, 1987 Xerox Corporation. All rights reserved.
;;;
;;; Use and copying of this software and preparation of derivative works
;;; based upon this software are permitted. Any distribution of this
;;; software or derivative works must comply with all applicable United
;;; States export control laws.
;;;
;;; This software is made available AS IS, and Xerox Corporation makes no
;;; warranty about the software, its performance or its conformity to any
;;; specification.
;;;
;;; Any person obtaining a copy of this software is requested to send their
;;; name and post office or electronic mail address to:
;;; CommonLoops Coordinator
;;; Xerox Artifical Intelligence Systems
;;; 2400 Hanover St.
;;; Palo Alto, CA 94303
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
;;;
;;; Suggestions, comments and requests for improvements are also welcome.
;;; *************************************************************************
;;;
(in-package 'pcl)
#|
to do:
rename this file to dcode and complete change from dfun to dcode terminology
make *compile-dcodes-at-run-time-p* work by centralizing a facility for
call the template constructor of a dcode
also make *can-call-the-compiler-p* work in install-discriminator-code,
recompile-class-of and dfun-templ
make individuals work, at least a little
make a backup general case for dcode and hook it up to
*compile-dcodes-at-run-time-p* so that PCL won't call the compiler at run
time unless that is really appropriate
finish some more of the special cases for dcode
move compute-discriminator-code and its friends from methods to the top of
here
work on getting this stuff to compile faster
work on state transition table techology for compute-discriminator-code
|#
;;;
;;;
;;;
;;; number of methods -- default only
;;; one only
;;; 2 or more
;;;
;;; type of methods -- all readers or writers
;;; some readers or writers
;;; no readers or writers
;;;
;;; metaclass of specialiers -- all standard-class
;;; all funcallable-standard-class
;;; all any one metaclass
;;; assortment
;;;
(defvar *dcode-arg-symbols* ())
(defun dcode-arg-symbol (arg-number)
(or (cdr (assoc arg-number *dcode-arg-symbols* :test #'=))
(let ((new (cons arg-number
(make-symbol (format nil "DCODE-Arg ~D" arg-number)))))
(push new *dcode-arg-symbols*)
(cdr new))))
(eval-when (load) (dotimes (i 10) (dcode-arg-symbol (- 9 i))))
(defvar *dcode-class-symbols* ())
(defun dcode-class-symbol (arg-number)
(or (cdr (assoc arg-number *dcode-class-symbols* :test #'=))
(let ((new (cons arg-number
(make-symbol
(format nil "Class of arg ~D" arg-number)))))
(push new *dcode-class-symbols*)
(cdr new))))
(eval-when (load) (dotimes (i 10) (dcode-class-symbol (- 9 i))))
(defmacro generic-function-cache-offset (mask &rest classes)
`(logand ,mask
,@(iterate ((class in classes))
(collect `(object-cache-no ,class ,mask)))))
(defmacro generic-function-cache-entry (cache offset offset-from-offset)
`(memory-block-ref ,cache (+ ,offset ,offset-from-offset)))
(defmacro cache-method (cache mask method-function &rest classes)
`(let* ((.offset. (generic-function-cache-offset ,mask ,@classes)))
;; Once again, we have to endure a little brain damage because we can't
;; count on having without-interrupts. I suppose the speed loss isn't
;; too significant since this is only when we get a cache miss.
(setf (generic-function-cache-entry ,cache .offset. 0) nil)
,@(iterate ((class in (cdr classes)) (key-no from 1))
(collect `(setf (generic-function-cache-entry ,cache
.offset.
,key-no)
,class)))
(prog1
(setf (generic-function-cache-entry ,cache .offset. ,(length classes))
,method-function)
(setf (generic-function-cache-entry ,cache .offset. 0)
,(car classes)))))
(defmacro cached-method (cache mask &rest classes)
`(let ((.offset. (generic-function-cache-offset ,mask . ,classes)))
(and ,@(iterate ((class in classes) (key-no from 0))
(collect
`(eq (generic-function-cache-entry ,cache .offset. ,key-no)
,class)))
(generic-function-cache-entry ,cache .offset. ,(length classes)))))
;;;
;;; A caching discriminating function looks like:
;;; (lambda (arg-1 arg-2 arg-3 &rest rest-args)
;;; (prog* ((class-1 (class-of arg-1))
;;; (class-2 (class-of arg-2))
;;; method-function)
;;; (and (cached-method method-function CACHE MASK class-1 class-2)
;;; (go hit))
;;; miss
;;; (setq method-function
;;; (cache-method GENERIC-FUNCTION
;;; (lookup-method-function GENERIC-FUNCTION
;;; class-1
;;; class-2)))
;;; hit
;;; (if method-function
;;; (return (apply method-function arg-1 arg-2 arg-3 rest-args))
;;; (return (no-matching-method GENERIC-FUNCTION)))))
;;;
;;; The upper-cased variables are the ones which are lexically bound.
;;;
;;; There is a great deal of room to play here. This open codes the
;;; test to see if the instance is iwmc-class-p. Only if it isn't is
;;; there a function call to class-of. This is done because we only have
;;; a default implementation of make-discriminating-function, we don't
;;; have one which is specific to generic-function-class
;;; STANDARD-GENERIC-FUNCTION and meta-class CLASS.
;;;
;;; Of course a real implementation of CommonLoops wouldn't even do a
;;; real function call to get to the discriminating function.
(eval-when (compile load eval)
(defun default-make-class-of-form-fn (arg)
`(class-of-1 ,arg))
(defvar *make-class-of-form-fn* #'default-make-class-of-form-fn)
)
;;;
;;; 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-0 --> | <wrapper for FOO> |
;;; index-0 --> | 3 |
;;; | |
;;; . | . |
;;; . | . |
;;; | |
;;; class-n --> | <wrapper for BAR> |
;;; index-n --> | 1 |
;;; -------------------
;;;
;;; It is a one key cache, the keys are the class-wrapper of the
;;; specialized argument. (In the case of reader methods there
;;; is only one argument, it is the
;;;
;;;
;;;
(defun make-all-std-class-readers-dcode (generic-function)
(initialize-generic-function-cache generic-function ())
(funcall
(get-templated-function-constructor 'all-std-class-readers-dcode)
generic-function
(generic-function-cache generic-function)))
(defun make-all-std-class-writers-dcode (generic-function)
(initialize-generic-function-cache generic-function ())
(funcall
(get-templated-function-constructor 'all-std-class-writers-dcode)
generic-function
(generic-function-cache generic-function)))
(defmacro r/w-cache-key () '(generic-function-cache-entry .CACHE. offset 0))
(defmacro r/w-cache-val () '(generic-function-cache-entry .CACHE. offset 1))
(define-function-template all-std-class-readers-dcode
()
'(.GENERIC-FUNCTION. .CACHE.)
(let ((mask (make-generic-function-cache-mask 1)))
`(function
(lambda (arg)
(let* ((wrapper (and (iwmc-class-p arg)
(iwmc-class-class-wrapper arg)))
(offset (generic-function-cache-offset ,mask wrapper))
(method nil)
(class nil))
(cond ((eq (r/w-cache-key) wrapper)
(get-static-slot--class arg (r/w-cache-val)))
((setq class (class-wrapper-class wrapper)
method (lookup-method .GENERIC-FUNCTION. class))
(let* ((slot-name (reader/writer-method-slot-name method))
(slot-pos
(slotd-position
slot-name
(class-instance-slots class))))
(cond ((not (null slot-pos)) ;This is an instance slot.
(setq slot-pos
(%convert-slotd-position-to-slot-index
slot-pos))
(without-interrupts
(setf (r/w-cache-key) wrapper)
(setf (r/w-cache-val) slot-pos))
(get-static-slot--class arg slot-pos))
(t
(slot-value-using-class--class-internal
class arg slot-name nil nil)))))
(t
(no-matching-method .GENERIC-FUNCTION.))))))))
(define-function-template all-std-class-writers-dcode
()
'(.GENERIC-FUNCTION. .CACHE.)
(let ((mask (make-generic-function-cache-mask 1)))
`(function
(lambda (arg new-value)
(let* ((wrapper (and (iwmc-class-p arg)
(iwmc-class-class-wrapper arg)))
(offset (generic-function-cache-offset ,mask wrapper))
(method nil)
(class nil))
(cond ((eq (r/w-cache-key) wrapper)
(setf (get-static-slot--class arg (r/w-cache-val)) new-value))
((setq class (class-wrapper-class wrapper)
method (lookup-method .GENERIC-FUNCTION. class))
(let* ((slot-name (reader/writer-method-slot-name method))
(slot-pos
(slotd-position
slot-name
(class-instance-slots class))))
(cond ((not (null slot-pos)) ;This is an instance slot.
(setq slot-pos
(%convert-slotd-position-to-slot-index
slot-pos))
(without-interrupts
(setf (r/w-cache-key) wrapper)
(setf (r/w-cache-val) slot-pos))
(setf (get-static-slot--class arg slot-pos)
new-value))
(t
(put-slot-using-class--class-internal
class arg slot-name new-value nil)))))
(t
(no-matching-method .GENERIC-FUNCTION.))))))))
(eval-when (load)
(pre-make-templated-function-constructor all-std-class-readers-dcode)
(pre-make-templated-function-constructor all-std-class-writers-dcode))
(define-function-template caching-discriminating-function
(required restp
specialized-positions
lookup-function
mask)
'(.GENERIC-FUNCTION. .CACHE.)
(let* ((args (with-collection
(dotimes (i required)
(collect (make-symbol (format nil "Disc-Fn-Arg ~D" i))))))
(class-bindings
;; *** Pay careful attention to what is going on here. What is
;; *** going on here, is that if a position is not specialized,
;; *** then we just let its class (THE CLASS THAT WE WILL PASS
;; *** TO THE LOOKUP FUNCTION), be NIL. This is done for two
;; *** reasons:
;; *** 1. speed, if we don't need the class, why bother to
;; *** compute it.
;; *** 2. Bootstrapping reasons. During Booting, there are
;; *** times when we can't compute the class of something,
;; *** but it is a T specialized argument (the new value
;; *** argument to a setf of an accessor.
(with-collection
(dotimes (i (1+ (apply #'max specialized-positions)))
(collect
(list (make-symbol (format nil "Class of ARG ~D" i))
(if (member i specialized-positions)
(funcall *make-class-of-form-fn* (nth i args))
nil))))))
(classes (remove nil (mapcar #'car class-bindings)))
(method-function-var (make-symbol "Method Function"))
(rest-arg-var (and restp (make-symbol "Disc-Fn-&Rest-Arg"))))
`(function
(lambda (,@args ,@(and rest-arg-var (list '&rest rest-arg-var)))
(prog ((,method-function-var nil)
,@class-bindings)
(and (setq ,method-function-var
(cached-method .CACHE. ,mask ,@classes))
(go hit))
(and (setq ,method-function-var
(cache-method .CACHE.
,mask
(,lookup-function .GENERIC-FUNCTION.
,@classes)
,@classes))
(go hit))
(no-matching-method .GENERIC-FUNCTION.)
hit (return
,(if restp
`(apply ,method-function-var ,@args ,rest-arg-var)
`(funcall ,method-function-var ,@args))))))))
(eval-when (compile)
(defmacro pre-make-caching-discriminating-functions (specs)
`(progn . ,(iterate ((spec in specs))
(collect `(pre-make-templated-function-constructor
caching-discriminating-function
,@spec
,(make-generic-function-cache-mask
(length (caddr spec)))))))))
;;;
;;; dcode-pre1 has a call to pre-make-caching-discriminating-functions
;;;
;;
;;;;;;
;;
(eval-when (compile load eval)
(defun make-checking-discriminating-function-1 (check-positions)
(with-collection
(dolist (pos check-positions)
(collect (if (null pos)
'ignore
(intern (format nil "Check ~D" pos)))))))
)
(define-function-template checking-discriminating-function
(required restp defaultp checks)
`(generic-function method-function default-function
,@(make-checking-discriminating-function-1 checks))
(let* ((arglist (make-discriminating-function-arglist required restp)))
`(function
(lambda ,arglist
(declare (optimize (speed 3) (safety 0)))
,(when (memq 'ignore arglist) '(declare (ignore ignore)))
generic-function default-function ;ignorable
(if (and ,@(with-collection
(do* ((checks (make-checking-discriminating-function-1
checks)
(cdr checks))
(args arglist (cdr args))
(check (car checks) (car checks))
(arg (car args) (car args)))
((or (null checks) (null args)))
(when (neq check 'ignore)
(collect
`(memq ,check
; (let ((.class. (class-of ,arg)))
; (slot-value--class .class.
; 'class-precedence-list))
; (get-static-slot--class
; ,(funcall *make-class-of-form-fn* arg)
; ,(slotd-position 'class-precedence-list
; *bootstrap-slots*))
(slot-value--class
,(funcall *make-class-of-form-fn* arg)
'class-precedence-list)
))))))
,(if restp
`(apply method-function ,@(remove '&rest arglist))
`(funcall method-function ,@arglist))
,(if defaultp
(if restp
`(apply default-function ,@(remove '&rest arglist))
`(funcall default-function ,@arglist))
`(no-matching-method generic-function)))))))
(eval-when (compile)
(defmacro pre-make-checking-discriminating-functions (specs)
`(progn . ,(iterate ((spec in specs))
(collect `(pre-make-templated-function-constructor
checking-discriminating-function
,@spec))))))
;;;
;;; dcode-pre2 has a call to pre-make-checking-discriminating-functions
;;;
()