src/sb-optimize.lisp
Wed Jul 8 16:56:52 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* SBCL: compile time overload resolution
--- 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:19.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)))))))))))