darcs - smoke

1 (in-package :smoke)

3 (declaim (optimize (debug 3)))

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))))))

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)))

28 (defun give-up-transform (&rest args)

29 (apply #'sb-c::give-up-ir1-transform args))

31 (defmacro define-transform (name lambda-list &body body)

32 `(sb-c:deftransform ,name (,lambda-list)

33 ,@body))

35 (defmacro define-known (name)

36 `(sb-c:defknown ,name * *))

38 (defun method-form (method)

39 `(make-smoke-method

40 :id ,(id method)

41 :smoke (eval ,(get-smoke-variable-for-pointer

42 (smoke method)))))

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))

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 ,(if (eql (type-specifier object)

85 (find-smoke-class (get-class method)))

86 `(pointer object)

87 `(cast object

88 (find-class (quote ,(class-name

89 (find-smoke-class

90 (get-class method)))))))

91 (list ,@(sequence-form

92 sequence argument-names)))))))))))

95 ;;; Cache overload resolution / method lookup

97 ;;; FIXME the cached lookup should be faster

98 ;;;

99 ;;; cache return value conversion

100 ;;;

101 ;;; Using the gf symbol instead of the method name would be better,

102 ;;; althoug we would have to invent one for constructors.

103 ;;;

104 ;;; Since the -using-types stuff was intended for for compile time

105 ;;; expansion it is not that well suited for this. i.e. passing

106 ;;; closures would be better than the actual syntax.

107 ;;;

108 ;;; For qt.tests the uncached calls make up 30 % of all calls.

109 ;;; qt.examples:colliding-mice (run for ~1 min) gets 20 % uncached

110 ;;; calls and qt.examples:class-browser get 10 %. (20 February 2010)

111

112 (sb-int:defun-cached (find-best-viable-function-using-layouts-cached

113 :hash-function (lambda (name arguments

114 class const-p)

115 (declare (string name)

116 (list arguments)

117 (sb-c::layout class)

118 (boolean const-p))

119 (logand

120 (logxor

121 (sxhash name)

122 (the fixnum

123 (reduce

124 #'logxor

125 (mapcar #'sb-c::layout-clos-hash

126 arguments)))

127 (sxhash class)

128 (sxhash const-p))

129 #x1FF))

130 :hash-bits 9)

131 ((name equal) (arguments equal) (class eq) (const-p eq))

132 (declare (optimize (speed 3))

133 (inline find-best-viable-function-using-types))

134 (multiple-value-bind (method conversion-sequence)

135 (find-best-viable-function-using-types

136 name (mapcar #'sb-pcl::wrapper-class* arguments)

137 class const-p)

138 (list method (mapcar #'(lambda (s)

139 (if (symbolp s)

140 (fdefinition s)

141 #'(lambda (x)

142 (declare (optimize (speed 3)))

143 (funcall (fdefinition (first s))

144 x

145 (eval (second s))))))

146 conversion-sequence))))

147

148 (declaim (inline find-best-viable-function-cached))

149 (defun find-best-viable-function-cached (name arguments class const-p)

150 (declare (optimize (speed 3)))

151 (catch 'unspecific-type

152 (return-from find-best-viable-function-cached

153 (values-list

154 (find-best-viable-function-using-layouts-cached

155 name

156 (mapcar #'(lambda (o) (sb-c::layout-of o)) arguments)

157 class

158 const-p))))

159 (find-best-viable-function name arguments class const-p))