Wed Jul 8 22:41:19 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Speedup overload resolution and some other stuff for faster C++ method calling.

--- old-smoke/src/clos.lisp 2014-10-30 07:06:00.000000000 +0100

+++ new-smoke/src/clos.lisp 2014-10-30 07:06:00.000000000 +0100

@@ -117,12 +117,9 @@

(:documentation "A Smoke C++ class"))

(defclass cxx:class (smoke-standard-class)

- ((pointer :type smoke-standard-class))

+ ()

(:documentation "Metaclass to extend Smoke Objects."))

-(defmethod pointer ((class cxx:class))

- (pointer (slot-value class 'pointer)))

-

(defmethod closer-mop:validate-superclass ((class smoke-standard-class) (superclass standard-class))

T)

@@ -160,7 +157,7 @@

"The first superclass must be an subclass of an smoke class.")

(apply

#'call-next-method class

- :pointer superclass

+ :id (id superclass)

:smoke (smoke superclass)

:direct-superclasses direct-superclasses

args)))

@@ -181,7 +178,7 @@

(apply

#'call-next-method class

- :pointer superclass

+ :id (id superclass)

:smoke (smoke superclass)

:direct-superclasses direct-superclasses

args)))

@@ -206,13 +203,7 @@

:direct-superclasses

(mapcar #'smoke-class-symbol

(smoke-class-direct-superclasses class))

- :pointer

- (pointer class)

- ;(mem-aref (smoke-array-pointer

- ; (smoke-module-classes

- ; (smoke class)))

- ; 'smoke-class

- ; (id class))

+ :id (id class)

:smoke (smoke class)

:metaclass 'smoke-standard-class))

(export (lispify (name class)))))

@@ -293,7 +284,7 @@

(defun put-returnvalue (stack value type object)

(unless (void-p type)

(let ((stack (make-call-stack stack)))

- (setf (top stack) (pointer stack))

+ (setf (call-stack-top stack) (call-stack-pointer stack))

;; FIXME support user conversions.

;; We need to determine which of value and converted-value is

;; passed on the stack. E.g. converted-value can be something like

@@ -397,12 +388,12 @@

;;FIXME use CHANGE-CLASS instead?

(defun cast (object class)

"Returns a pointer of type CLASS to the C++ object of OBJECT."

+ (declare (optimize (speed 3)))

(assert (derived-p (class-of object) class)

()

"Can not cast object ~A of class ~A to class ~A."

object (name (class-of object)) (name class))

(smoke-cast (smoke-module-pointer (smoke (class-of object))) (pointer object)

- ;(id (class-of object)) (id (real-class class))))

(id (class-of object)) (id class)))

--- old-smoke/src/method.lisp 2014-10-30 07:06:00.000000000 +0100

+++ new-smoke/src/method.lisp 2014-10-30 07:06:00.000000000 +0100

@@ -65,7 +65,6 @@

:lambda-list '(object &rest args))

(export (first symbol-name) :cxx)))

-

(defun setf-method-definition (method)

`(defun (setf ,(lispify (subseq (name method) 3) :cxx)) (new-value object)

(,(lispify (name method) :cxx) object new-value)

@@ -149,8 +148,10 @@

(push export exports))))

`(progn (check-recompile ,smoke)

,@functions

- (eval-startup (:execute)

- (make-smoke-classes ,package ,smoke)

+ (eval-startup (:load-toplevel :execute)

+ ;; eval on startup for class map.

+ (make-smoke-classes ,package ,smoke))

+ (eval-when (:load-toplevel :execute)

(ensure-generic-methods ',(hash-table-alist generics)))

,@constants

(eval-when (:load-toplevel :execute)

--- old-smoke/src/objects/class.lisp 2014-10-30 07:06:00.000000000 +0100

+++ new-smoke/src/objects/class.lisp 2014-10-30 07:06:00.000000000 +0100

@@ -1,42 +1,28 @@

(in-package #:smoke)

(defclass smoke-class ()

- ;; FXIME maybe change back to id

- ((pointer ;:type foreign-pointer

- :initarg :pointer

- :reader pointer)

- (smoke :type smoke-module

- :initarg :smoke

- :reader smoke))

- (:documentation "A class"))

+ ((id :initform 0 :type smoke-index :reader id :initarg :id)

+ (smoke :type smoke-module :reader smoke :initarg :smoke)))

(defun make-smoke-class-from-id (smoke id)

- (make-instance 'smoke-class

- :pointer (mem-aref (smoke-array-pointer (smoke-module-classes

- smoke))

- 'smoke-class

- id)

- :smoke smoke))

+ (make-instance 'smoke-class :id id :smoke smoke))

-(defmethod id ((class smoke-class))

- (declare (values (smoke-index 0))

- (optimize (speed 3)))

- (values

- (floor

- (the (integer 0)

- (- (pointer-address (pointer class))

- (pointer-address (smoke-array-pointer (smoke-module-classes

- (smoke class))))))

- #.(cffi:foreign-type-size 'smoke-class))))

+

+(declaim (inline smoke-class-pointer))

+(defun smoke-class-pointer (class)

+ (mem-aref (the foreign-pointer (smoke-array-pointer (smoke-module-classes

+ (smoke class))))

+ 'smoke-class

+ (the smoke-index (id class))))

(declaim (inline class-slot-value))

(defun class-slot-value (class slot-name)

- (foreign-slot-value (pointer class)

+ (foreign-slot-value (smoke-class-pointer class)

'smoke-class slot-name))

(define-compiler-macro class-slot-value (&whole form class slot-name)

(if (constantp slot-name)

- `(foreign-slot-value (pointer ,class)

+ `(foreign-slot-value (smoke-class-pointer ,class)

'smoke-class ,slot-name)

form))

@@ -50,10 +36,8 @@

(let ((class (make-instance 'smoke-class

:smoke smoke)))

(loop for id from 1 to (smoke-array-length (smoke-module-classes smoke)) do

- (setf (slot-value class 'pointer)

- (mem-aref (smoke-array-pointer (smoke-module-classes smoke))

- 'smoke-class

- id))

+ (setf (slot-value class 'id)

+ id)

(funcall function class))))

(defun external-p (class)

@@ -100,9 +84,7 @@

:interactive read-new-value

(setf name new-name))))

(make-instance 'smoke-class

- :pointer (smoke-get-class

- (foreign-slot-value c 'smoke-module-index 'smoke)

- (foreign-slot-value c 'smoke-module-index 'index))

+ :id (foreign-slot-value c 'smoke-module-index 'index)

:smoke (gethash (pointer-address (foreign-slot-value c 'smoke-module-index 'smoke)) *smoke-modules*))))

(defun real-class (class)

--- old-smoke/src/objects/method.lisp 2014-10-30 07:06:00.000000000 +0100

+++ new-smoke/src/objects/method.lisp 2014-10-30 07:06:00.000000000 +0100

@@ -133,6 +133,7 @@

(defun return-type (method)

"Returns the return type of METHOD."

+ (declare (optimize (speed 3)))

(make-instance 'smoke-type

:id (method-slot-value method 'return-type)

:smoke (smoke-method-smoke method)))

@@ -206,7 +207,7 @@

(declare (optimize (speed 3)))

(mem-aref (smoke-module-argument-list (smoke argument))

'smoke-index

- (call-next-method)))

+ (the smoke-index (call-next-method))))

(defun last-p (argument)

"Returns T when ARGUMENT is the last argument and NIL otherwise."

--- old-smoke/src/objects/stack.lisp 2014-10-30 07:06:00.000000000 +0100

+++ new-smoke/src/objects/stack.lisp 2014-10-30 07:06:00.000000000 +0100

@@ -1,46 +1,44 @@

(in-package #:smoke)

-(defclass call-stack ()

- ((pointer :reader pointer :initarg :pointer

- :initform (null-pointer)

- :type foreign-pointer

- :documentation "Pointer to the Smoke stack")

- (top :accessor top :initarg :top

- :initform (null-pointer)

- :type foreign-pointer

- :documentation "Pointer to push the next argument to."))

- (:documentation "Contains the argument passed to a Smoke method."))

+(declaim (inline %make-call-stack))

+(defstruct (call-stack (:constructor %make-call-stack))

+ (pointer (null-pointer) :type foreign-pointer)

+ (top (null-pointer) :type foreign-pointer))

(defgeneric size (object))

(defmethod size ((stack call-stack))

"Returns the size (number of arguments) of STACK."

(/

- (- (pointer-address (top stack))

- (pointer-address (pointer stack)))

+ (- (pointer-address (call-stack-top stack))

+ (pointer-address (call-stack-pointer stack)))

(foreign-type-size 'smoke-stack-item)))

(defun make-call-stack (smoke-stack)

- (declare (optimize (speed 3)))

- (make-instance 'call-stack

- :pointer smoke-stack

- :top (inc-pointer smoke-stack (foreign-type-size 'smoke-stack-item))))

+ (declare (type foreign-pointer smoke-stack)

+ (optimize (speed 3)))

+ (%make-call-stack

+ :pointer smoke-stack

+ :top (inc-pointer smoke-stack

+ #.(foreign-type-size 'smoke-stack-item))))

(defun push-stack (stack value type)

- (setf (foreign-slot-value (top stack)

+ (setf (foreign-slot-value (call-stack-top stack)

'smoke-stack-item type) value)

- (incf-pointer (top stack) #.(foreign-type-size 'smoke-stack-item)))

+ (incf-pointer (call-stack-top stack) #.(foreign-type-size 'smoke-stack-item)))

(define-compiler-macro push-stack (&whole form stack value type)

(if (constantp type)

`(progn

- (setf (foreign-slot-value (top ,stack)

+ (setf (foreign-slot-value (call-stack-top ,stack)

'smoke-stack-item ,type) ,value)

- (incf-pointer (top ,stack) ,(foreign-type-size 'smoke-stack-item)))

+ (incf-pointer (call-stack-top ,stack)

+ ,(foreign-type-size 'smoke-stack-item)))

form))

(defclass smoke-standard-object ()

((pointer :reader pointer

+ :type foreign-pointer

:initarg :pointer

:documentation "Pointer to the C++ object.")

#+clisp (finalizer :type list :initform (list nil))

--- old-smoke/src/objects/type.lisp 2014-10-30 07:06:00.000000000 +0100

+++ new-smoke/src/objects/type.lisp 2014-10-30 07:06:00.000000000 +0100

@@ -120,10 +120,11 @@

;; For efficiency just check if the first byte is a null byte;

;; No need to convert the entire C string to lisp like in:

;; (null (name type)))

+ (declare (optimize (speed 3)))

(= 0 (mem-ref (mem-aref (smoke-array-pointer

(smoke-module-types (smoke type)))

'smoke-type

- (id type))

+ (the smoke-index (id type)))

:char)))

--- old-smoke/src/overload-resolution.lisp 2014-10-30 07:06:00.000000000 +0100

+++ new-smoke/src/overload-resolution.lisp 2014-10-30 07:06:00.000000000 +0100

@@ -76,6 +76,8 @@

(cstring-cmp (smoke-method-name method)

name))))

+;;; INLINE OPTIMIZE

+(declaim (inline first-unabigious-index))

(defun first-unabigious-index (smoke index)

(declare (type smoke-index index)

(optimize (speed 3)))

@@ -94,7 +96,8 @@

(class-id (id class))

(smoke (smoke class))

(end (1+ (smoke-array-length (smoke-module-method-maps smoke)))))

- (declare (type (smoke-index 0) start end))

+ (declare (type (smoke-index 0) start end)

+ (dynamic-extent start))

(loop until (> start end) do

(let* ((index (the smoke-index (floor (+ end start) 2)))

(method (make-smoke-method

@@ -111,7 +114,7 @@

'method)))))

(cmp (the (integer -1 1) (method-cmp method class-id name))))

(declare (type (integer -1 1) cmp)

- (dynamic-extent method index cmp))

+ (dynamic-extent method))

(ecase cmp

(-1 (setf start (1+ index)))

(0 (return-from find-method-for-class index))

@@ -190,50 +193,26 @@

(defconstant +promotion+ 1)

(defconstant +conversion+ 2))

-(defclass std-conversion ()

- ((function-name :accessor conversion-function-name

- :initarg :conversion-function-name))

- (:documentation "A conversion"))

-

-(defclass exact-match (std-conversion)

- ((rank :reader rank

- :allocation :class

- :type fixnum

- :initform +exact-match+)))

-

-(defclass promotion (std-conversion)

- ((rank :reader rank

- :allocation :class

- :type fixnum

- :initform +promotion+)))

-

-(defclass number-conversion (std-conversion)

- ((rank :reader rank

- :allocation :class

- :type fixnum

- :initform +conversion+)))

-

-(defclass pointer-conversion (std-conversion)

- ((rank :reader rank

- :allocation :class

- :type fixnum

- :initform (1+ +conversion+))

- (from :reader from

- :initarg :from)

- (to :reader to

- :initarg :to)))

-

-(defclass boolean-conversion (std-conversion)

- ((rank :reader rank

- :allocation :class

- :type fixnum

- :initform (+ 2 +conversion+))))

-

-(defclass user-conversion (std-conversion)

- ((rank :reader rank

- :allocation :class

- :type fixnum

- :initform (+ 3 +conversion+))))

+(declaim (inline make-conversion make-exact-match make-promotion

+ make-number-conversion make-pointer-conversion

+ make-boolean-conversion make-user-conversion))

+(defstruct conversion

+ (function-name nil :type (or symbol function) :read-only t)

+ (rank -1 :type fixnum :read-only t))

+

+(defstruct (exact-match (:include conversion (rank +exact-match+))))

+

+(defstruct (promotion (:include conversion (rank +promotion+))))

+

+(defstruct (number-conversion (:include conversion (rank +conversion+))))

+

+(defstruct (pointer-conversion (:include conversion (rank (1+ +conversion+))))

+ (from (find-class t) :type class :read-only t)

+ (to (find-class t) :type class :read-only t))

+

+(defstruct (boolean-conversion (:include conversion (rank (+ 2 +conversion+)))))

+

+(defstruct (user-conversion (:include conversion (rank (+ 3 +conversion+)))))

(defgeneric conversion< (conversion1 conversion2)

(:documentation

@@ -243,16 +222,20 @@

(:method (conversion1 conversion2)

(declare (optimize (speed 3)))

(or (null conversion2)

- (< (the fixnum (rank conversion1))

- (the fixnum (rank conversion2)))))

+ (< (the fixnum (conversion-rank conversion1))

+ (the fixnum (conversion-rank conversion2)))))

(:method ((conversion1 pointer-conversion) (conversion2 pointer-conversion))

(declare (optimize (speed 3)))

- (if (eq (from conversion1) (from conversion2))

+ (if (eq (pointer-conversion-from conversion1)

+ (pointer-conversion-from conversion2))

;; A->B < A->C <=> B subclass of C

- (subtypep (to conversion1) (to conversion2))

- (if (eq (to conversion1) (to conversion2))

+ (subtypep (pointer-conversion-to conversion1)

+ (pointer-conversion-to conversion2))

+ (if (eq (pointer-conversion-to conversion1)

+ (pointer-conversion-to conversion2))

;; B->A < C->A <=> B subclass of C

- (subtypep (from conversion1) (from conversion2))

+ (subtypep (pointer-conversion-from conversion1)

+ (pointer-conversion-from conversion2))

nil))))

(defgeneric conversion= (conversion1 conversion2)

@@ -260,7 +243,7 @@

"Returns true when the standard conversion sequence CONVERSION1

is indistinguishable from CONVERSION2.")

(:method (conversion1 conversion2)

- (= (rank conversion1) (rank conversion2)))

+ (= (conversion-rank conversion1) (conversion-rank conversion2)))

(:method ((conversion1 (eql nil)) (conversion2 (eql nil)))

t)

(:method ((conversion1 pointer-conversion) (conversion2 pointer-conversion))

@@ -291,9 +274,8 @@

(defmacro make-match (type &optional (name ''identity)

(argument nil)

&rest args)

- `(make-instance ,type

- :conversion-function-name ,(conversion-function name argument)

-

+ `(,(symbolicate 'make- (eval type))

+ :function-name ,(conversion-function name argument)

,@args))

(defun+using-type get-conversion-sequence object (object type &optional user)

--- old-smoke/src/sb-optimize.lisp 2014-10-30 07:06:00.000000000 +0100

+++ new-smoke/src/sb-optimize.lisp 2014-10-30 07:06:00.000000000 +0100

@@ -81,10 +81,12 @@

sequence args)))

`(lambda (object ,@argument-names)

(s-call ,(method-form method)

- ;; FIXME only cast when needed.

- (cast object

- (find-class (quote ,(class-name

- (find-smoke-class

- (get-class 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)))))))))))

--- old-smoke/src/smoke.lisp 2014-10-30 07:06:00.000000000 +0100

+++ new-smoke/src/smoke.lisp 2014-10-30 07:06:00.000000000 +0100

@@ -30,7 +30,7 @@

(declaim (inline call-s-method))

(defun call-s-method (method object-pointer stack-pointer)

(foreign-funcall-pointer

- (foreign-slot-value (pointer (get-class method))

+ (foreign-slot-value (smoke-class-pointer (get-class method))

'smoke-class

'class-function)

()

@@ -43,13 +43,13 @@

(defun s-call (method object-pointer &optional (args nil))

(with-stack (stack args (arguments method) )

- (call-s-method method object-pointer (pointer stack))

- (type-to-lisp (pointer stack) (return-type method))))

+ (call-s-method method object-pointer (call-stack-pointer stack))

+ (type-to-lisp (call-stack-pointer stack) (return-type method))))

(defun pointer-call (method object-pointer &optional (args nil))

(with-stack (stack args (arguments method) )

- (call-s-method method object-pointer (pointer stack))

- (foreign-slot-value (pointer stack) 'smoke-stack-item 'class)))

+ (call-s-method method object-pointer (call-stack-pointer stack))

+ (foreign-slot-value (call-stack-pointer stack) 'smoke-stack-item 'class)))

(defun smoke-call (class pointer method-name &optional (args nil))

@@ -73,8 +73,8 @@

;;

(assert (enum-p method))

(with-stack (stack nil nil)

- (call-s-method method (null-pointer) (pointer stack))

- (foreign-slot-value (pointer stack) 'smoke-stack-item 'long)))

+ (call-s-method method (null-pointer) (call-stack-pointer stack))

+ (foreign-slot-value (call-stack-pointer stack) 'smoke-stack-item 'long)))

(defun delete-pointer (pointer class)

"Destructs the object at POINTER of type CLASS.

@@ -104,7 +104,7 @@

'voidp)

(smoke-module-binding (smoke (class-of object))))

(foreign-funcall-pointer

- (foreign-slot-value (pointer (class-of object))

+ (foreign-slot-value (smoke-class-pointer (class-of object))

'smoke-class

'class-function)

()