(in-package :smoke)

(declaim (optimize (debug 3)))

(defmacro catch-try ((tag &optional catch-result) catch-form &body body)
  "Catch TAG in the BODY forms. When TAG is throw CATCH-RESULT is bound
to the thrown values and result of CATCH-FORM is returned. Otherwise
the result of BODY is returned and CATCH-FORM is not evaluated."
  (flet ((catch-block (tag return-block body)
           `(catch ,tag
              (return-from ,return-block
                ,@body))))
    (let ((return-block (gensym)))
      `(block ,return-block 
         ,(if catch-result
              `(let ((,catch-result ,(catch-block tag return-block body)))
                 ,catch-form)
              `(progn ,(catch-block tag return-block body)
                     ,catch-form))))))

(defun type-specifier (lvar)
  (let ((type (sb-kernel:type-specifier (sb-c::lvar-type lvar))))
    (if (subtypep type 'smoke-standard-object)
        (find-class type)
        type)))
      

(defun give-up-transform (&rest args)
  (apply #'sb-c::give-up-ir1-transform args))

(defmacro define-transform (name lambda-list &body body)
  `(sb-c:deftransform ,name (,lambda-list)
     ,@body))

(defmacro define-known (name)
  `(sb-c:defknown ,name * *))

(defun method-form (method)
  `(make-smoke-method
    :id ,(id method)
    :smoke (eval ,(get-smoke-variable-for-pointer
                   (smoke method)))))
                                   
(defun sequence-form (sequence arguments)
  (mapcar #'(lambda (sequence argument)
              (if (symbolp sequence)
                  `(,sequence ,argument)
                  `(,(first sequence) ,argument ,@(rest sequence))))
          sequence arguments))


(defmacro define-resolve-at-compile-time (gf-name)
  `(eval-when (:compile-toplevel :load-toplevel :execute)
     (define-known ,gf-name)
     (sb-c:defoptimizer (,gf-name derive-type) ((object &rest args))
       (catch-try ('unspecific-type) sb-c::*wild-type*
         (let ((method (find-best-viable-function-using-types
                        ,(name (fdefinition gf-name))
                        (mapcar #'type-specifier args) (type-specifier object))))
           (if (and method (class-p (return-type method)))
               (sb-kernel:single-value-specifier-type
                (find-smoke-class (get-class (return-type method))))
               sb-c::*wild-type*))))
     (define-transform ,gf-name (object &rest args)
       (when (null args)
         (give-up-transform "No arguments."))
       (catch-try ('unspecific-type reason)
           (give-up-transform "Could not resolve overload at compile time: ~A" reason)
         (multiple-value-bind (method sequence)
             (find-best-viable-function-using-types
              ,(name (fdefinition gf-name))
              (mapcar #'type-specifier args)
              (type-specifier object))
           (let ((argument-names (make-gensym-list (length args))))
             (when (null method)
               (give-up-transform "No applicable method."))
             (if (static-p method)
                 `(s-call ,(method-form method)
                          (null-pointer)
                          (list ,@(sequence-form
                                   sequence args)))
                 `(lambda (object ,@argument-names)
                    (s-call ,(method-form method)
                            ,(if (eql (type-specifier object)
                                      (find-smoke-class (get-class method)))
                                 `(pointer object)
                                 `(cast object
                                        (find-class (quote ,(class-name 
                                                             (find-smoke-class
                                                              (get-class method)))))))
                            (list ,@(sequence-form
                                     sequence argument-names)))))))))))


;;; Cache overload resolution / method lookup

;;; FIXME the cached lookup should be faster
;;;
;;; cache return value conversion
;;;
;;; Using the gf symbol instead of the method name would be better,
;;; althoug we would have to invent one for constructors.
;;;
;;; Since the -using-types stuff was intended for for compile time
;;; expansion it is not that well suited for this. i.e. passing
;;; closures would be better than the actual syntax.
;;;
;;; For qt.tests the uncached calls make up 30 % of all calls.
;;; qt.examples:colliding-mice (run for ~1 min) gets 20 % uncached
;;; calls and qt.examples:class-browser get 10 %. (20 February 2010)

(sb-int:defun-cached (find-best-viable-function-using-layouts-cached
                      :hash-function (lambda (name arguments
                                              class const-p)
                                       (declare (string name)
                                                (list arguments)
                                                (sb-c::layout class)
                                                (boolean const-p))
                                       (logand 
                                        (logxor
                                         (sxhash name)
                                         (the fixnum
                                           (reduce 
                                            #'logxor
                                            (mapcar #'sb-c::layout-clos-hash
                                                    arguments)))
                                         (sxhash class)
                                         (sxhash const-p))
                                        #x1FF))
                      :hash-bits 9)
    ((name equal) (arguments equal) (class eq) (const-p eq))
  (declare (optimize (speed 3))
           (inline find-best-viable-function-using-types))
  (multiple-value-bind (method conversion-sequence)
      (find-best-viable-function-using-types
       name (mapcar #'sb-pcl::wrapper-class* arguments)
       class const-p)
    (list method (mapcar #'(lambda (s)
                             (if (symbolp s)
                                 (fdefinition s)
                                 #'(lambda (x)
                                     (declare (optimize (speed 3)))
                                     (funcall (fdefinition (first s))
                                              x
                                              (eval (second s))))))
                         conversion-sequence))))

(declaim (inline find-best-viable-function-cached))
(defun find-best-viable-function-cached (name arguments class const-p)
  (declare (optimize (speed 3)))
  (catch 'unspecific-type
    (return-from find-best-viable-function-cached
      (values-list
       (find-best-viable-function-using-layouts-cached
        name
        (mapcar #'(lambda (o) (sb-c::layout-of o)) arguments)
        class
        const-p))))
  (find-best-viable-function name arguments class const-p))