1
;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
5
;; This file contains some of the things that will have to change to support
6
;; inlining of methods.
8
(defun make-method-lambda-internal (method-lambda &optional env)
9
(unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
10
(error "The method-lambda argument to make-method-lambda, ~S,~
11
is not a lambda form" method-lambda))
12
(multiple-value-bind (documentation declarations real-body)
13
(extract-declarations (cddr method-lambda) env)
14
(let* ((name-decl (get-declaration 'method-name declarations))
15
(sll-decl (get-declaration 'method-lambda-list declarations))
16
(method-name (when (consp name-decl) (car name-decl)))
17
(generic-function-name (when method-name (car method-name)))
18
(specialized-lambda-list (or sll-decl (cadr method-lambda))))
19
(multiple-value-bind (parameters lambda-list specializers)
20
(parse-specialized-lambda-list specialized-lambda-list)
21
(let* ((required-parameters
22
(mapcar #'(lambda (r s) (declare (ignore s)) r)
25
(slots (mapcar #'list required-parameters))
27
(parameters-to-reference
28
(make-parameter-references specialized-lambda-list
36
(mapcar #'(lambda (a s) (and (symbolp s)
42
;; Remove the documentation string and insert the
43
;; appropriate class declarations. The documentation
44
;; string is removed to make it easy for us to insert
45
;; new declarations later, they will just go after the
46
;; cadr of the method lambda. The class declarations
47
;; are inserted to communicate the class of the method's
48
;; arguments to the code walk.
52
(progn ,@parameters-to-reference)
53
(block ,(if (listp generic-function-name)
54
(cadr generic-function-name)
55
generic-function-name)
57
(constant-value-p (and (null (cdr real-body))
58
(constantp (car real-body))))
59
(constant-value (and constant-value-p
60
(eval (car real-body))))
61
(plist (if (and constant-value-p
62
(or (typep constant-value '(or number character))
63
(and (symbolp constant-value)
64
(symbol-package constant-value))))
65
(list :constant-value constant-value)
67
(applyp (dolist (p lambda-list nil)
68
(cond ((memq p '(&optional &rest &key))
72
(multiple-value-bind (walked-lambda call-next-method-p closurep
74
(walk-method-lambda method-lambda required-parameters env
76
(multiple-value-bind (ignore walked-declarations walked-lambda-body)
77
(extract-declarations (cddr walked-lambda))
78
(declare (ignore ignore))
79
(when (or next-method-p-p call-next-method-p)
80
(setq plist (list* :needs-next-methods-p 't plist)))
81
(when (some #'cdr slots)
82
(multiple-value-bind (slot-name-lists call-list)
83
(slot-name-lists-from-slots slots calls)
84
(let ((pv-table-symbol (make-symbol "pv-table")))
86
`(,@(when slot-name-lists
87
`(:slot-name-lists ,slot-name-lists))
89
`(:call-list ,call-list))
90
:pv-table-symbol ,pv-table-symbol
92
(setq walked-lambda-body
93
`((pv-binding (,required-parameters ,slot-name-lists
95
,@walked-lambda-body))))))
96
(when (and (memq '&key lambda-list)
97
(not (memq '&allow-other-keys lambda-list)))
98
(let ((aux (memq '&aux lambda-list)))
99
(setq lambda-list (nconc (ldiff lambda-list aux)
100
(list '&allow-other-keys)
102
(values `(lambda (.method-args. .next-methods.)
103
(simple-lexical-method-functions
104
(,lambda-list .method-args. .next-methods.
105
:call-next-method-p ,call-next-method-p
106
:next-method-p-p ,next-method-p-p
109
,@walked-declarations
110
,@walked-lambda-body))
113
,@(when documentation
114
`(:documentation ,documentation)))))))))))
116
(define-inline-function slot-value (instance slot-name) (form closure-p env)
117
:predicate (and (not closure-p) (constantp slot-name))
118
:inline-arguments (required-parameters slots)
119
:inline (optimize-slot-value
121
(can-optimize-access form required-parameters env)
124
;collect information about:
125
; uses of the required-parameters
126
; uses of call-next-method and next-method-p:
130
;optimize calls to slot-value, set-slot-value, slot-boundp
131
;optimize calls to find-class
132
;optimize generic-function calls
133
(defun make-walk-function (required-parameters info slots calls)
134
#'(lambda (form context env)
135
(cond ((not (eq context ':eval)) form)
136
((not (listp form)) form)
137
((eq (car form) 'call-next-method)
138
(setq call-next-method-p 't)
140
((eq (car form) 'next-method-p)
141
(setq next-method-p-p 't)
143
((and (eq (car form) 'function)
144
(cond ((eq (cadr form) 'call-next-method)
145
(setq call-next-method-p 't)
148
((eq (cadr form) 'next-method-p)
149
(setq next-method-p-p 't)
153
((and (or (eq (car form) 'slot-value)
154
(eq (car form) 'set-slot-value)
155
(eq (car form) 'slot-boundp))
156
(constantp (caddr form)))
158
(can-optimize-access form
159
required-parameters env)))
162
(optimize-slot-value slots parameter form))
164
(optimize-set-slot-value slots parameter form))
166
(optimize-slot-boundp slots parameter form)))))
167
((and (or (symbolp (car form))
168
(and (consp (car form))
169
(eq (caar form) 'setf)))
171
(if (eq *boot-state* 'complete)
172
(standard-generic-function-p (gdefinition (car form)))
173
(funcallable-instance-p (gdefinition (car form)))))
174
(optimize-generic-function-call
175
form required-parameters env slots calls))
178
(defun walk-method-lambda (method-lambda required-parameters env slots calls)
179
(let* ((call-next-method-p nil) ;flag indicating that call-next-method
180
;should be in the method definition
181
(closurep nil) ;flag indicating that #'call-next-method
182
;was seen in the body of a method
183
(next-method-p-p nil) ;flag indicating that next-method-p
184
;should be in the method definition
185
(walk-functions `((call-next-method-p
186
,#'(lambda (form closure-p env)
187
(setq call-next-method-p 't)
192
,#'(lambda (form closure-p env)
193
(setq next-method-p-p 't)
197
((slot-value set-slot-value slot-boundp)
198
,#'(lambda (form closure-p env)
199
(if (and (not closure-p)
200
(constantp (caddr form)))
202
(let ((walked-lambda (walk-form method-lambda env
204
`((call-next-method-p
205
,#'(lambda (form closure-p env)
206
(setq call-next-method-p 't)
211
,#'(lambda (form closure-p env)
212
(setq next-method-p-p 't)
216
((slot-value set-slot-value slot-boundp)
217
,#'(lambda (form closure-p env)
219
(values walked-lambda
220
call-next-method-p closurep next-method-p-p)))))
222
(defun initialize-method-function (initargs &optional return-function-p method)
223
(let* ((mf (getf initargs ':function))
224
(method-spec (getf initargs ':method-spec))
225
(plist (getf initargs ':plist))
226
(pv-table-symbol (getf plist ':pv-table-symbol))
228
(mff (getf initargs ':fast-function)))
229
(flet ((set-mf-property (p v)
231
(setf (method-function-get mf p) v))
233
(setf (method-function-get mff p) v))))
236
(setq mf (set-function-name mf method-spec)))
238
(let ((name `(,(or (get (car method-spec) 'fast-sym)
239
(setf (get (car method-spec) 'fast-sym)
240
(intern (format nil "FAST-~A"
243
,@(cdr method-spec))))
244
(set-function-name mff name)
246
(set-mf-property :name name)))))
248
(let ((snl (getf plist :slot-name-lists))
249
(cl (getf plist :call-list)))
251
(setq pv-table (intern-pv-table :slot-name-lists snl
253
(when pv-table (set pv-table-symbol pv-table))
254
(set-mf-property :pv-table pv-table)))
255
(loop (when (null plist) (return nil))
256
(set-mf-property (pop plist) (pop plist)))
258
(set-mf-property :method method))
259
(when return-function-p
260
(or mf (method-function-from-fast-function mff)))))))
added
removed
pcl/extensions/inline.lisp
