repos
/
smoke
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
SBCL: compile time overload resolution
Annotate for file src/sb-optimize.lisp
2009-07-08 tobias
1
(in-package :smoke)
14:56:52 '
2
'
3
(declaim (optimize (debug 3)))
'
4
'
5
(defmacro catch-try ((tag &optional catch-result) catch-form &body body)
'
6
"Catch TAG in the BODY forms. When TAG is throw CATCH-RESULT is bound
'
7
to the thrown values and result of CATCH-FORM is returned. Otherwise
'
8
the result of BODY is returned and CATCH-FORM is not evaluated."
'
9
(flet ((catch-block (tag return-block body)
'
10
`(catch ,tag
'
11
(return-from ,return-block
'
12
,@body))))
'
13
(let ((return-block (gensym)))
'
14
`(block ,return-block
'
15
,(if catch-result
'
16
`(let ((,catch-result ,(catch-block tag return-block body)))
'
17
,catch-form)
'
18
`(progn ,(catch-block tag return-block body)
'
19
,catch-form))))))
'
20
'
21
(defun type-specifier (lvar)
'
22
(let ((type (sb-kernel:type-specifier (sb-c::lvar-type lvar))))
'
23
(if (subtypep type 'smoke-standard-object)
'
24
(find-class type)
'
25
type)))
'
26
'
27
'
28
(defun give-up-transform (&rest args)
'
29
(apply #'sb-c::give-up-ir1-transform args))
'
30
'
31
(defmacro define-transform (name lambda-list &body body)
'
32
`(sb-c:deftransform ,name (,lambda-list)
'
33
,@body))
'
34
'
35
(defmacro define-known (name)
'
36
`(sb-c:defknown ,name * *))
'
37
'
38
(defun method-form (method)
'
39
`(make-smoke-method
'
40
:id ,(id method)
'
41
:smoke (eval ,(get-smoke-variable-for-pointer
'
42
(smoke method)))))
'
43
'
44
(defun sequence-form (sequence arguments)
'
45
(mapcar #'(lambda (sequence argument)
'
46
(if (symbolp sequence)
'
47
`(,sequence ,argument)
'
48
`(,(first sequence) ,argument ,@(rest sequence))))
'
49
sequence arguments))
'
50
'
51
'
52
(defmacro define-resolve-at-compile-time (gf-name)
'
53
`(eval-when (:compile-toplevel :load-toplevel :execute)
'
54
(define-known ,gf-name)
'
55
(sb-c:defoptimizer (,gf-name derive-type) ((object &rest args))
'
56
(catch-try ('unspecific-type) sb-c::*wild-type*
'
57
(let ((method (find-best-viable-function-using-types
'
58
,(name (fdefinition gf-name))
'
59
(mapcar #'type-specifier args) (type-specifier object))))
'
60
(if (and method (class-p (return-type method)))
'
61
(sb-kernel:single-value-specifier-type
'
62
(find-smoke-class (get-class (return-type method))))
'
63
sb-c::*wild-type*))))
'
64
(define-transform ,gf-name (object &rest args)
'
65
(when (null args)
'
66
(give-up-transform "No arguments."))
'
67
(catch-try ('unspecific-type reason)
'
68
(give-up-transform "Could not resolve overload at compile time: ~A" reason)
'
69
(multiple-value-bind (method sequence)
'
70
(find-best-viable-function-using-types
'
71
,(name (fdefinition gf-name))
'
72
(mapcar #'type-specifier args)
'
73
(type-specifier object))
'
74
(let ((argument-names (make-gensym-list (length args))))
'
75
(when (null method)
'
76
(give-up-transform "No applicable method."))
'
77
(if (static-p method)
'
78
`(s-call ,(method-form method)
'
79
(null-pointer)
'
80
(list ,@(sequence-form
'
81
sequence args)))
'
82
`(lambda (object ,@argument-names)
'
83
(s-call ,(method-form method)
'
84
;; FIXME only cast when needed.
'
85
(cast object
'
86
(find-class (quote ,(class-name
'
87
(find-smoke-class
'
88
(get-class method))))))
'
89
(list ,@(sequence-form
'
90
sequence argument-names)))))))))))