Mon May 25 20:39:33 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* speed up get-struct-slot-value & cleanup

--- old-smoke/src/clos.lisp 2014-09-30 10:28:33.000000000 +0200

+++ new-smoke/src/clos.lisp 2014-09-30 10:28:34.000000000 +0200

@@ -358,11 +358,6 @@

(defmethod convert-to-class (smoke-class (object smoke-standard-object))

(cast object smoke-class))

-(defun make-smoke-constructor (class args)

- (find-method-using-args class

- (name class)

- args))

-

(defun call-constructor (object arguments)

(if (null arguments)

(let ((method (find-smoke-method (class-of object)

--- old-smoke/src/marshall.lisp 2014-09-30 10:28:33.000000000 +0200

+++ new-smoke/src/marshall.lisp 1970-01-01 01:00:00.000000000 +0100

@@ -1,152 +0,0 @@

-(in-package :smoke)

-

-(declaim (optimize (debug 3)))

-

-(defmacro average (&rest args)

- `(floor (+ ,@args) ,(length args)))

-

-

-(defun binary-find (lower upper < =)

- (let ((mid (average lower upper)))

- (if (= mid lower)

- nil

- (if (funcall = mid)

- mid

- (if (funcall < mid)

- (binary-find lower mid < =)

- (binary-find mid upper < =))))))

-

-(defun serach-method (smoke name)

- (binary-find 1 (smoke-method-name-size smoke)

- #'(lambda (index)

- (string< name

- (smoke-get-method-name smoke index)))

- #'(lambda (index)

- (string= name

- (smoke-get-method-name smoke index)))))

-

-(defun find-last (lower upper =)

- (if (or (>= lower upper)

- (not (funcall = (1+ lower))))

- lower

- (find-last (1+ lower) upper =)))

-

-

-(defun find-methods (smoke name)

- (let* ((index (serach-method smoke name))

- (= #'(lambda (index)

- (string= name

- (smoke-get-method-name smoke index)

- :end2 (length name))))

- (upper (find-last index (smoke-method-name-size smoke) =))

- (methods nil))

- (loop for i from index to upper do

- (push (smoke-get-method-name smoke i)

- methods))

- methods))

-

-

-

-;(defmethod exact-match ((object singl-float) type))

-(defun type-equal (type type-name)

- (equal (name type) type-name))

-

-(defun exact-match (object type)

- (format t "~A ~A~%" object (name type))

- (ctypecase object

- (smoke-standard-object

- (and (class-p type)

- (derived-p (class-of object)

- (get-class type))))

- (double-float (type-equal type "double"))

- (single-float (type-equal type "float"))

- (integer (type-equal type "int"))

- (string (or (type-equal type "const char*")

- (type-equal type "const QString&")))

- (character (type-equal type "char"))))

-

-(defun exact-match-p (arguments types)

- (if (or (null arguments) (null types))

- (and (null arguments)

- (null types))

- (if (not (exact-match (first arguments)

- (first types)))

- nil

- (exact-match-p (rest arguments)

- (rest types)))))

-

-(defun promotion-match (object type)

- (ctypecase object

- (character (type-equal type "int"))

- (float (type-equal type "double"))

- (boolean (type-equal type "int"))))

-

-(defun standard-conversion-match (object type)

- (ctypecase object

- (number (or (type-equal type "short")

- (type-equal type "int")

- (type-equal type "long")))))

-

-(defun constructor-match (object type)

- (if (class-p type)

- (let ((constructor (make-smoke-constructor (get-class type)

- (mung-arg object))))

- (exact-match object (get-first-argument constructor)))

- nil))

-

-(defun find-ambiguous-method (predicate method)

- (let ((index (- (id method))))

- (loop as i = (smoke-ambiguous-method (smoke method)

- index)

- while (> i 0) do

- (incf index)

- (let ((ambiguous-method (make-instance 'smoke-method

- :smoke (smoke method)

- :id i)))

- (when (funcall predicate ambiguous-method)

- (return ambiguous-method))))))

-

-(defun find-method-using-args (class name arguments)

- (with-foreign-object (m 'smoke-module-index)

- (smoke-find-method m (smoke class) (id class)

- (concatenate 'string name

- (munged-args arguments)))

- (let ((method (make-instance 'smoke-method

- :smoke (foreign-slot-value m

- 'smoke-module-index

- 'smoke)

- :id (foreign-slot-value m

- 'smoke-module-index

- 'index))))

- (when (< (id method) 0)

- (setf method

- (find-ambiguous-method #'(lambda (method)

- (exact-match-p arguments (arguments method)))

- method))

- (assert (not (null method)) (method)

- "No method ~A::~A for the arguments ~A"

- (name class) name arguments))

- method)))

-

-

-(defgeneric get-convert-function (to from))

-(defmethod get-convert-function ((to eql 'int) (from eql 'char)))

-(defmethod get-convert-function ((to cxx::int) (from string)))

-

-(get-convert-function 'int 'char)

-

-;'const int 'char:

-(get-convert-function 'int 'char)

-&& (convert-const-p 'char)

-

-;'int 'const char:

-(get-convert-function 'int 'char)

-&& (not (const-p 'char))

-

-

-(defclass int ()

- ((const-p)))

-

-(defun get-convert-function (to from))

-

-

--- old-smoke/src/objects/method.lisp 2014-09-30 10:28:33.000000000 +0200

+++ new-smoke/src/objects/method.lisp 2014-09-30 10:28:34.000000000 +0200

@@ -76,114 +76,6 @@

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

:smoke (foreign-slot-value m 'smoke-module-index 'smoke))))

-(defun type-equal (type type-name)

- "Returns true when TYPE is of the type named TYPE-NAME and false otherwise."

- (equal (name type) type-name))

-

-(defun exact-match (object type)

- "Returns true when the type of OBJECT is exactly the same as TYPE and

-false otherwise."

- (ctypecase object

- (smoke-standard-object

- (and (class-p type)

- (derived-p (class-of object)

- (get-class type))))

- (double-float (type-equal type "double"))

- (single-float (type-equal type "float"))

- (integer (type-equal type "int"))

- ;; int is also enum

- ;; FIXME remove magic number 12

- ;;(= (type-id type) 12)))

- (string (or (type-equal type "const char*")

- (type-equal type "const QString&")))

- (enum (smoke-type= (enum-type object)

- type))

- (sequence (type-equal type "const QStringList&"))

- (character (type-equal type "char"))))

-

-(defun exact-match-p (arguments types)

- "Returns true when all the type of ARGUMENTS is the same as the

-corresponing type of TYPES and the length of the ARGUMENTS and TYPES list

-is equal."

- (if (or (null arguments) (null types))

- (and (null arguments)

- (null types))

- (if (not (exact-match (first arguments)

- (first types)))

- nil

- (exact-match-p (rest arguments)

- (rest types)))))

-

-(defun mung-arg (argument)

- "Returns the mung char for ARUGMENT."

- ;; FIXME void* is #\$ but void[] is #\?

- ;; FIXME Get rid of the mugging stuff and compute the applicable methods

- ;; including argument promotion

- (case argument

- ((t nil) #\$) ;; Booleans

- (otherwise

- (ctypecase argument

- (number #\$)

- (character #\$)

- (string #\$)

- (foreign-pointer #\?)

- (sequence #\?)

- (enum #\$)

- (smoke-standard-object #\#)))))

-

-(defun munged-args (arguments &optional (string nil))

- "Maps the type of every item of ARGUMENTS to a char;

-Returns the list of the chars."

- (if (null arguments)

- string

- (munged-args (rest arguments)

- (append string (list (mung-arg (first arguments)))))))

-

-(defun find-ambiguous-method (predicate method)

- "Returns a method of the ambiguous method METHOD such that

-PREDICATE is true. NIL is returned when no matching method is found."

- (assert (ambiguous-p method)

- (method)

- "The method is not ambiguous.")

- (let ((index (- (id method))))

- (loop as i = (smoke-ambiguous-method (smoke method)

- index)

- while (> i 0) do

- (incf index)

- (let ((ambiguous-method (make-instance 'smoke-method

- :smoke (smoke method)

- :id i)))

- (when (funcall predicate ambiguous-method)

- (return ambiguous-method))))))

-

-(defun find-method-using-args (class name arguments)

- "Returns the method of class CLASS with the name NAME

-for the arguments ARGUMENTS."

- (with-foreign-object (m 'smoke-module-index)

- (smoke-find-method m (smoke class) (id class)

- (concatenate 'string name

- (munged-args arguments)))

- (let ((method (make-instance 'smoke-method

- :smoke (foreign-slot-value m

- 'smoke-module-index

- 'smoke)

- :id (foreign-slot-value m

- 'smoke-module-index

- 'index))))

- (assert (valid-p method)

- (method)

- "No method ~A::~A for the arguments ~A" (name class) name arguments)

- (when (ambiguous-p method)

- (setf method

- (find-ambiguous-method #'(lambda (method)

- (exact-match-p arguments (arguments method)))

- method))

- (assert (not (null method)) (method)

- "No method ~A::~A for the arguments ~A"

- (name class) name arguments))

- method)))

-

-

(defun map-methods (function smoke)

"Applys FUNCTION to the methods of SMOKE.

The method argument to function must not be modified."

@@ -198,13 +90,16 @@

(setf (slot-value method 'id) id)

(funcall function method))))

-(defmethod get-struct-slot-value ((method smoke-method) slot-name)

+(defun method-slot-value (method slot-name)

+ (declare (smoke-method method)

+ (symbol slot-name)

+ (optimize (speed 3)))

(foreign-slot-value (smoke-get-method (smoke method) (id method))

'smoke-method slot-name))

(defmethod name ((method smoke-method))

(smoke-get-method-name (smoke method)

- (get-struct-slot-value method 'name)))

+ (method-slot-value method 'name)))

(defun signature (method)

"Returns the signature of METHOD."

@@ -226,7 +121,7 @@

(defun return-type (method)

"Returns the return type of METHOD."

(make-instance 'smoke-type

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

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

:smoke (smoke method)))

(defun method-declaration (method)

@@ -240,7 +135,7 @@

(:documentation "Returns the value for FLAG of OBJECT."))

(defmethod get-flag ((method smoke-method) flag)

- (logand (get-struct-slot-value method 'flags)

+ (logand (method-slot-value method 'flags)

(foreign-enum-value 'smoke-method-flags flag)))

(defgeneric constructor-p (object)

@@ -279,7 +174,7 @@

(defmethod get-class ((method smoke-method))

(make-instance 'smoke-class

- :id (get-struct-slot-value method 'class)

+ :id (method-slot-value method 'class)

:smoke (smoke method)))

@@ -310,18 +205,18 @@

(defun get-arguments-length (method)

"Returns the number of arguments for METHOD."

- (get-struct-slot-value method 'num-args))

+ (method-slot-value method 'num-args))

(defun get-first-argument (method)

"Returns the first argument of METHOD"

(make-instance 'smoke-argument

- :id (get-struct-slot-value method 'arguments)

+ :id (method-slot-value method 'arguments)

:smoke (smoke method)))

(defun get-argument (method index)

"Returns the type of METHODs argument with number INDEX."

(make-instance 'smoke-argument

- :id (+ (get-struct-slot-value method 'arguments) index)

+ :id (+ (method-slot-value method 'arguments) index)

:smoke (smoke method)))

--- old-smoke/src/objects/type.lisp 2014-09-30 10:28:33.000000000 +0200

+++ new-smoke/src/objects/type.lisp 2014-09-30 10:28:34.000000000 +0200

@@ -13,7 +13,10 @@

(defmethod smoke::smoke ((type smoke-lazy-type))

(eval (smoke-symbol type)))

-(defmethod get-struct-slot-value ((type smoke-type) slot-name)

+(defun type-slot-value (type slot-name)

+ (declare (smoke-type type)

+ (symbol slot-name)

+ (optimize (speed 3)))

(foreign-slot-value (smoke-get-type (smoke type) (id type))

'smoke-type slot-name))

@@ -24,7 +27,7 @@

:smoke smoke))

(defmethod name ((type smoke-type))

- (get-struct-slot-value type 'name))

+ (type-slot-value type 'name))

(defun smoke-type= (type1 type2)

(and t ;(pointer-eq (smoke type1)

@@ -33,12 +36,12 @@

(id type2))))

(defmethod get-flag ((type smoke-type) flag)

- (logand (get-struct-slot-value type 'flags)

+ (logand (type-slot-value type 'flags)

#xF0 ;; = ! 0x0F

(foreign-enum-value 'smoke-type-flags flag)))

(defun get-allocation-flag (type)

- (logand (get-struct-slot-value type 'flags)

+ (logand (type-slot-value type 'flags)

#x30))

(defun stack-p (type)

@@ -60,11 +63,11 @@

(defun class-p (type)

"Returns T when TYPE is a smoke class"

(and (eql (type-id type) 13)

- (/= -1 (get-struct-slot-value type 'class))))

+ (/= -1 (type-slot-value type 'class))))

(defun type-id (type)

"Returns the ID of TYPE."

- (logand (get-struct-slot-value type 'flags)

+ (logand (type-slot-value type 'flags)

(foreign-enum-value 'smoke-type-flags :type-id)))

(defun void-p (type)

@@ -76,11 +79,11 @@

(defmethod get-class ((type smoke-type))

"Return the smoke-class of TYPE."

- (assert (/= -1 (get-struct-slot-value type 'class))

+ (assert (/= -1 (type-slot-value type 'class))

(type)

"The type ~S is not a smoke class." (name type))

(make-instance 'smoke-class

- :id (get-struct-slot-value type 'class)

+ :id (type-slot-value type 'class)

:smoke (smoke type)))