;;;-*-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
;;;

()