Wed Jul 8 16:56:52 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* SBCL: compile time overload resolution
diff -rN -u old-smoke/smoke.mbd new-smoke/smoke.mbd
--- old-smoke/smoke.mbd 2014-10-30 07:06:02.000000000 +0100
+++ new-smoke/smoke.mbd 2014-10-30 07:06:02.000000000 +0100
@@ -35,6 +35,7 @@
("translate" (:needs "package"))
("using-type" (:needs "package"))
("overload-resolution" (:needs "package" "smoke" "using-type"))
+ ("sb-optimize" (:for :sbcl) (:needs "overload-resolution"))
("smoke" (:needs "smoke-c" "objects" "clos"))
("object-map" (:needs "objects" :utils))
("class-map" (:needs "package"))
diff -rN -u old-smoke/src/overload-resolution.lisp new-smoke/src/overload-resolution.lisp
--- old-smoke/src/overload-resolution.lisp 2014-10-30 07:06:02.000000000 +0100
+++ new-smoke/src/overload-resolution.lisp 2014-10-30 07:06:02.000000000 +0100
@@ -299,15 +299,14 @@
(defun+using-type get-conversion-sequence object (object type &optional user)
"Retrains a conversion sequence to convert a instance of type CLASS
to an instance of type TYPE. When USER is true user conversions are considered."
- (if-let
- (match (call-using-type exact-match object type))
- (if (eql t match)
- (make-match 'exact-match)
- (make-match 'exact-match match))
- (or (call-using-type promotion object type)
- (call-using-type conversion object type)
- (and user
- (call-using-type user-conversion object type)))))
+ (if-let (match (call-using-type exact-match object type))
+ (if (eql t match)
+ (make-match 'exact-match)
+ (make-match 'exact-match match))
+ (or (call-using-type promotion object type)
+ (call-using-type conversion object type)
+ (and user
+ (call-using-type user-conversion object type)))))
(defun+using-types standard-conversion-sequence (method classes &optional user)
"Returns the conversion sequences to convert the arguments of types CLASSES
diff -rN -u old-smoke/src/sb-optimize.lisp new-smoke/src/sb-optimize.lisp
--- old-smoke/src/sb-optimize.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-smoke/src/sb-optimize.lisp 2014-10-30 07:06:02.000000000 +0100
@@ -0,0 +1,90 @@
+(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)
+ ;; FIXME only cast when needed.
+ (cast object
+ (find-class (quote ,(class-name
+ (find-smoke-class
+ (get-class method))))))
+ (list ,@(sequence-form
+ sequence argument-names)))))))))))
diff -rN -u old-smoke/src/using-type.lisp new-smoke/src/using-type.lisp
--- old-smoke/src/using-type.lisp 2014-10-30 07:06:02.000000000 +0100
+++ new-smoke/src/using-type.lisp 2014-10-30 07:06:02.000000000 +0100
@@ -17,8 +17,7 @@
(defun typep-using-type (object-type type)
"Returns true when OBJECT-TYPE is a subtype of TYPE,
-false when it is not; and :MAYBE when the relationship
-could not be determined."
+false when it is not."
(declare (values (member t nil :maybe)))
(multiple-value-bind (subtype-p valid-p)
(subtypep object-type type)
@@ -30,7 +29,10 @@
(if subtype-p
(throw 'unspecific-type (values object-type type))
(if valid-p
- nil
+ (if (and (subtypep type 'integer)
+ (not (integer-types-disjunct-p object-type type)))
+ (throw 'unspecific-type (values object-type type))
+ nil)
(throw 'unspecific-type (values object-type type)))))
(throw 'unspecific-type (values object-type))))))
@@ -57,7 +59,6 @@
(with-object-as-object ,object
(defun ,name ,lambda-list
,@body))
- #+nil
(with-object-as-type ,object
(defun ,(symbolicate name '-using-type) ,lambda-list
,@body))))
@@ -72,7 +73,6 @@
`(function ,name)))
(defun ,name ,lambda-list
,@body))
- #+nil
(macrolet ((call-using-types (function-name &rest args)
`(,(symbolicate function-name '-using-types)
,@args))
@@ -84,3 +84,8 @@
`(function ,(symbolicate name '-using-types))))
(defun ,(symbolicate name '-using-types) ,lambda-list
,@body))))
+
+(defun integer-types-disjunct-p (type1 type2)
+ ;; FIXME implement this
+ (declare (ignore type1 type2))
+ nil)