Wed Jul 8 16:56:52 CEST 2009 Tobias Rautenkranz * SBCL: compile time overload resolution diff -rN -u old-smoke/smoke.mbd new-smoke/smoke.mbd --- old-smoke/smoke.mbd 2014-10-30 08:13:12.000000000 +0100 +++ new-smoke/smoke.mbd 2014-10-30 08:13:12.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 08:13:12.000000000 +0100 +++ new-smoke/src/overload-resolution.lisp 2014-10-30 08:13:12.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 08:13:12.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 08:13:12.000000000 +0100 +++ new-smoke/src/using-type.lisp 2014-10-30 08:13:12.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)