;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-

;;;. Copyright (c) 1991 by Venue

(in-package "CLOS")

                                                             
                                                             ; ************************************************************************
                                                             ; temporary for data gathering         
                                                             ; temporary for data gathering
                                                             ; ************************************************************************


(defvar *dfun-states* (make-hash-table :test #'eq))

(defun notice-dfun-state (generic-function state &optional nkeys valuep)
       (setf (gethash generic-function *dfun-states*)
             (cons state (when nkeys (list nkeys valuep)))))

                                                             
                                                             ; ************************************************************************
                                                             ; temporary for data gathering         
                                                             ; temporary for data gathering
                                                             ; ************************************************************************


(defvar *dfun-constructors* nil)

                                                             ; An alist in which each entry is of
                                                             ; the form (<generator> . (<subentry>
                                                             ; ...)) Each subentry is of the form:
                                                             ; (<args> <constructor> <system>) 


(defvar *enable-dfun-constructor-caching* t)

                                                             ; If this is NIL, then the whole
                                                             ; mechanism for caching dfun
                                                             ; constructors is turned off.  The only
                                                             ; time that makes sense is when
                                                             ; debugging LAP code. 


(defun show-dfun-constructors nil (format t "~&DFUN constructor caching is ~A." (if 
                                                                    *enable-dfun-constructor-caching*
                                                                                    "enabled"
                                                                                    "disabled"))
       (dolist (generator-entry *dfun-constructors*)
           (dolist (args-entry (cdr generator-entry))
               (format t "~&~S ~S" (cons (car generator-entry)
                                         (caar args-entry))
                      (caddr args-entry)))))

(defun get-dfun-constructor (generator &rest args)
       (let* ((generator-entry (assq generator *dfun-constructors*))
              (args-entry (assoc args (cdr generator-entry)
                                 :test
                                 #'equal)))
             (if (null *enable-dfun-constructor-caching*)
                 (apply (symbol-function generator)
                        args)
                 (or (cadr args-entry)
                     (let ((new (apply (symbol-function generator)
                                       args)))
                          (if generator-entry
                              (push (list (copy-list args)
                                          new nil)
                                    (cdr generator-entry))
                              (push (list generator (list (copy-list args)
                                                          new nil))
                                    *dfun-constructors*))
                          new)))))

(defun load-precompiled-dfun-constructor (generator args system constructor)
       (let* ((generator-entry (assq generator *dfun-constructors*))
              (args-entry (assoc args (cdr generator-entry)
                                 :test
                                 #'equal)))
             (unless args-entry
                 (if generator-entry
                     (push (list args constructor system)
                           (cdr generator-entry))
                     (push (list generator (list args constructor system))
                           *dfun-constructors*)))))

(defmacro
 precompile-dfun-constructors
 (&optional system)
 (let
  ((*precompiling-lap* t))
  `(progn
    ,@(gathering1 (collecting)
             (dolist (generator-entry *dfun-constructors*)
                 (dolist (args-entry (cdr generator-entry))
                     (when (or (null (caddr args-entry))
                               (eq (caddr args-entry)
                                   system))
                         (multiple-value-bind (closure-variables arguments iregs vregs tregs lap)
                             (apply (symbol-function (car generator-entry))
                                    (car args-entry))
                           (gather1 (make-top-level-form `(precompile-dfun-constructor
                                                           ,(car generator-entry))
                                           '(load)
                                           `(load-precompiled-dfun-constructor
                                             ',(car generator-entry)
                                             ',(car args-entry)
                                             ',system
                                             (precompile-lap-closure-generator ,closure-variables
                                                    ,arguments
                                                    ,iregs
                                                    ,vregs
                                                    ,tregs
                                                    ,lap))))))))))))

(defun make-initial-dfun (generic-function)
       #'(lambda (&rest args)
                (initial-dfun args generic-function)))


;;; When all the methods of a generic function are automatically generated reader or writer methods
;;; a number of special optimizations are possible. These are important because of the large number
;;; of generic functions of this type. There are a number of cases: ONE-CLASS-ACCESSOR In this case,
;;; the accessor generic function has only been called with one class of argument.  There is no
;;; cache vector, the wrapper of the one class, and the slot index are stored directly as closure
;;; variables of the discriminating function.  This case can convert to either of the next kind.
;;; TWO-CLASS-ACCESSOR Like above, but two classes.  This is common enough to do specially. There is
;;; no cache vector.  The two classes are stored a separate closure variables. ONE-INDEX-ACCESSOR In
;;; this case, the accessor generic function has seen more than one class of argument, but the index
;;; of the slot is the same for all the classes that have been seen.  A cache vector is used to
;;; store the wrappers that have been seen, the slot index is stored directly as a closure variable
;;; of the discriminating function.  This case can convert to the next kind. N-N-ACCESSOR This is
;;; the most general case.  In this case, the accessor generic function has seen more than one class
;;; of argument and more than one slot index.  A cache vector stores the wrappers and corresponding
;;; slot indexes.  Because each cache line is more than one element long, a cache lock count is
;;; used. ONE-CLASS-ACCESSOR 


(defun update-to-one-class-readers-dfun (generic-function wrapper index)
       (let ((constructor (get-dfun-constructor 'emit-one-class-reader (consp index))))
            (notice-dfun-state generic-function `(one-class readers ,(consp index)))
                                                             ; ***
            (update-dfun generic-function (funcall constructor wrapper index
                                                 #'(lambda (arg)
                                                          (declare (clos-fast-call))
                                                          (one-class-readers-miss arg 
                                                                 generic-function index wrapper))))))

(defun update-to-one-class-writers-dfun (generic-function wrapper index)
       (let ((constructor (get-dfun-constructor 'emit-one-class-writer (consp index))))
            (notice-dfun-state generic-function `(one-class writers ,(consp index)))
                                                             ; ***
            (update-dfun generic-function (funcall constructor wrapper index
                                                 #'(lambda (new-value arg)
                                                          (declare (clos-fast-call))
                                                          (one-class-writers-miss new-value arg 
                                                                 generic-function index wrapper))))))

(defun one-class-readers-miss (arg generic-function index wrapper)
       (accessor-miss generic-function 'one-class 'reader nil arg index wrapper nil nil nil))

(defun one-class-writers-miss (new arg generic-function index wrapper)
       (accessor-miss generic-function 'one-class 'writer new arg index wrapper nil nil nil))


;;; TWO-CLASS-ACCESSOR 


(defun update-to-two-class-readers-dfun (generic-function wrapper-0 wrapper-1 index)
       (let ((constructor (get-dfun-constructor 'emit-two-class-reader (consp index))))
            (notice-dfun-state generic-function `(two-class readers ,(consp index)))
                                                             ; ***
            (update-dfun generic-function (funcall constructor wrapper-0 wrapper-1 index
                                                 #'(lambda (arg)
                                                          (declare (clos-fast-call))
                                                          (two-class-readers-miss arg 
                                                                 generic-function index wrapper-0 
                                                                 wrapper-1))))))

(defun update-to-two-class-writers-dfun (generic-function wrapper-0 wrapper-1 index)
       (let ((constructor (get-dfun-constructor 'emit-two-class-writer (consp index))))
            (notice-dfun-state generic-function `(two-class writers ,(consp index)))
                                                             ; ***
            (update-dfun generic-function (funcall constructor wrapper-0 wrapper-1 index
                                                 #'(lambda (new-value arg)
                                                          (declare (clos-fast-call))
                                                          (two-class-writers-miss new-value arg 
                                                                 generic-function index wrapper-0 
                                                                 wrapper-1))))))

(defun two-class-readers-miss (arg generic-function index w0 w1)
       (accessor-miss generic-function 'two-class 'reader nil arg index w0 w1 nil nil))

(defun two-class-writers-miss (new arg generic-function index w0 w1)
       (accessor-miss generic-function 'two-class 'writer new arg index w0 w1 nil nil))


;;; std accessors same index dfun 


(defun update-to-one-index-readers-dfun (generic-function index &optional field cache)
       (unless field
           (setq field (wrapper-field 'number)))
       (let ((constructor (get-dfun-constructor 'emit-one-index-readers (consp index))))
            (multiple-value-bind (mask size)
                (compute-cache-parameters 1 nil (or cache 4))
              (unless cache
                  (setq cache (get-cache size)))
              (notice-dfun-state generic-function `(one-index readers ,(consp index)))
                                                             ; ***
              (update-dfun generic-function (funcall constructor field cache mask size index
                                                   #'(lambda (arg)
                                                            (declare (clos-fast-call))
                                                            (one-index-readers-miss arg 
                                                                   generic-function index field cache
                                                                   )))
                     cache))))

(defun update-to-one-index-writers-dfun (generic-function index &optional field cache)
       (unless field
           (setq field (wrapper-field 'number)))
       (let ((constructor (get-dfun-constructor 'emit-one-index-writers (consp index))))
            (multiple-value-bind (mask size)
                (compute-cache-parameters 1 nil (or cache 4))
              (unless cache
                  (setq cache (get-cache size)))
              (notice-dfun-state generic-function `(one-index writers ,(consp index)))
                                                             ; ***
              (update-dfun generic-function (funcall constructor field cache mask size index
                                                   #'(lambda (new-value arg)
                                                            (declare (clos-fast-call))
                                                            (one-index-writers-miss new-value arg 
                                                                   generic-function index field cache
                                                                   )))
                     cache))))

(defun one-index-readers-miss (arg gf index field cache)
       (accessor-miss gf 'one-index 'reader nil arg index nil nil field cache))

(defun one-index-writers-miss (new arg gf index field cache)
       (accessor-miss gf 'one-index 'writer new arg index nil nil field cache))

(defun one-index-limit-fn (nlines)
       (default-limit-fn nlines))

(defun update-to-n-n-readers-dfun (generic-function &optional field cache)
       (unless field
           (setq field (wrapper-field 'number)))
       (let ((constructor (get-dfun-constructor 'emit-n-n-readers)))
            (multiple-value-bind (mask size)
                (compute-cache-parameters 1 t (or cache 2))
              (unless cache
                  (setq cache (get-cache size)))
              (notice-dfun-state generic-function `(n-n readers))
                                                             ; ***
              (update-dfun generic-function (funcall constructor field cache mask size
                                                   #'(lambda (arg)
                                                            (declare (clos-fast-call))
                                                            (n-n-readers-miss arg generic-function 
                                                                   field cache)))
                     cache))))

(defun update-to-n-n-writers-dfun (generic-function &optional field cache)
       (unless field
           (setq field (wrapper-field 'number)))
       (let ((constructor (get-dfun-constructor 'emit-n-n-writers)))
            (multiple-value-bind (mask size)
                (compute-cache-parameters 1 t (or cache 2))
              (unless cache
                  (setq cache (get-cache size)))
              (notice-dfun-state generic-function `(n-n writers))
                                                             ; ***
              (update-dfun generic-function (funcall constructor field cache mask size
                                                   #'(lambda (new arg)
                                                            (declare (clos-fast-call))
                                                            (n-n-writers-miss new arg 
                                                                   generic-function field cache)))
                     cache))))

(defun n-n-readers-miss (arg gf field cache)
       (accessor-miss gf 'n-n 'reader nil arg nil nil nil field cache))

(defun n-n-writers-miss (new arg gf field cache)
       (accessor-miss gf 'n-n 'writer new arg nil nil nil field cache))

(defun n-n-accessors-limit-fn (nlines)
       (default-limit-fn nlines))


;;; 


(defun update-to-checking-dfun (generic-function function &optional field cache)
       (unless field
           (setq field (wrapper-field 'number)))
       (let* ((arg-info (gf-arg-info generic-function))
              (metatypes (arg-info-metatypes arg-info))
              (applyp (arg-info-applyp arg-info))
              (nkeys (arg-info-nkeys arg-info)))
             (if (every #'(lambda (mt)
                                 (eq mt 't))
                        metatypes)
                 (progn (notice-dfun-state generic-function `(default-method-only))
                                                             ; ***
                        (update-dfun generic-function function))
                 (multiple-value-bind (mask size)
                     (compute-cache-parameters nkeys nil (or cache 2))
                   (unless cache
                       (setq cache (get-cache size)))
                   (let ((constructor (get-dfun-constructor 'emit-checking metatypes applyp)))
                        (notice-dfun-state generic-function '(checking)
                               nkeys nil)
                                                             ; ****
                        (update-dfun generic-function
                               (funcall constructor field cache mask size function
                                      #'(lambda (&rest args)
                                               (declare (clos-fast-call))
                                               (checking-miss generic-function args function field 
                                                      cache)))
                               cache))))))

(defun checking-limit-fn (nlines)
       (default-limit-fn nlines))


;;; 


(defun update-to-caching-dfun (generic-function &optional field cache)
       (unless field
           (setq field (wrapper-field 'number)))
       (let* ((arg-info (gf-arg-info generic-function))
              (metatypes (arg-info-metatypes arg-info))
              (applyp (arg-info-applyp arg-info))
              (nkeys (arg-info-nkeys arg-info))
              (constructor (get-dfun-constructor 'emit-caching metatypes applyp)))
             (multiple-value-bind (mask size)
                 (compute-cache-parameters nkeys t (or cache 2))
               (unless cache
                   (setq cache (get-cache size)))
               (notice-dfun-state generic-function '(caching)
                      nkeys t)
                                                             ; ****
               (update-dfun generic-function (funcall constructor field cache mask size
                                                    #'(lambda (&rest args)
                                                             (declare (clos-fast-call))
                                                             (caching-miss generic-function args 
                                                                    field cache)))
                      cache))))

(defun caching-limit-fn (nlines)
       (default-limit-fn nlines))


;;; The dynamically adaptive method lookup algorithm is implemented is implemented as a kind of
;;; state machine.  The kinds of discriminating function is the state, the various kinds of reasons
;;; for a cache miss are the state transitions. The code which implements the transitions is all in
;;; the miss handlers for each kind of dfun.  Those appear here. Note that within the states that
;;; cache, there are dfun updates which simply select a new cache or cache field.  Those are not
;;; considered as state transitions. 


(defun initial-dfun (args generic-function)
       (protect-cache-miss-code generic-function args
              (multiple-value-bind (wrappers invalidp nfunction applicable)
                  (cache-miss-values generic-function args)
                (multiple-value-bind (ntype nindex)
                    (accessor-miss-values generic-function applicable args)
                  (cond ((null applicable)
                         (apply #'no-applicable-method generic-function args))
                        (invalidp (apply nfunction args))
                        ((and ntype nindex)
                         (ecase ntype
                             (reader (update-to-one-class-readers-dfun generic-function wrappers 
                                            nindex))
                             (writer (update-to-one-class-writers-dfun generic-function wrappers 
                                            nindex)))
                         (apply nfunction args))
                        (ntype (apply nfunction args))
                        (t (update-to-checking-dfun generic-function nfunction)
                           (apply nfunction args)))))))

(defun
 accessor-miss
 (gf ostate otype new object oindex ow0 ow1 field cache)
 (declare (ignore ow1))
 (let ((args (ecase otype                                    ; The congruence rules assure
                 (reader (list object))                      ; us that this is safe despite
                 (writer (list new object)))))
                                                             ; not knowing the new type yet.
      (protect-cache-miss-code
       gf args
       (multiple-value-bind (wrappers invalidp nfunction applicable)
           (cache-miss-values gf args)
         (multiple-value-bind (ntype nindex)
             (accessor-miss-values gf applicable args)
           
           ;; The following lexical functions change the state of the dfun to that which is their
           ;; name.  They accept arguments which are the parameters of the new state, and get other
           ;; information from the lexical variables bound above. 
           (flet ((two-class (index w0 w1)
                         (when (zerop (random 2))
                               (psetf w0 w1 w1 w0))
                         (ecase ntype
                             (reader (update-to-two-class-readers-dfun gf w0 w1 index))
                             (writer (update-to-two-class-writers-dfun gf w0 w1 index))))
                  (one-index (index &optional field cache)
                         (ecase ntype
                             (reader (update-to-one-index-readers-dfun gf index field cache))
                             (writer (update-to-one-index-writers-dfun gf index field cache))))
                  (n-n (&optional field cache)
                       (ecase ntype
                           (reader (update-to-n-n-readers-dfun gf field cache))
                           (writer (update-to-n-n-writers-dfun gf field cache))))
                  (checking nil (update-to-checking-dfun gf nfunction))
                  
                  ;; 
                  (do-fill (valuep limit-fn update-fn)
                         (multiple-value-bind (nfield ncache)
                             (fill-cache field cache 1 valuep limit-fn wrappers nindex)
                           (unless (and (= nfield field)
                                        (eq ncache cache))
                                  (funcall update-fn nfield ncache)))))
                 (cond ((null nfunction)
                        (apply #'no-applicable-method gf args))
                       ((null ntype)
                        (checking)
                        (apply nfunction args))
                       ((or invalidp (null nindex))
                        (apply nfunction args))
                       ((not (or (std-instance-p object)
                                 (fsc-instance-p object)))
                        (checking)
                        (apply nfunction args))
                       ((neq ntype otype)
                        (checking)
                        (apply nfunction args))
                       (t (ecase ostate
                              (one-class (if (eql nindex oindex)
                                             (two-class nindex ow0 wrappers)
                                             (n-n)))
                              (two-class (if (eql nindex oindex)
                                             (one-index nindex)
                                             (n-n)))
                              (one-index (if (eql nindex oindex)
                                             (do-fill nil #'one-index-limit-fn
                                                    #'(lambda (nfield ncache)
                                                             (one-index nindex nfield ncache)))
                                             (n-n)))
                              (n-n (unless (consp nindex)
                                       (do-fill t #'n-n-accessors-limit-fn #'n-n))))
                          (apply nfunction args)))))))))

(defun checking-miss (generic-function args ofunction field cache)
       (protect-cache-miss-code generic-function args
              (let* ((arg-info (gf-arg-info generic-function))
                     (nkeys (arg-info-nkeys arg-info)))
                    (multiple-value-bind (wrappers invalidp nfunction)
                        (cache-miss-values generic-function args)
                      (cond (invalidp (apply nfunction args))
                            ((null nfunction)
                             (apply #'no-applicable-method generic-function args))
                            ((eq ofunction nfunction)
                             (multiple-value-bind (nfield ncache)
                                 (fill-cache field cache nkeys nil #'checking-limit-fn wrappers nil)
                               (unless (and (= nfield field)
                                            (eq ncache cache))
                                      (update-to-checking-dfun generic-function nfunction nfield 
                                             ncache)))
                             (apply nfunction args))
                            (t (update-to-caching-dfun generic-function)
                               (apply nfunction args)))))))

(defun caching-miss (generic-function args ofield ocache)
       (protect-cache-miss-code generic-function args
              (let* ((arg-info (gf-arg-info generic-function))
                     (nkeys (arg-info-nkeys arg-info)))
                    (multiple-value-bind (wrappers invalidp function)
                        (cache-miss-values generic-function args)
                      (cond (invalidp (apply function args))
                            ((null function)
                             (apply #'no-applicable-method generic-function args))
                            (t (multiple-value-bind (nfield ncache)
                                   (fill-cache ofield ocache nkeys t #'caching-limit-fn wrappers 
                                          function)
                                 (unless (and (= nfield ofield)
                                              (eq ncache ocache))
                                        (update-to-caching-dfun generic-function nfield ncache)))
                               (apply function args)))))))


;;; Some useful support functions which are shared by the implementations of the different kinds of
;;; dfuns. Given a generic function and a set of arguments to that generic function, returns a mess
;;; of values. <wrappers>   Is a single wrapper if the generic function has only one key, that is
;;; arg-info-nkeys of the arg-info is 1. Otherwise a list of the wrappers of the specialized
;;; arguments to the generic function. Note that all these wrappers are valid.  This function does
;;; invalid wrapper traps when it finds an invalid wrapper and then returns the new, valid wrapper.
;;; <invalidp>   True if any of the specialized arguments had an invalid wrapper, false otherwise.
;;; <function>   The compiled effective method function for this set of arguments.  Gotten from
;;; get-secondary-dispatch-function so effective-method-function caching is in effect, and that is
;;; important since it is what keeps us in checking dfun state when possible. <type>       READER or
;;; WRITER when the only method that would be run is a standard reader or writer method.  To be
;;; specific, the value is READER when the method combination is eq to
;;; *standard-method-combination*; there are no applicable :before, :after or :around methods; and
;;; the most specific primary method is a standard reader method. <index>      If <type> is READER
;;; or WRITER, and the slot accessed is an :instance slot, this is the index number of that slot in
;;; the object argument. <applicable> Sorted list of applicable methods. 


(defun cache-miss-values (generic-function args)
       (declare (values wrappers invalidp function applicable))
       (multiple-value-bind (function appl arg-info)
           (get-secondary-dispatch-function generic-function args)
         (multiple-value-bind (wrappers invalidp)
             (get-wrappers generic-function args arg-info)
           (values wrappers invalidp (cache-miss-values-function generic-function function)
                  appl))))

(defun get-wrappers (generic-function args &optional arg-info)
       (let* ((invalidp nil)
              (wrappers nil)
              (arg-info (or arg-info (gf-arg-info generic-function)))
              (metatypes (arg-info-metatypes arg-info))
              (nkeys (arg-info-nkeys arg-info)))
             (flet ((get-valid-wrapper (x)
                           (let ((wrapper (wrapper-of x)))
                                (cond ((invalid-wrapper-p wrapper)
                                       (setq invalidp t)
                                       (check-wrapper-validity x))
                                      (t wrapper)))))
                   (setq wrappers (block collect-wrappers
                                      (gathering1 (collecting)
                                             (iterate ((arg (list-elements args))
                                                       (metatype (list-elements metatypes)))
                                                    (when (neq metatype 't)
                                                        (if (= nkeys 1)
                                                            (return-from collect-wrappers
                                                                   (get-valid-wrapper arg))
                                                            (gather1 (get-valid-wrapper arg))))))))
                   (values wrappers invalidp))))

(defun cache-miss-values-function (generic-function function)
       (if (eq *generate-random-code-segments* generic-function)
           (progn (setq *generate-random-code-segments* nil)
                  #'(lambda (&rest args)
                           (declare (ignore args))
                           nil))
           function))

(defun generate-random-code-segments (generic-function)
       (dolist (arglist (generate-arglists generic-function))
           (let ((*generate-random-code-segments* generic-function))
                (apply generic-function arglist))))

(defun generate-arglists (generic-function)
       
       ;; Generate arglists using class-prototypes and eql-specializer-objects to get all the
       ;; "different" values that could be returned by get-secondary-dispatch-function for this
       ;; generic-function. 
       (let ((methods (generic-function-methods generic-function)))
            (mapcar #'(lambda (class-list)
                             (mapcar #'(lambda (specializer)
                                              (if (eql-specializer-p specializer)
                                                  (eql-specializer-object specializer)
                                                  (class-prototype specializer)))
                                    (method-specializers (find class-list methods :test
                                                               #'(lambda (class-list method)
                                                                        (every 
                                                                               #'
                                                                 specializer-applicable-using-class-p
                                                                               (method-specializers
                                                                                method)
                                                                               class-list))))))
                   (generate-arglist-classes generic-function))))

(defun generate-arglist-classes (generic-function)
       (let ((methods (generic-function-methods generic-function)))
            (declare (ignore methods))
            
            ;; Finish this sometime.
            nil))

(defun accessor-miss-values (generic-function applicable args)
       (declare (values type index))
       (let ((type (and (eq (generic-function-method-combination generic-function)
                            *standard-method-combination*)
                        (every #'(lambda (m)
                                        (null (method-qualifiers m)))
                               applicable)
                        (let ((method (car applicable)))
                             (cond ((standard-reader-method-p method)
                                    (and (optimize-slot-value-by-class-p (class-of (car args))
                                                (accessor-method-slot-name method)
                                                nil)
                                         'reader))
                                   ((standard-writer-method-p method)
                                    (and (optimize-slot-value-by-class-p (class-of (cadr args))
                                                (accessor-method-slot-name method)
                                                t)
                                         'writer))
                                   (t nil))))))
            (values type (and type (let ((wrapper (wrapper-of (case type
                                                                  (reader (car args))
                                                                  (writer (cadr args)))))
                                         (slot-name (accessor-method-slot-name (car applicable))))
                                        (or (instance-slot-index wrapper slot-name)
                                            (assq slot-name (wrapper-class-slots wrapper))))))))