;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
;;;
;;; *************************************************************************
;;; Copyright (c) 1985 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)))))))))
(eval-when (load)
(pre-make-caching-discriminating-functions
((2 NIL (1) LOOKUP-MULTI-METHOD) ;setf of accessor gfuns
(2 NIL (0 1) LOOKUP-MULTI-METHOD)
(4 NIL (0) LOOKUP-CLASSICAL-METHOD)
(5 NIL (0) LOOKUP-CLASSICAL-METHOD)
(1 T (0) LOOKUP-CLASSICAL-METHOD)
(3 NIL (0 1) LOOKUP-MULTI-METHOD)
(4 T (0) LOOKUP-CLASSICAL-METHOD)
(3 T (0) LOOKUP-CLASSICAL-METHOD)
(3 NIL (0) LOOKUP-CLASSICAL-METHOD)
(1 NIL (0) LOOKUP-CLASSICAL-METHOD)
(2 NIL (0) LOOKUP-CLASSICAL-METHOD)
(6 NIL (0 1) LOOKUP-MULTI-METHOD))))
;;
;;;;;;
;;
(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)))
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))))))
(eval-when (load)
(pre-make-checking-discriminating-functions ((7 NIL NIL (0))
(2 NIL NIL (0 1))
(2 NIL NIL (NIL 1))
(2 T NIL (0))
(3 NIL NIL (0 1))
(7 NIL NIL (0 1))
(5 NIL NIL (0 1))
(3 NIL NIL (0 NIL 2))
(6 NIL NIL (0))
(5 NIL NIL (0))
(4 T NIL (0))
(3 T NIL (0))
(1 T NIL (0))
(4 NIL NIL (0))
(3 NIL NIL (0))
(3 NIL T (0 1))
(2 NIL T (0))
(5 NIL T (0 1))
(1 T T (0))
(1 NIL T (0))
(2 NIL T (0 1))
(3 NIL T (0))
(2 T T (0))
(6 NIL T (0 1))
(3 NIL T (0 NIL 2))
(4 NIL T (0 1))
(4 NIL T (0))
(5 NIL T (0))
(1 NIL NIL (0))
(2 NIL NIL (0))
(6 NIL NIL (0 1)))))