1
;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
3
;;; *************************************************************************
4
;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
5
;;; All rights reserved.
7
;;; Use and copying of this software and preparation of derivative works
8
;;; based upon this software are permitted. Any distribution of this
9
;;; software or derivative works must comply with all applicable United
10
;;; States export control laws.
12
;;; This software is made available AS IS, and Xerox Corporation makes no
13
;;; warranty about the software, its performance or its conformity to any
16
;;; Any person obtaining a copy of this software is requested to send their
17
;;; name and post office or electronic mail address to:
18
;;; CommonLoops Coordinator
20
;;; 3333 Coyote Hill Rd.
21
;;; Palo Alto, CA 94304
22
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
24
;;; Suggestions, comments and requests for improvements are also welcome.
25
;;; *************************************************************************
30
;;; This file is (almost) functionally equivalent to dlap.lisp,
31
;;; but easier to read.
33
;;; Might generate faster code, too, depending on the compiler and
34
;;; whether an implementation-specific lap assembler was used.
36
(defun emit-one-class-reader (class-slot-p)
37
(emit-reader/writer :reader 1 class-slot-p))
39
(defun emit-one-class-writer (class-slot-p)
40
(emit-reader/writer :writer 1 class-slot-p))
42
(defun emit-two-class-reader (class-slot-p)
43
(emit-reader/writer :reader 2 class-slot-p))
45
(defun emit-two-class-writer (class-slot-p)
46
(emit-reader/writer :writer 2 class-slot-p))
48
;;; --------------------------------
50
(defun emit-one-index-readers (class-slot-p)
51
(emit-one-or-n-index-reader/writer :reader nil class-slot-p))
53
(defun emit-one-index-writers (class-slot-p)
54
(emit-one-or-n-index-reader/writer :writer nil class-slot-p))
56
(defun emit-n-n-readers ()
57
(emit-one-or-n-index-reader/writer :reader t nil))
59
(defun emit-n-n-writers ()
60
(emit-one-or-n-index-reader/writer :writer t nil))
62
;;; --------------------------------
64
(defun emit-checking (metatypes applyp)
65
(emit-checking-or-caching nil nil metatypes applyp))
67
(defun emit-caching (metatypes applyp)
68
(emit-checking-or-caching t nil metatypes applyp))
70
(defun emit-in-checking-cache-p (metatypes)
71
(emit-checking-or-caching nil t metatypes nil))
73
(defun emit-constant-value (metatypes)
74
(emit-checking-or-caching t t metatypes nil))
76
;;; --------------------------------
78
(defvar *precompiling-lap* nil)
79
(defvar *emit-function-p* t)
81
(defun emit-default-only (metatypes applyp)
82
(when (and (null *precompiling-lap*) *emit-function-p*)
83
(return-from emit-default-only
84
(emit-default-only-function metatypes applyp)))
85
(let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp))
86
(args (remove '&rest dlap-lambda-list))
87
(restl (when applyp '(.lap-rest-arg.))))
88
(generating-lisp '(emf)
90
`(invoke-effective-method-function emf ,applyp ,@args ,@restl))))
92
(defmacro emit-default-only-macro (metatypes applyp)
93
(let ((*emit-function-p* nil)
94
(*precompiling-lap* t))
96
(emit-default-only metatypes applyp))))
98
;;; --------------------------------
100
(defun generating-lisp (closure-variables args form)
101
(let* ((rest (memq '&rest args))
102
(ldiff (and rest (ldiff args rest)))
103
(args (if rest (append ldiff '(&rest .lap-rest-arg.)) args))
104
(lambda `(lambda ,closure-variables
105
,@(when (member 'miss-fn closure-variables)
106
`((declare (type function miss-fn))))
110
`((setq .lap-rest-arg. (copy-list .lap-rest-arg.))))
112
(declare #.*optimize-speed*)
114
(values (if *precompiling-lap*
116
(compile-lambda lambda))
119
;;; cmu17 note: since std-instance-p is weakened, that branch may run
120
;;; on non-pcl instances (structures). The result will be the
121
;;; non-wrapper layout for the structure, which will cause a miss. The "slots"
122
;;; will be whatever the first slot is, but will be ignored. Similarly,
123
;;; fsc-instance-p returns true on funcallable structures as well as PCL fins.
125
(defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p)
126
(when (and (null *precompiling-lap*) *emit-function-p*)
127
(return-from emit-reader/writer
128
(emit-reader/writer-function reader/writer 1-or-2-class class-slot-p)))
131
(closure-variables ())
132
(field (first-wrapper-cache-number-index))
133
(readp (eq reader/writer :reader))
134
(read-form (emit-slot-read-form class-slot-p 'index 'slots)))
135
;;we need some field to do the fast obsolete check
137
(:reader (setq instance (dfun-arg-symbol 0)
138
arglist (list instance)))
139
(:writer (setq instance (dfun-arg-symbol 1)
140
arglist (list (dfun-arg-symbol 0) instance))))
142
(1 (setq closure-variables '(wrapper-0 index miss-fn)))
143
(2 (setq closure-variables '(wrapper-0 wrapper-1 index miss-fn))))
144
(generating-lisp closure-variables
146
`(let* (,@(unless class-slot-p `((slots nil)))
147
(wrapper (cond ((std-instance-p ,instance)
148
,@(unless class-slot-p
149
`((setq slots (std-instance-slots ,instance))))
150
(std-instance-wrapper ,instance))
151
((fsc-instance-p ,instance)
152
,@(unless class-slot-p
153
`((setq slots (fsc-instance-slots ,instance))))
154
(fsc-instance-wrapper ,instance))))
155
,@(when readp '(value)))
156
(if (or (null wrapper)
157
(zerop (wrapper-cache-number-vector-ref wrapper ,field))
158
(not (or (eq wrapper wrapper-0)
159
,@(when (eql 2 1-or-2-class)
160
`((eq wrapper wrapper-1)))))
161
,@(when readp `((eq *slot-unbound* (setq value ,read-form)))))
162
(funcall miss-fn ,@arglist)
165
`(setf ,read-form ,(car arglist))))))))
167
(defun emit-slot-read-form (class-slot-p index slots)
170
`(%instance-ref ,slots ,index)))
172
(defun emit-boundp-check (value-form miss-fn arglist)
173
`(let ((value ,value-form))
174
(if (eq value *slot-unbound*)
175
(funcall ,miss-fn ,@arglist)
178
(defun emit-slot-access (reader/writer class-slot-p slots index miss-fn arglist)
179
(let ((read-form (emit-slot-read-form class-slot-p index slots)))
181
(:reader (emit-boundp-check read-form miss-fn arglist))
182
(:writer `(setf ,read-form ,(car arglist))))))
184
(defmacro emit-reader/writer-macro (reader/writer 1-or-2-class class-slot-p)
185
(let ((*emit-function-p* nil)
186
(*precompiling-lap* t))
188
(emit-reader/writer reader/writer 1-or-2-class class-slot-p))))
190
(defun emit-one-or-n-index-reader/writer (reader/writer cached-index-p class-slot-p)
191
(when (and (null *precompiling-lap*) *emit-function-p*)
192
(return-from emit-one-or-n-index-reader/writer
193
(emit-one-or-n-index-reader/writer-function
194
reader/writer cached-index-p class-slot-p)))
195
(multiple-value-bind (arglist metatypes)
197
(:reader (values (list (dfun-arg-symbol 0))
198
'(standard-instance)))
199
(:writer (values (list (dfun-arg-symbol 0) (dfun-arg-symbol 1))
200
'(t standard-instance))))
201
(generating-lisp `(cache ,@(unless cached-index-p '(index)) miss-fn)
203
`(let (,@(unless class-slot-p '(slots))
204
,@(when cached-index-p '(index)))
205
,(emit-dlap arglist metatypes
206
(emit-slot-access reader/writer class-slot-p
207
'slots 'index 'miss-fn arglist)
208
`(funcall miss-fn ,@arglist)
209
(when cached-index-p 'index)
210
(unless class-slot-p '(slots)))))))
212
(defmacro emit-one-or-n-index-reader/writer-macro
213
(reader/writer cached-index-p class-slot-p)
214
(let ((*emit-function-p* nil)
215
(*precompiling-lap* t))
217
(emit-one-or-n-index-reader/writer reader/writer cached-index-p class-slot-p))))
219
(defun emit-miss (miss-fn args &optional applyp)
220
(let ((restl (when applyp '(.lap-rest-arg.))))
222
`(apply ,miss-fn ,@args ,@restl)
223
`(funcall ,miss-fn ,@args ,@restl))))
225
(defun emit-checking-or-caching (cached-emf-p return-value-p metatypes applyp)
226
(when (and (null *precompiling-lap*) *emit-function-p*)
227
(return-from emit-checking-or-caching
228
(emit-checking-or-caching-function
229
cached-emf-p return-value-p metatypes applyp)))
230
(let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp))
231
(args (remove '&rest dlap-lambda-list))
232
(restl (when applyp '(.lap-rest-arg.))))
233
(generating-lisp `(cache ,@(unless cached-emf-p '(emf)) miss-fn)
235
`(let (,@(when cached-emf-p '(emf)))
239
(if cached-emf-p 'emf t)
240
`(invoke-effective-method-function emf ,applyp
242
(emit-miss 'miss-fn args applyp)
243
(when cached-emf-p 'emf))))))
245
(defmacro emit-checking-or-caching-macro (cached-emf-p return-value-p metatypes applyp)
246
(let ((*emit-function-p* nil)
247
(*precompiling-lap* t))
249
(emit-checking-or-caching cached-emf-p return-value-p metatypes applyp))))
251
(defun emit-dlap (args metatypes hit miss value-reg &optional slot-regs)
253
(wrapper-bindings (mapcan #'(lambda (arg mt)
256
`((,(intern (format nil "WRAPPER-~D" index)
258
,(emit-fetch-wrapper mt arg 'miss
261
(wrappers (mapcar #'car wrapper-bindings)))
262
(declare (fixnum index))
263
(unless wrappers (error "Every metatype is T."))
266
(let ((field (cache-field cache))
267
(cache-vector (cache-vector cache))
268
(mask (cache-mask cache))
269
(size (cache-size cache))
270
(overflow (cache-overflow cache))
272
(declare (fixnum size field mask))
273
,(cond ((cdr wrappers)
274
(emit-greater-than-1-dlap wrappers 'miss value-reg))
276
(emit-1-t-dlap (car wrappers) 'miss value-reg))
278
(emit-1-nil-dlap (car wrappers) 'miss)))
279
(return-from dfun ,hit))
281
(return-from dfun ,miss)))))
283
(defun emit-1-nil-dlap (wrapper miss-label)
284
`(let* ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper miss-label))
286
(declare (fixnum primary location))
288
(loop (when (eq ,wrapper (cache-vector-ref cache-vector location))
289
(return-from search nil))
290
(setq location (the fixnum (+ location 1)))
291
(when (= location size)
293
(when (= location primary)
294
(dolist (entry overflow)
295
(when (eq (car entry) ,wrapper)
296
(return-from search nil)))
297
(go ,miss-label))))))
299
(defmacro get-cache-vector-lock-count (cache-vector)
300
`(let ((lock-count (cache-vector-lock-count ,cache-vector)))
301
(unless (typep lock-count 'fixnum)
302
(error "my cache got freed somehow"))
303
(the fixnum lock-count)))
305
(defun emit-1-t-dlap (wrapper miss-label value)
306
`(let ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper miss-label))
307
(initial-lock-count (get-cache-vector-lock-count cache-vector)))
308
(declare (fixnum primary initial-lock-count))
309
(let ((location primary))
310
(declare (fixnum location))
312
(loop (when (eq ,wrapper (cache-vector-ref cache-vector location))
313
(setq ,value (cache-vector-ref cache-vector (1+ location)))
314
(return-from search nil))
315
(setq location (the fixnum (+ location 2)))
316
(when (= location size)
318
(when (= location primary)
319
(dolist (entry overflow)
320
(when (eq (car entry) ,wrapper)
321
(setq ,value (cdr entry))
322
(return-from search nil)))
324
(unless (= initial-lock-count
325
(get-cache-vector-lock-count cache-vector))
328
(defun emit-greater-than-1-dlap (wrappers miss-label value)
329
(declare (type list wrappers))
330
(let ((cache-line-size (compute-line-size (+ (length wrappers) (if value 1 0)))))
331
`(let ((primary 0) (size-1 (the fixnum (- size 1))))
332
(declare (fixnum primary size-1))
333
,(emit-n-wrapper-compute-primary-cache-location wrappers miss-label)
334
(let ((initial-lock-count (get-cache-vector-lock-count cache-vector)))
335
(declare (fixnum initial-lock-count))
336
(let ((location primary) (next-location 0))
337
(declare (fixnum location next-location))
339
(loop (setq next-location (the fixnum (+ location ,cache-line-size)))
343
(cache-vector-ref cache-vector
345
(the fixnum (+ location 1))))))
348
`((setq location (the fixnum (+ location 1)))
349
(setq ,value (cache-vector-ref cache-vector location))))
350
(return-from search nil))
351
(setq location next-location)
352
(when (= location size-1)
354
(when (= location primary)
355
(dolist (entry overflow)
356
(let ((entry-wrappers (car entry)))
357
(when (and ,@(mapcar #'(lambda (wrapper)
358
`(eq ,wrapper (pop entry-wrappers)))
361
`((setq ,value (cdr entry))))
362
(return-from search nil))))
364
(unless (= initial-lock-count
365
(get-cache-vector-lock-count cache-vector))
366
(go ,miss-label)))))))
368
(defun emit-1-wrapper-compute-primary-cache-location (wrapper miss-label)
369
`(let ((wrapper-cache-no (wrapper-cache-number-vector-ref ,wrapper field)))
370
(declare (fixnum wrapper-cache-no))
371
(when (zerop wrapper-cache-no) (go ,miss-label))
372
,(let ((form `(#+lucid %logand #-lucid logand
373
mask wrapper-cache-no)))
375
#-lucid `(the fixnum ,form))))
377
(defun emit-n-wrapper-compute-primary-cache-location (wrappers miss-label)
378
(declare (type list wrappers))
379
;; this returns 1 less that the actual location
381
,@(let ((adds 0) (len (length wrappers)))
382
(declare (fixnum adds len))
383
(mapcar #'(lambda (wrapper)
384
`(let ((wrapper-cache-no (wrapper-cache-number-vector-ref
386
(declare (fixnum wrapper-cache-no))
387
(when (zerop wrapper-cache-no) (go ,miss-label))
388
(setq primary (the fixnum (+ primary wrapper-cache-no)))
391
(when (or (zerop (mod adds wrapper-cache-number-adds-ok))
394
,(let ((form `(#+lucid %logand #-lucid logand
397
#-lucid `(the fixnum ,form))))))))
400
;;; cmu17 note: since std-instance-p is weakened, that branch may run
401
;;; on non-pcl instances (structures). The result will be the
402
;;; non-wrapper layout for the structure, which will cause a miss. The "slots"
403
;;; will be whatever the first slot is, but will be ignored. Similarly,
404
;;; fsc-instance-p returns true on funcallable structures as well as PCL fins.
406
(defun emit-fetch-wrapper (metatype argument miss-label &optional slot)
408
((standard-instance #+new-kcl-wrapper structure-instance)
409
`(cond ((std-instance-p ,argument)
410
,@(when slot `((setq ,slot (std-instance-slots ,argument))))
411
(std-instance-wrapper ,argument))
412
((fsc-instance-p ,argument)
413
,@(when slot `((setq ,slot (fsc-instance-slots ,argument))))
414
(fsc-instance-wrapper ,argument))
418
(when slot (error "Can't do a slot reg for this metatype."))
419
`(wrapper-of-macro ,argument))
420
((built-in-instance #-new-kcl-wrapper structure-instance)
421
(when slot (error "Can't do a slot reg for this metatype."))
422
`(#+new-kcl-wrapper built-in-wrapper-of
423
#-new-kcl-wrapper built-in-or-structure-wrapper
added
removed
pcl/pcl_dlisp.lisp
