Wed Jul 8 16:56:52 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* SBCL: compile time overload resolution
hunk ./smoke.mbd 38
+ ("sb-optimize" (:for :sbcl) (:needs "overload-resolution"))
hunk ./src/overload-resolution.lisp 302
- (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)))))
addfile ./src/sb-optimize.lisp
hunk ./src/sb-optimize.lisp 1
+(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)))))))))))
hunk ./src/using-type.lisp 20
-false when it is not; and :MAYBE when the relationship
-could not be determined."
+false when it is not."
hunk ./src/using-type.lisp 32
- nil
+ (if (and (subtypep type 'integer)
+ (not (integer-types-disjunct-p object-type type)))
+ (throw 'unspecific-type (values object-type type))
+ nil)
hunk ./src/using-type.lisp 62
- #+nil [_$_]
hunk ./src/using-type.lisp 76
- #+nil
hunk ./src/using-type.lisp 87
+
+(defun integer-types-disjunct-p (type1 type2)
+ ;; FIXME implement this
+ (declare (ignore type1 type2))
+ nil)