/[cmucl]/src/pcl/fin.lisp
ViewVC logotype

Contents of /src/pcl/fin.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (show annotations)
Sat Aug 1 15:28:45 1992 UTC (21 years, 8 months ago) by ram
Branch: MAIN
Changes since 1.6: +48 -34 lines
This is July 92 PCL
1 ;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*-
2 ;;;
3 ;;; *************************************************************************
4 ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
5 ;;; All rights reserved.
6 ;;;
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.
11 ;;;
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
14 ;;; specification.
15 ;;;
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
19 ;;; Xerox PARC
20 ;;; 3333 Coyote Hill Rd.
21 ;;; Palo Alto, CA 94304
22 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
23 ;;;
24 ;;; Suggestions, comments and requests for improvements are also welcome.
25 ;;; *************************************************************************
26 ;;;
27
28 ;;
29 ;;;;;; FUNCALLABLE INSTANCES
30 ;;
31
32 #|
33
34 Generic functions are instances with meta class funcallable-standard-class.
35 Instances with this meta class are called funcallable-instances (FINs for
36 short). They behave something like lexical closures in that they have data
37 associated with them (which is used to store the slots) and are funcallable.
38 When a funcallable instance is funcalled, the function that is invoked is
39 called the funcallable-instance-function. The funcallable-instance-function
40 of a funcallable instance can be changed.
41
42 This file implements low level code for manipulating funcallable instances.
43
44 It is possible to implement funcallable instances in pure Common Lisp. A
45 simple implementation which uses lexical closures as the instances and a
46 hash table to record that the lexical closures are funcallable instances
47 is easy to write. Unfortunately, this implementation adds significant
48 overhead:
49
50 to generic-function-invocation (1 function call)
51 to slot-access (1 function call or one hash table lookup)
52 to class-of a generic-function (1 hash-table lookup)
53
54 In addition, it would prevent the funcallable instances from being garbage
55 collected. In short, the pure Common Lisp implementation really isn't
56 practical.
57
58 Instead, PCL uses a specially tailored implementation for each Common Lisp and
59 makes no attempt to provide a purely portable implementation. The specially
60 tailored implementations are based on the lexical closure's provided by that
61 implementation and are fairly short and easy to write.
62
63 Some of the implementation dependent code in this file was originally written
64 by someone in the employ of the vendor of that Common Lisp. That code is
65 explicitly marked saying who wrote it.
66
67 |#
68
69 (in-package 'pcl)
70
71 ;;;
72 ;;; The first part of the file contains the implementation dependent code to
73 ;;; implement funcallable instances. Each implementation must provide the
74 ;;; following functions and macros:
75 ;;;
76 ;;; ALLOCATE-FUNCALLABLE-INSTANCE-1 ()
77 ;;; should create and return a new funcallable instance. The
78 ;;; funcallable-instance-data slots must be initialized to NIL.
79 ;;; This is called by allocate-funcallable-instance and by the
80 ;;; bootstrapping code.
81 ;;;
82 ;;; FUNCALLABLE-INSTANCE-P (x)
83 ;;; the obvious predicate. This should be an INLINE function.
84 ;;; it must be funcallable, but it would be nice if it compiled
85 ;;; open.
86 ;;;
87 ;;; SET-FUNCALLABLE-INSTANCE-FUNCTION (fin new-value)
88 ;;; change the fin so that when it is funcalled, the new-value
89 ;;; function is called. Note that it is legal for new-value
90 ;;; to be copied before it is installed in the fin, specifically
91 ;;; there is no accessor for a FIN's function so this function
92 ;;; does not have to preserve the actual new value. The new-value
93 ;;; argument can be any funcallable thing, a closure, lambda
94 ;;; compiled code etc. This function must coerce those values
95 ;;; if necessary.
96 ;;; NOTE: new-value is almost always a compiled closure. This
97 ;;; is the important case to optimize.
98 ;;;
99 ;;; FUNCALLABLE-INSTANCE-DATA-1 (fin data-name)
100 ;;; should return the value of the data named data-name in the fin.
101 ;;; data-name is one of the symbols in the list which is the value
102 ;;; of funcallable-instance-data. Since data-name is almost always
103 ;;; a quoted symbol and funcallable-instance-data is a constant, it
104 ;;; is possible (and worthwhile) to optimize the computation of
105 ;;; data-name's offset in the data part of the fin.
106 ;;; This must be SETF'able.
107 ;;;
108
109 (eval-when (compile load eval)
110 (defconstant funcallable-instance-data
111 '(wrapper slots)
112 "These are the 'data-slots' which funcallable instances have so that
113 the meta-class funcallable-standard-class can store class, and static
114 slots in them.")
115 )
116
117 (defmacro funcallable-instance-data-position (data)
118 (if (and (consp data)
119 (eq (car data) 'quote))
120 (or (position (cadr data) funcallable-instance-data :test #'eq)
121 (progn
122 (warn "Unknown funcallable-instance data: ~S." (cadr data))
123 `(error "Unknown funcallable-instance data: ~S." ',(cadr data))))
124 `(position ,data funcallable-instance-data :test #'eq)))
125
126 (proclaim '(notinline called-fin-without-function))
127 (defun called-fin-without-function (&rest args)
128 (declare (ignore args))
129 (error "Attempt to funcall a funcallable-instance without first~%~
130 setting its funcallable-instance-function."))
131
132
133
134
135 ;;;
136 ;;; In Lucid Lisp, compiled functions and compiled closures have the same
137 ;;; representation. They are called procedures. A procedure is a basically
138 ;;; just a constants vector, with one slot which points to the CODE. This
139 ;;; means that constants and closure variables are intermixed in the procedure
140 ;;; vector.
141 ;;;
142 ;;; This code was largely written by JonL@Lucid.com. Problems with it should
143 ;;; be referred to him.
144 ;;;
145 #+Lucid
146 (progn
147
148 (defconstant procedure-is-funcallable-instance-bit-position 10)
149
150 (defconstant fin-trampoline-fun-index lucid::procedure-literals)
151
152 (defconstant fin-size (+ fin-trampoline-fun-index
153 (length funcallable-instance-data)
154 1))
155
156 ;;;
157 ;;; The inner closure of this function will have its code vector replaced
158 ;;; by a hand-coded fast jump to the function that is stored in the
159 ;;; captured-lexical variable. In effect, that code is a hand-
160 ;;; optimized version of the code for this inner closure function.
161 ;;;
162 (defun make-trampoline (function)
163 (declare (optimize (speed 3) (safety 0)(compilation-speed 0)(space 0)))
164 #'(lambda (&rest args)
165 (apply function args)))
166
167 (eval-when (eval)
168 (compile 'make-trampoline)
169 )
170
171
172 (defun binary-assemble (codes)
173 (declare (list codes))
174 (let* ((ncodes (length codes))
175 (code-vec #-LCL3.0 (lucid::new-code ncodes)
176 #+LCL3.0 (lucid::with-current-area
177 lucid::*READONLY-NON-POINTER-AREA*
178 (lucid::new-code ncodes))))
179 (declare (type index ncodes))
180 (do ((l codes (cdr l))
181 (i 0 (the index (1+ i))))
182 ((null l) nil)
183 (declare (type index i))
184 (setf (lucid::code-ref code-vec i) (car l)))
185 code-vec))
186
187 ;;;
188 ;;; Egad! Binary patching!
189 ;;; See comment following definition of MAKE-TRAMPOLINE -- this is just
190 ;;; the "hand-optimized" machine instructions to make it work.
191 ;;;
192 (defvar *mattress-pad-code*
193 (binary-assemble
194 #+MC68000
195 '(#x2A6D #x11 #x246D #x1 #x4EEA #x5)
196 #+SPARC
197 (ecase (lucid::procedure-length #'lucid::false)
198 (5
199 '(#xFA07 #x6012 #xDE07 #x7FFE #x81C3 #xFFFE #x100 #x0))
200 (8
201 `(#xFA07 #x601E #xDE07 #x7FFE #x81C3 #xFFFE #x100 #x0)))
202 #+(and BSP (not LCL3.0 ))
203 '(#xCD33 #x11 #xCDA3 #x1 #xC19A #x5 #xE889)
204 #+(and BSP LCL3.0)
205 '(#x7733 #x7153 #xC155 #x5 #xE885)
206 #+I386
207 '(#x87 #xD2 #x8B #x76 #xE #xFF #x66 #xFE)
208 #+VAX
209 '(#xD0 #xAC #x11 #x5C #xD0 #xAC #x1 #x57 #x17 #xA7 #x5)
210 #+PA
211 '(#x4891 #x3C #xE461 #x6530 #x48BF #x3FF9)
212 #+MIPS
213 '(#x8FD4 #x1E #x2785 #x2EEF #xA0 #x8 #x14 #xF000)
214 #-(or MC68000 SPARC BSP I386 VAX PA MIPS)
215 '(0 0 0 0)))
216
217
218 (lucid::defsubst funcallable-instance-p (x)
219 (and (lucid::procedurep x)
220 (lucid::logbitp& procedure-is-funcallable-instance-bit-position
221 (lucid::procedure-ref x lucid::procedure-flags))))
222
223 (lucid::defsubst set-funcallable-instance-p (x)
224 (if (not (lucid::procedurep x))
225 (error "Can't make a non-procedure a fin.")
226 (setf (lucid::procedure-ref x lucid::procedure-flags)
227 (logior (the index
228 (expt 2 (the index
229 procedure-is-funcallable-instance-bit-position)))
230 (the index
231 (lucid::procedure-ref x lucid::procedure-flags))))))
232
233
234 (defun allocate-funcallable-instance-1 ()
235 #+Prime
236 (declare (notinline lucid::new-procedure)) ;fixes a bug in Prime 1.0 in
237 ;which new-procedure expands
238 ;incorrectly
239 (let ((new-fin (lucid::new-procedure fin-size))
240 (fin-index fin-size))
241 (declare (type index fin-index)
242 (type lucid::procedure new-fin))
243 (dotimes (i (length (the list funcallable-instance-data)) )
244 ;; Initialize the new funcallable-instance. As part of our contract,
245 ;; we have to make sure the initial value of all the funcallable
246 ;; instance data slots is NIL.
247 (setf fin-index (the index (1- fin-index)))
248 (setf (lucid::procedure-ref new-fin fin-index) nil))
249 ;;
250 ;; "Assemble" the initial function by installing a fast "trampoline" code;
251 ;;
252 (setf (lucid::procedure-ref new-fin lucid::procedure-code)
253 *mattress-pad-code*)
254 ;; Disable argcount checking in the "mattress-pad" code for
255 ;; ports that go through standardized trampolines
256 #+PA (setf (sys:procedure-ref new-fin lucid::procedure-arg-count) -1)
257 #+MIPS (progn
258 (setf (sys:procedure-ref new-fin lucid::procedure-min-args) 0)
259 (setf (sys:procedure-ref new-fin lucid::procedure-max-args)
260 (the index call-arguments-limit)))
261 ;; but start out with the function to be run as an error call.
262 (setf (lucid::procedure-ref new-fin fin-trampoline-fun-index)
263 #'called-fin-without-function)
264 ;; Then mark it as a "fin"
265 (set-funcallable-instance-p new-fin)
266 new-fin))
267
268 (defun set-funcallable-instance-function (fin new-value)
269 (unless (funcallable-instance-p fin)
270 (error "~S is not a funcallable-instance" fin))
271 (if (lucid::procedurep new-value)
272 (progn
273 (setf (lucid::procedure-ref fin fin-trampoline-fun-index) new-value)
274 fin)
275 (progn
276 (unless (functionp new-value)
277 (error "~S is not a function." new-value))
278 ;; 'new-value' is an interpreted function. Install a
279 ;; trampoline to call the interpreted function.
280 (set-funcallable-instance-function fin
281 (make-trampoline new-value)))))
282
283 (defmacro funcallable-instance-data-1 (instance data)
284 `(lucid::procedure-ref
285 ,instance
286 (the index
287 (- (the index (- (the index fin-size) 1))
288 (the index (funcallable-instance-data-position ,data))))))
289
290 );end of #+Lucid
291
292
293 ;;;
294 ;;; In Symbolics Common Lisp, a lexical closure is a pair of an environment
295 ;;; and an ordinary compiled function. The environment is represented as
296 ;;; a CDR-coded list. I know of no way to add a special bit to say that the
297 ;;; closure is a FIN, so for now, closures are marked as FINS by storing a
298 ;;; special marker in the last cell of the environment.
299 ;;;
300 ;;; The new structure of a fin is:
301 ;;; (lex-env lex-fun *marker* fin-data0 fin-data1)
302 ;;; The value returned by allocate is a lexical-closure pointing to the start
303 ;;; of the fin list. Benefits are: no longer ever have to copy environments,
304 ;;; fins can be much smaller (5 words instead of 18), old environments never
305 ;;; get destroyed (so running dcodes dont have the lex env change from under
306 ;;; them any longer).
307 ;;;
308 ;;; Most of the fin operations speed up a little (by as much as 30% on a
309 ;;; 3650), at least one nasty bug is fixed, and so far at least I've not
310 ;;; seen any problems at all with this code. - mike thome (mthome@bbn.com)
311 ;;;
312 #+(and Genera (not Genera-Release-8))
313 (progn
314
315 (defvar *funcallable-instance-marker* (list "Funcallable Instance Marker"))
316
317 (defun allocate-funcallable-instance-1 ()
318 (let* ((whole-fin (make-list (+ 3 (length funcallable-instance-data))))
319 (new-fin (sys:%make-pointer-offset sys:dtp-lexical-closure
320 whole-fin
321 0)))
322 ;;
323 ;; note that we DO NOT turn the real lex-closure part of the fin into
324 ;; a dotted pair, because (1) the machine doesn't care and (2) if we
325 ;; did the garbage collector would reclaim everything after the lexical
326 ;; function.
327 ;;
328 (setf (sys:%p-contents-offset new-fin 2) *funcallable-instance-marker*)
329 (setf (si:lexical-closure-function new-fin)
330 #'(lambda (ignore &rest ignore-them-too)
331 (declare (ignore ignore ignore-them-too))
332 (called-fin-without-function)))
333 #+ignore
334 (setf (si:lexical-closure-environment new-fin) nil)
335 new-fin))
336
337 (scl:defsubst funcallable-instance-p (x)
338 (declare (inline si:lexical-closure-p))
339 (and (si:lexical-closure-p x)
340 (= (sys:%p-cdr-code (sys:%make-pointer-offset sys:dtp-compiled-function x 1))
341 sys:cdr-next)
342 (eq (sys:%p-contents-offset x 2) *funcallable-instance-marker*)))
343
344 (defun set-funcallable-instance-function (fin new-value)
345 (cond ((not (funcallable-instance-p fin))
346 (error "~S is not a funcallable-instance" fin))
347 ((not (or (functionp new-value)
348 (and (consp new-value)
349 (eq (car new-value) 'si:digested-lambda))))
350 (error "~S is not a function." new-value))
351 ((and (si:lexical-closure-p new-value)
352 (compiled-function-p (si:lexical-closure-function new-value)))
353 (let ((env (si:lexical-closure-environment new-value))
354 (fn (si:lexical-closure-function new-value)))
355 ;; we only have to copy the pointers!!
356 (setf (si:lexical-closure-environment fin) env
357 (si:lexical-closure-function fin) fn)
358 ; (dbg:set-env->fin env fin)
359 ))
360 (t
361 (set-funcallable-instance-function fin
362 (make-trampoline new-value)))))
363
364 (defun make-trampoline (function)
365 (declare #.*optimize-speed*)
366 #'(lambda (&rest args)
367 #+Genera (declare (dbg:invisible-frame :pcl-internals))
368 (apply function args)))
369
370 (defmacro funcallable-instance-data-1 (fin data)
371 `(sys:%p-contents-offset ,fin
372 (+ 3 (funcallable-instance-data-position ,data))))
373
374 (defsetf funcallable-instance-data-1 (fin data) (new-value)
375 `(setf (sys:%p-contents-offset ,fin
376 (+ 3 (funcallable-instance-data-position ,data)))
377 ,new-value))
378
379 ;;;
380 ;;; Make funcallable instances print out properly.
381 ;;;
382 (defvar *print-lexical-closure* nil)
383
384 (defun pcl-print-lexical-closure (exp stream slashify-p &optional (depth 0))
385 (declare (ignore depth))
386 (declare (special *boot-state*))
387 (if (or (eq *print-lexical-closure* exp)
388 (neq *boot-state* 'complete)
389 (eq (class-of exp) *the-class-t*))
390 (let ((*print-lexical-closure* nil))
391 (funcall (original-definition 'si:print-lexical-closure)
392 exp stream slashify-p))
393 (let ((*print-escape* slashify-p)
394 (*print-lexical-closure* exp))
395 (print-object exp stream))))
396
397 (unless (boundp '*boot-state*)
398 (setq *boot-state* nil))
399
400 (redefine-function 'si:print-lexical-closure 'pcl-print-lexical-closure)
401
402 (defvar *function-name-level* 0)
403
404 (defun pcl-function-name (function &rest other-args)
405 (if (and (eq *boot-state* 'complete)
406 (funcallable-instance-p function)
407 (generic-function-p function)
408 (<= *function-name-level* 2))
409 (let ((*function-name-level* (1+ *function-name-level*)))
410 (generic-function-name function))
411 (apply (original-definition 'si:function-name) function other-args)))
412
413 (redefine-function 'si:function-name 'pcl-function-name)
414
415 (defun pcl-arglist (function &rest other-args)
416 (let ((defn nil))
417 (cond ((and (funcallable-instance-p function)
418 (generic-function-p function))
419 (generic-function-pretty-arglist function))
420 ((and (sys:validate-function-spec function)
421 (sys:fdefinedp function)
422 (setq defn (sys:fdefinition function))
423 (funcallable-instance-p defn)
424 (generic-function-p defn))
425 (generic-function-pretty-arglist defn))
426 (t (apply (original-definition 'zl:arglist) function other-args)))))
427
428 (redefine-function 'zl:arglist 'pcl-arglist)
429
430
431 ;;;
432 ;;; This code is adapted from frame-lexical-environment and frame-function.
433 ;;;
434 #||
435 dbg:
436 (progn
437
438 (defvar *old-frame-function*)
439
440 (defvar *inside-new-frame-function* nil)
441
442 (defun new-frame-function (frame)
443 (let* ((fn (funcall *old-frame-function* frame))
444 (location (%pointer-plus frame #+imach (defstorage-size stack-frame) #-imach 0))
445 (env? #+3600 (location-contents location)
446 #+imach (%memory-read location :cycle-type %memory-scavenge)))
447 (or (when (cl:consp env?)
448 (let ((l2 (last2 env?)))
449 (when (eq (car l2) '.this-is-a-dfun.)
450 (cadr l2))))
451 fn)))
452
453 (defun pcl::doctor-dfun-for-the-debugger (gf dfun)
454 (when (sys:lexical-closure-p dfun)
455 (let* ((env (si:lexical-closure-environment dfun))
456 (l2 (last2 env)))
457 (unless (eq (car l2) '.this-is-a-dfun.)
458 (setf (si:lexical-closure-environment dfun)
459 (nconc env (list '.this-is-a-dfun. gf))))))
460 dfun)
461
462 (defun last2 (l)
463 (labels ((scan (2ago tail)
464 (if (null tail)
465 2ago
466 (if (cl:consp tail)
467 (scan (cdr 2ago) (cdr tail))
468 nil))))
469 (and (cl:consp l)
470 (cl:consp (cdr l))
471 (scan l (cddr l)))))
472
473 (eval-when (load)
474 (unless (boundp '*old-frame-function*)
475 (setq *old-frame-function* #'frame-function)
476 (setf (cl:symbol-function 'frame-function) 'new-frame-function)))
477
478 )
479 ||#
480
481 );end of #+Genera
482
483
484
485 ;;;
486 ;;; In Genera 8.0, we use a real funcallable instance (from Genera CLOS) for this.
487 ;;; This minimizes the subprimitive mucking around.
488 ;;;
489 #+(and Genera Genera-Release-8)
490 (progn
491
492 (clos-internals::ensure-class
493 'pcl-funcallable-instance
494 :direct-superclasses '(clos-internals:funcallable-instance)
495 :slots `((:name function
496 :initform #'(lambda (ignore &rest ignore-them-too)
497 (declare (ignore ignore ignore-them-too))
498 (called-fin-without-function))
499 :initfunction ,#'(lambda nil
500 #'(lambda (ignore &rest ignore-them-too)
501 (declare (ignore ignore ignore-them-too))
502 (called-fin-without-function))))
503 ,@(mapcar #'(lambda (slot) `(:name ,slot)) funcallable-instance-data))
504 :metaclass 'clos:funcallable-standard-class)
505
506 (defun pcl-funcallable-instance-trampoline (extra-arg &rest args)
507 (apply (sys:%instance-ref (clos-internals::%dispatch-instance-from-extra-argument extra-arg)
508 3)
509 args))
510
511 (defun allocate-funcallable-instance-1 ()
512 (let ((fin (clos:make-instance 'pcl-funcallable-instance)))
513 (setf (clos-internals::%funcallable-instance-function fin)
514 #'pcl-funcallable-instance-trampoline)
515 (setf (clos-internals::%funcallable-instance-extra-argument fin)
516 (sys:%make-pointer sys:dtp-instance
517 (clos-internals::%funcallable-instance-extra-argument fin)))
518 (setf (clos:slot-value fin 'clos-internals::funcallable-instance) fin)
519 fin))
520
521 (scl:defsubst funcallable-instance-p (x)
522 (and (sys:funcallable-instance-p x)
523 (eq (clos-internals::%funcallable-instance-function x)
524 #'pcl-funcallable-instance-trampoline)))
525
526 (defun set-funcallable-instance-function (fin new-value)
527 (setf (clos:slot-value fin 'function) new-value))
528
529 (defmacro funcallable-instance-data-1 (fin data)
530 `(clos-internals:%funcallable-instance-ref
531 ,fin (+ 4 (funcallable-instance-data-position ,data))))
532
533 (defsetf funcallable-instance-data-1 (fin data) (new-value)
534 `(setf (clos-internals:%funcallable-instance-ref
535 ,fin (+ 4 (funcallable-instance-data-position ,data)))
536 ,new-value))
537
538 (clos:defmethod clos:print-object ((fin pcl-funcallable-instance) stream)
539 (print-object fin stream))
540
541 (clos:defmethod clos-internals:debugging-information-function ((fin pcl-funcallable-instance))
542 nil)
543
544 (clos:defmethod clos-internals:function-name-object ((fin pcl-funcallable-instance))
545 (declare (special *boot-state*))
546 (if (and (eq *boot-state* 'complete)
547 (generic-function-p fin))
548 (generic-function-name fin)
549 fin))
550
551 (clos:defmethod clos-internals:arglist-object ((fin pcl-funcallable-instance))
552 (declare (special *boot-state*))
553 (if (and (eq *boot-state* 'complete)
554 (generic-function-p fin))
555 (generic-function-pretty-arglist fin)
556 '(&rest args)))
557
558 );end of #+Genera
559
560
561
562 #+Cloe-Runtime
563 (progn
564
565 (defconstant funcallable-instance-closure-slots 5)
566 (defconstant funcallable-instance-closure-size
567 (+ funcallable-instance-closure-slots (length funcallable-instance-data) 1))
568
569 #-CLOE-Release-2 (progn
570
571 (defun allocate-funcallable-instance-1 ()
572 (let ((data (system::make-funcallable-structure 'funcallable-instance
573 funcallable-instance-closure-size)))
574 (setf (system::%trampoline-ref data funcallable-instance-closure-slots)
575 'funcallable-instance)
576 (set-funcallable-instance-function
577 data
578 #'(lambda (&rest ignore-them-too)
579 (declare (ignore ignore-them-too))
580 (called-fin-without-function)))
581 data))
582
583 (proclaim '(inline funcallable-instance-p))
584 (defun funcallable-instance-p (x)
585 (and (typep x 'system::trampoline)
586 (= (system::%trampoline-data-length x) funcallable-instance-closure-size)
587 (eq (system::%trampoline-ref x funcallable-instance-closure-slots)
588 'funcallable-instance)))
589
590 (defun set-funcallable-instance-function (fin new-value)
591 (when (not (funcallable-instance-p fin))
592 (error "~S is not a funcallable-instance" fin))
593 (etypecase new-value
594 (system::trampoline
595 (let ((length (system::%trampoline-data-length new-value)))
596 (cond ((> length funcallable-instance-closure-slots)
597 (set-funcallable-instance-function
598 fin
599 #'(lambda (&rest args)
600 (declare (sys:downward-rest-argument))
601 (apply new-value args))))
602 (t
603 (setf (system::%trampoline-function fin)
604 (system::%trampoline-function new-value))
605 (dotimes (i length)
606 (setf (system::%trampoline-ref fin i)
607 (system::%trampoline-ref new-value i)))))))
608 (compiled-function
609 (setf (system::%trampoline-function fin) new-value))
610 (function
611 (set-funcallable-instance-function
612 fin
613 #'(lambda (&rest args)
614 (declare (sys:downward-rest-argument))
615 (apply new-value args))))))
616
617 (defmacro funcallable-instance-data-1 (fin data)
618 `(system::%trampoline-ref ,fin (+ funcallable-instance-closure-slots
619 1 (funcallable-instance-data-position ,data))))
620
621 (defsetf funcallable-instance-data-1 (fin data) (new-value)
622 `(setf (system::%trampoline-ref ,fin (+ funcallable-instance-closure-slots
623 1 (funcallable-instance-data-position ,data)))
624 ,new-value))
625
626 )
627
628 #+CLOE-Release-2 (progn
629
630 (defun allocate-funcallable-instance-1 ()
631 (let ((data (si::cons-closure funcallable-instance-closure-size)))
632 (setf (si::closure-ref data funcallable-instance-closure-slots) 'funcallable-instance)
633 (set-funcallable-instance-function
634 data
635 #'(lambda (&rest ignore-them-too)
636 (declare (ignore ignore-them-too))
637 (error "Called a FIN without first setting its function.")))
638 data))
639
640 (proclaim '(inline funcallable-instance-p))
641 (defun funcallable-instance-p (x)
642 (and (si::closurep x)
643 (= (si::closure-length x) funcallable-instance-closure-size)
644 (eq (si::closure-ref x funcallable-instance-closure-slots) 'funcallable-instance)))
645
646 (defun set-funcallable-instance-function (fin new-value)
647 (when (not (funcallable-instance-p fin))
648 (error "~S is not a funcallable-instance" fin))
649 (etypecase new-value
650 (si::closure
651 (let ((length (si::closure-length new-value)))
652 (cond ((> length funcallable-instance-closure-slots)
653 (set-funcallable-instance-function
654 fin
655 #'(lambda (&rest args)
656 (declare (sys:downward-rest-argument))
657 (apply new-value args))))
658 (t
659 (setf (si::closure-function fin) (si::closure-function new-value))
660 (dotimes (i length)
661 (si::object-set fin (+ i 3) (si::object-ref new-value (+ i 3))))))))
662 (compiled-function
663 (setf (si::closure-function fin) new-value))
664 (function
665 (set-funcallable-instance-function
666 fin
667 #'(lambda (&rest args)
668 (declare (sys:downward-rest-argument))
669 (apply new-value args))))))
670
671 (defmacro funcallable-instance-data-1 (fin data)
672 `(si::closure-ref ,fin (+ funcallable-instance-closure-slots
673 1 (funcallable-instance-data-position ,data))))
674
675 (defsetf funcallable-instance-data-1 (fin data) (new-value)
676 `(setf (si::closure-ref ,fin (+ funcallable-instance-closure-slots
677 1 (funcallable-instance-data-position ,data)))
678 ,new-value))
679
680 )
681
682 )
683
684
685 ;;;
686 ;;;
687 ;;; In Xerox Common Lisp, a lexical closure is a pair of an environment and
688 ;;; CCODEP. The environment is represented as a block. There is space in
689 ;;; the top 8 bits of the pointers to the CCODE and the environment to use
690 ;;; to mark the closure as being a FIN.
691 ;;;
692 ;;; To help the debugger figure out when it has found a FIN on the stack, we
693 ;;; reserve the last element of the closure environment to use to point back
694 ;;; to the actual fin.
695 ;;;
696 ;;; Note that there is code in xerox-low which lets us access the fields of
697 ;;; compiled-closures and which defines the closure-overlay record. That
698 ;;; code is there because there are some clients of it in that file.
699 ;;;
700 #+Xerox
701 (progn
702
703 ;; Don't be fooled. We actually allocate one bigger than this to have a place
704 ;; to store the backpointer to the fin. -smL
705 (defconstant funcallable-instance-closure-size 15)
706
707 ;; This is only used in the file PCL-ENV.
708 (defvar *fin-env-type*
709 (type-of (il:\\allocblock (1+ funcallable-instance-closure-size) t)))
710
711 ;; Well, Gregor may be too proud to hack xpointers, but bvm and I aren't. -smL
712
713 (defstruct fin-env-pointer
714 (pointer nil :type il:fullxpointer))
715
716 (defun fin-env-fin (fin-env)
717 (fin-env-pointer-pointer
718 (il:\\getbaseptr fin-env (* funcallable-instance-closure-size 2))))
719
720 (defun |set fin-env-fin| (fin-env new-value)
721 (il:\\rplptr fin-env (* funcallable-instance-closure-size 2)
722 (make-fin-env-pointer :pointer new-value))
723 new-value)
724
725 (defsetf fin-env-fin |set fin-env-fin|)
726
727 ;; The finalization function that will clean up the backpointer from the
728 ;; fin-env to the fin. This needs to be careful to not cons at all. This
729 ;; depends on there being no other finalization function on compiled-closures,
730 ;; since there is only one finalization function per datatype. Too bad. -smL
731 (defun finalize-fin (fin)
732 ;; This could use the fn funcallable-instance-p, but if we get here we know
733 ;; that this is a closure, so we can skip that test.
734 (when (il:fetch (closure-overlay funcallable-instance-p) il:of fin)
735 (let ((env (il:fetch (il:compiled-closure il:environment) il:of fin)))
736 (when env
737 (setq env
738 (il:\\getbaseptr env (* funcallable-instance-closure-size 2)))
739 (when (il:typep env 'fin-env-pointer)
740 (setf (fin-env-pointer-pointer env) nil)))))
741 nil) ;Return NIL so GC can proceed
742
743 (eval-when (load)
744 ;; Install the above finalization function.
745 (when (fboundp 'finalize-fin)
746 (il:\\set.finalization.function 'il:compiled-closure 'finalize-fin)))
747
748 (defun allocate-funcallable-instance-1 ()
749 (let* ((env (il:\\allocblock (1+ funcallable-instance-closure-size) t))
750 (fin (il:make-compiled-closure nil env)))
751 (setf (fin-env-fin env) fin)
752 (il:replace (closure-overlay funcallable-instance-p) il:of fin il:with 't)
753 (set-funcallable-instance-function fin
754 #'(lambda (&rest ignore)
755 (declare (ignore ignore))
756 (called-fin-without-function)))
757 fin))
758
759 (xcl:definline funcallable-instance-p (x)
760 (and (typep x 'il:compiled-closure)
761 (il:fetch (closure-overlay funcallable-instance-p) il:of x)))
762
763 (defun set-funcallable-instance-function (fin new)
764 (cond ((not (funcallable-instance-p fin))
765 (error "~S is not a funcallable-instance" fin))
766 ((not (functionp new))
767 (error "~S is not a function." new))
768 ((typep new 'il:compiled-closure)
769 (let* ((fin-env
770 (il:fetch (il:compiled-closure il:environment) il:of fin))
771 (new-env
772 (il:fetch (il:compiled-closure il:environment) il:of new))
773 (new-env-size (if new-env (il:\\#blockdatacells new-env) 0))
774 (fin-env-size (- funcallable-instance-closure-size
775 (length funcallable-instance-data))))
776 (cond ((and new-env
777 (<= new-env-size fin-env-size))
778 (dotimes (i fin-env-size)
779 (il:\\rplptr fin-env
780 (* i 2)
781 (if (< i new-env-size)
782 (il:\\getbaseptr new-env (* i 2))
783 nil)))
784 (setf (compiled-closure-fnheader fin)
785 (compiled-closure-fnheader new)))
786 (t
787 (set-funcallable-instance-function
788 fin
789 (make-trampoline new))))))
790 (t
791 (set-funcallable-instance-function fin
792 (make-trampoline new)))))
793
794 (defun make-trampoline (function)
795 #'(lambda (&rest args)
796 (apply function args)))
797
798
799 (defmacro funcallable-instance-data-1 (fin data)
800 `(il:\\getbaseptr (il:fetch (il:compiled-closure il:environment) il:of ,fin)
801 (* (- funcallable-instance-closure-size
802 (funcallable-instance-data-position ,data)
803 1) ;Reserve last element to
804 ;point back to actual FIN!
805 2)))
806
807 (defsetf funcallable-instance-data-1 (fin data) (new-value)
808 `(il:\\rplptr (il:fetch (il:compiled-closure il:environment) il:of ,fin)
809 (* (- funcallable-instance-closure-size
810 (funcallable-instance-data-position ,data)
811 1)
812 2)
813 ,new-value))
814
815 );end of #+Xerox
816
817
818 ;;;
819 ;;; In Franz Common Lisp ExCL
820 ;;; This code was originally written by:
821 ;;; jkf%franz.uucp@berkeley.edu
822 ;;; and hacked by:
823 ;;; smh%franz.uucp@berkeley.edu
824
825 #+ExCL
826 (progn
827
828 (defconstant funcallable-instance-flag-bit #x1)
829
830 (defun funcallable-instance-p (x)
831 (and (excl::function-object-p x)
832 (eq funcallable-instance-flag-bit
833 (logand (excl::fn_flags x)
834 funcallable-instance-flag-bit))))
835
836 (defun make-trampoline (function)
837 #'(lambda (&rest args)
838 (apply function args)))
839
840 ;; We initialize a fin's procedure function to this because
841 ;; someone might try to funcall it before it has been set up.
842 (defun init-fin-fun (&rest ignore)
843 (declare (ignore ignore))
844 (called-fin-without-function))
845
846
847 (eval-when (eval)
848 (compile 'make-trampoline)
849 (compile 'init-fin-fun))
850
851
852 ;; new style
853 #+(and gsgc (not sun4) (not cray) (not mips))
854 (progn
855 ;; set-funcallable-instance-function must work by overwriting the fin itself
856 ;; because the fin must maintain EQ identity.
857 ;; Because the gsgc time needs several of the fields in the function object
858 ;; at gc time in order to walk the stack frame, it is important never to bash
859 ;; a function object that is active in a frame on the stack. Besides, changing
860 ;; the functions closure vector, not to mention overwriting its constant
861 ;; vector, would scramble it's execution when that stack frame continues.
862 ;; Therefore we represent a fin as a funny compiled-function object.
863 ;; The code vector of this object has some hand-coded instructions which
864 ;; do a very fast jump into the real fin handler function. The function
865 ;; which is the fin object *never* creates a frame on the stack.
866
867
868 (defun allocate-funcallable-instance-1 ()
869 (let ((fin (compiler::.primcall 'sys::new-function))
870 (init #'init-fin-fun)
871 (mattress-fun #'funcallable-instance-mattress-pad))
872 (setf (excl::fn_symdef fin) 'anonymous-fin)
873 (setf (excl::fn_constant fin) init)
874 (setf (excl::fn_code fin) ; this must be before fn_start
875 (excl::fn_code mattress-fun))
876 (setf (excl::fn_start fin) (excl::fn_start mattress-fun))
877 (setf (excl::fn_flags fin) (logior (excl::fn_flags init)
878 funcallable-instance-flag-bit))
879 (setf (excl::fn_closure fin)
880 (make-array (length funcallable-instance-data)))
881
882 fin))
883
884 ;; This function gets its code vector modified with a hand-coded fast jump
885 ;; to the function that is stored in place of its constant vector.
886 ;; This function is never linked in and never appears on the stack.
887
888 (defun funcallable-instance-mattress-pad ()
889 (declare #.*optimize-speed*)
890 'nil)
891
892 (eval-when (eval)
893 (compile 'funcallable-instance-mattress-pad))
894
895
896 #+(and excl (target-class s))
897 (eval-when (load eval)
898 (let ((codevec (excl::fn_code
899 (symbol-function 'funcallable-instance-mattress-pad))))
900 ;; The entire code vector wants to be:
901 ;; move.l 7(a2),a2 ;#x246a0007
902 ;; jmp 1(a2) ;#x4eea0001
903 (setf (aref codevec 0) #x246a
904 (aref codevec 1) #x0007
905 (aref codevec 2) #x4eea
906 (aref codevec 3) #x0001))
907 )
908
909 #+(and excl (target-class a))
910 (eval-when (load eval)
911 (let ((codevec (excl::fn_code
912 (symbol-function 'funcallable-instance-mattress-pad))))
913 ;; The entire code vector wants to be:
914 ;; l r5,15(r5) ;#x5850500f
915 ;; l r15,11(r5) ;#x58f0500b
916 ;; br r15 ;#x07ff
917 (setf (aref codevec 0) #x5850
918 (aref codevec 1) #x500f
919 (aref codevec 2) #x58f0
920 (aref codevec 3) #x500b
921 (aref codevec 4) #x07ff
922 (aref codevec 5) #x0000))
923 )
924
925 #+(and excl (target-class i))
926 (eval-when (load eval)
927 (let ((codevec (excl::fn_code
928 (symbol-function 'funcallable-instance-mattress-pad))))
929 ;; The entire code vector wants to be:
930 ;; movl 7(edx),edx ;#x07528b
931 ;; jmp *3(edx) ;#x0362ff
932 (setf (aref codevec 0) #x8b
933 (aref codevec 1) #x52
934 (aref codevec 2) #x07
935 (aref codevec 3) #xff
936 (aref codevec 4) #x62
937 (aref codevec 5) #x03))
938 )
939
940 (defun funcallable-instance-data-1 (instance data)
941 (let ((constant (excl::fn_closure instance)))
942 (svref constant (funcallable-instance-data-position data))))
943
944 (defsetf funcallable-instance-data-1 set-funcallable-instance-data-1)
945
946 (defun set-funcallable-instance-data-1 (instance data new-value)
947 (let ((constant (excl::fn_closure instance)))
948 (setf (svref constant (funcallable-instance-data-position data))
949 new-value)))
950
951 (defun set-funcallable-instance-function (fin new-function)
952 (unless (funcallable-instance-p fin)
953 (error "~S is not a funcallable-instance" fin))
954 (unless (functionp new-function)
955 (error "~S is not a function." new-function))
956 (setf (excl::fn_constant fin)
957 (if (excl::function-object-p new-function)
958 new-function
959 ;; The new-function is an interpreted function.
960 ;; Install a trampoline to call the interpreted function.
961 (make-trampoline new-function))))
962
963
964 ) ;; end sun3
965
966
967 #+(and gsgc (or sun4 mips))
968 (progn
969
970 (eval-when (compile load eval)
971 (defconstant funcallable-instance-constant-count 15)
972 )
973
974 (defun allocate-funcallable-instance-1 ()
975 (let ((new-fin (compiler::.primcall
976 'sys::new-function
977 funcallable-instance-constant-count)))
978 ;; Have to set the procedure function to something for two reasons.
979 ;; 1. someone might try to funcall it.
980 ;; 2. the flag bit that says the procedure is a funcallable
981 ;; instance is set by set-funcallable-instance-function.
982 (set-funcallable-instance-function new-fin #'init-fin-fun)
983 new-fin))
984
985 (defun set-funcallable-instance-function (fin new-value)
986 ;; we actually only check for a function object since
987 ;; this is called before the funcallable instance flag is set
988 (unless (excl::function-object-p fin)
989 (error "~S is not a funcallable-instance" fin))
990
991 (cond ((not (functionp new-value))
992 (error "~S is not a function." new-value))
993 ((not (excl::function-object-p new-value))
994 ;; new-value is an interpreted function. Install a
995 ;; trampoline to call the interpreted function.
996 (set-funcallable-instance-function fin (make-trampoline new-value)))
997 ((> (+ (excl::function-constant-count new-value)
998 (length funcallable-instance-data))
999 funcallable-instance-constant-count)
1000 ; can't fit, must trampoline
1001 (set-funcallable-instance-function fin (make-trampoline new-value)))
1002 (t
1003 ;; tack the instance variables at the end of the constant vector
1004
1005 (setf (excl::fn_code fin) ; this must be before fn_start
1006 (excl::fn_code new-value))
1007 (setf (excl::fn_start fin) (excl::fn_start new-value))
1008
1009 (setf (excl::fn_closure fin) (excl::fn_closure new-value))
1010 ; only replace the symdef slot if the new value is an
1011 ; interned symbol or some other object (like a function spec)
1012 (let ((newsym (excl::fn_symdef new-value)))
1013 (excl:if* (and newsym (or (not (symbolp newsym))
1014 (symbol-package newsym)))
1015 then (setf (excl::fn_symdef fin) newsym)))
1016 (setf (excl::fn_formals fin) (excl::fn_formals new-value))
1017 (setf (excl::fn_cframe-size fin) (excl::fn_cframe-size new-value))
1018 (setf (excl::fn_locals fin) (excl::fn_locals new-value))
1019 (setf (excl::fn_flags fin) (logior (excl::fn_flags new-value)
1020 funcallable-instance-flag-bit))
1021
1022 ;; on a sun4 we copy over the constants
1023 (dotimes (i (excl::function-constant-count new-value))
1024 (setf (excl::function-constant fin i)
1025 (excl::function-constant new-value i)))
1026 ;(format t "all done copy from ~s to ~s" new-value fin)
1027 )))
1028
1029 (defmacro funcallable-instance-data-1 (instance data)
1030 `(excl::function-constant ,instance
1031 (- funcallable-instance-constant-count
1032 (funcallable-instance-data-position ,data)
1033 1)))
1034
1035 ) ;; end sun4 or mips
1036
1037 #+(and gsgc cray)
1038 (progn
1039
1040 ;; The cray is like the sun4 in that the constant vector is included in the
1041 ;; function object itself. But a mattress pad must be used anyway, because
1042 ;; the function start address is copied in the symbol object, and cannot be
1043 ;; updated when the fin is changed.
1044 ;; We place the funcallable-instance-function into the first constant slot,
1045 ;; and leave enough constant slots after that for the instance data.
1046
1047 (eval-when (compile load eval)
1048 (defconstant fin-fun-slot 0)
1049 (defconstant fin-instance-data-slot 1)
1050 )
1051
1052
1053 ;; We initialize a fin's procedure function to this because
1054 ;; someone might try to funcall it before it has been set up.
1055 (defun init-fin-fun (&rest ignore)
1056 (declare (ignore ignore))
1057 (called-fin-without-function))
1058
1059 (defun allocate-funcallable-instance-1 ()
1060 (let ((fin (compiler::.primcall 'sys::new-function
1061 (1+ (length funcallable-instance-data))
1062 "funcallable-instance"))
1063 (init #'init-fin-fun)
1064 (mattress-fun #'funcallable-instance-mattress-pad))
1065 (setf (excl::fn_symdef fin) 'anonymous-fin)
1066 (setf (excl::function-constant fin fin-fun-slot) init)
1067 (setf (excl::fn_code fin) ; this must be before fn_start
1068 (excl::fn_code mattress-fun))
1069 (setf (excl::fn_start fin) (excl::fn_start mattress-fun))
1070 (setf (excl::fn_flags fin) (logior (excl::fn_flags init)
1071 funcallable-instance-flag-bit))
1072
1073 fin))
1074
1075 ;; This function gets its code vector modified with a hand-coded fast jump
1076 ;; to the function that is stored in place of its constant vector.
1077 ;; This function is never linked in and never appears on the stack.
1078
1079 (defun funcallable-instance-mattress-pad ()
1080 (declare #.*optimize-speed*)
1081 'nil)
1082
1083 (eval-when (eval)
1084 (compile 'funcallable-instance-mattress-pad)
1085 (compile 'init-fin-fun))
1086
1087 (eval-when (load eval)
1088 (let ((codevec (excl::fn_code
1089 (symbol-function 'funcallable-instance-mattress-pad))))
1090 ;; The entire code vector wants to be:
1091 ;; a1 b77
1092 ;; a2 12,a1
1093 ;; a1 1,a2
1094 ;; b77 a2
1095 ;; b76 a1
1096 ;; j b76
1097 (setf (aref codevec 0) #o024177
1098 (aref codevec 1) #o101200 (aref codevec 2) 12
1099 (aref codevec 3) #o102100 (aref codevec 4) 1
1100 (aref codevec 5) #o025277
1101 (aref codevec 6) #o025176
1102 (aref codevec 7) #o005076
1103 ))
1104 )
1105
1106 (defmacro funcallable-instance-data-1 (instance data)
1107 `(excl::function-constant ,instance
1108 (+ (funcallable-instance-data-position ,data)
1109 fin-instance-dtat-slot)))
1110
1111
1112 (defun set-funcallable-instance-function (fin new-function)
1113 (unless (funcallable-instance-p fin)
1114 (error "~S is not a funcallable-instance" fin))
1115 (unless (functionp new-function)
1116 (error "~S is not a function." new-function))
1117 (setf (excl::function-constant fin fin-fun-slot)
1118 (if (excl::function-object-p new-function)
1119 new-function
1120 ;; The new-function is an interpreted function.
1121 ;; Install a trampoline to call the interpreted function.
1122 (make-trampoline new-function))))
1123
1124 ) ;; end cray
1125
1126 #-gsgc
1127 (progn
1128
1129 (defun allocate-funcallable-instance-1 ()
1130 (let ((new-fin (compiler::.primcall 'sys::new-function)))
1131 ;; Have to set the procedure function to something for two reasons.
1132 ;; 1. someone might try to funcall it.
1133 ;; 2. the flag bit that says the procedure is a funcallable
1134 ;; instance is set by set-funcallable-instance-function.
1135 (set-funcallable-instance-function new-fin #'init-fin-fn)
1136 new-fin))
1137
1138 (defun set-funcallable-instance-function (fin new-value)
1139 ;; we actually only check for a function object since
1140 ;; this is called before the funcallable instance flag is set
1141 (unless (excl::function-object-p fin)
1142 (error "~S is not a funcallable-instance" fin))
1143 (cond ((not (functionp new-value))
1144 (error "~S is not a function." new-value))
1145 ((not (excl::function-object-p new-value))
1146 ;; new-value is an interpreted function. Install a
1147 ;; trampoline to call the interpreted function.
1148 (set-funcallable-instance-function fin (make-trampoline new-value)))
1149 (t
1150 ;; tack the instance variables at the end of the constant vector
1151 (setf (excl::fn_start fin) (excl::fn_start new-value))
1152 (setf (excl::fn_constant fin) (add-instance-vars
1153 (excl::fn_constant new-value)
1154 (excl::fn_constant fin)))
1155 (setf (excl::fn_closure fin) (excl::fn_closure new-value))
1156 ;; In versions prior to 2.0. comment the next line and any other
1157 ;; references to fn_symdef or fn_locals.
1158 (setf (excl::fn_symdef fin) (excl::fn_symdef new-value))
1159 (setf (excl::fn_code fin) (excl::fn_code new-value))
1160 (setf (excl::fn_formals fin) (excl::fn_formals new-value))
1161 (setf (excl::fn_cframe-size fin) (excl::fn_cframe-size new-value))
1162 (setf (excl::fn_locals fin) (excl::fn_locals new-value))
1163 (setf (excl::fn_flags fin) (logior (excl::fn_flags new-value)
1164 funcallable-instance-flag-bit)))))
1165
1166 (defun add-instance-vars (cvec old-cvec)
1167 ;; create a constant vector containing everything in the given constant
1168 ;; vector plus space for the instance variables
1169 (let* ((nconstants (cond (cvec (length (the simple-vector cvec))) (t 0)))
1170 (ndata (length funcallable-instance-data))
1171 (old-cvec-length (if old-cvec (length (the simple-vector old-cvec)) 0))
1172 (new-cvec nil))
1173 (declare (fixnum nconstants ndate old-cvec-length))
1174 (cond ((<= (the fixnum (+ nconstants ndata)) old-cvec-length)
1175 (setq new-cvec old-cvec))
1176 (t
1177 (setq new-cvec (make-array (the fixnum (+ nconstants ndata))))
1178 (when old-cvec
1179 (dotimes (i ndata)
1180 (declare (fixnum i))
1181 (setf (svref new-cvec (- (the fixnum (+ nconstants ndata)) i 1))
1182 (svref old-cvec (- old-cvec-length i 1)))))))
1183
1184 (dotimes (i nconstants) (setf (svref new-cvec i) (svref cvec i)))
1185
1186 new-cvec))
1187
1188 (defun funcallable-instance-data-1 (instance data)
1189 (let ((constant (excl::fn_constant instance)))
1190 (declare (simple-vector constant))
1191 (svref constant (- (the fixnum (length constant))
1192 (the fixnum
1193 (1+ (the fixnum
1194 (funcallable-instance-data-position data))))))))
1195
1196 (defsetf funcallable-instance-data-1 set-funcallable-instance-data-1)
1197
1198 (defun set-funcallable-instance-data-1 (instance data new-value)
1199 (let ((constant (excl::fn_constant instance)))
1200 (setf (svref constant (- (length constant)
1201 (1+ (funcallable-instance-data-position data))))
1202 new-value)))
1203
1204 );end #-gsgc
1205
1206 );end of #+ExCL
1207
1208
1209 ;;;
1210 ;;; In Vaxlisp
1211 ;;; This code was originally written by:
1212 ;;; vanroggen%bach.DEC@DECWRL.DEC.COM
1213 ;;;
1214 #+(and dec vax common)
1215 (progn
1216
1217 ;;; The following works only in Version 2 of VAXLISP, and will have to
1218 ;;; be replaced for later versions.
1219
1220 (defun allocate-funcallable-instance-1 ()
1221 (list 'system::%compiled-closure%
1222 ()
1223 #'(lambda (&rest args)
1224 (declare (ignore args))
1225 (called-fin-without-function))
1226 (make-array (length funcallable-instance-data))))
1227
1228 (proclaim '(inline funcallable-instance-p))
1229 (defun funcallable-instance-p (x)
1230 (and (consp x)
1231 (eq (car x) 'system::%compiled-closure%)
1232 (not (null (cdddr x)))))
1233
1234 (defun set-funcallable-instance-function (fin func)
1235 (cond ((not (funcallable-instance-p fin))
1236 (error "~S is not a funcallable-instance" fin))
1237 ((not (functionp func))
1238 (error "~S is not a function" func))
1239 ((and (consp func) (eq (car func) 'system::%compiled-closure%))
1240 (setf (cadr fin) (cadr func)
1241 (caddr fin) (caddr func)))
1242 (t (set-funcallable-instance-function fin
1243 (make-trampoline func)))))
1244
1245 (defun make-trampoline (function)
1246 #'(lambda (&rest args)
1247 (apply function args)))
1248
1249 (eval-when (eval) (compile 'make-trampoline))
1250
1251 (defmacro funcallable-instance-data-1 (instance data)
1252 `(svref (cadddr ,instance)
1253 (funcallable-instance-data-position ,data)))
1254
1255 );end of Vaxlisp (and dec vax common)
1256
1257
1258 ;;;; Implementation of funcallable instances for CMU Common Lisp:
1259 ;;;
1260 ;;; We represent a FIN like a closure, but the header has a distinct type
1261 ;;; tag. The FIN data slots are stored at the end of a fixed-length closure
1262 ;;; (at FIN-DATA-OFFSET.) When the function is set to a closure that has no
1263 ;;; more than FIN-DATA-OFFSET slots, we can just replace the slots in the FIN
1264 ;;; with the closure slots. If the closure has too many slots, we must
1265 ;;; indirect through a trampoline with a rest arg. For non-closures, we just
1266 ;;; set the function slot.
1267 ;;;
1268 ;;; We can get away with this efficient and relatively simple scheme because
1269 ;;; the compiler currently currently only references closure slots during the
1270 ;;; initial call and on entry into the function. So we don't have to worry
1271 ;;; about bad things happening when the FIN is clobbered (the problem JonL
1272 ;;; flames about somewhere...)
1273 ;;;
1274 ;;; We also stick in a slot for the function name at the end, but before the
1275 ;;; data slots.
1276
1277 #+CMU
1278 (import 'kernel:funcallable-instance-p)
1279
1280 #+CMU
1281 (progn
1282
1283 (eval-when (compile load eval)
1284 ;;; The offset of the function's name & the max number of real closure slots.
1285 ;;;
1286 (defconstant fin-name-slot 14)
1287
1288 ;;; The offset of the data slots.
1289 ;;;
1290 (defconstant fin-data-offset 15))
1291
1292
1293 ;;; ALLOCATE-FUNCALLABLE-INSTANCE-1 -- Interface
1294 ;;;
1295 ;;; Allocate a funcallable instance, setting the function to an error
1296 ;;; function and initializing the data slots to NIL.
1297 ;;;
1298 (defun allocate-funcallable-instance-1 ()
1299 (let* ((len (+ (length funcallable-instance-data) fin-data-offset))
1300 (res (kernel:%make-funcallable-instance
1301 len
1302 #'called-fin-without-function)))
1303 (dotimes (i (length funcallable-instance-data))
1304 (kernel:%set-funcallable-instance-info res (+ i fin-data-offset) nil))
1305 (kernel:%set-funcallable-instance-info res fin-name-slot nil)
1306 res))
1307
1308
1309 ;;; FUNCALLABLE-INSTANCE-P -- Interface
1310 ;;;
1311 ;;; Return true if X is a funcallable instance. This is an interpreter
1312 ;;; stub; the compiler directly implements this function.
1313 ;;;
1314 (defun funcallable-instance-p (x) (funcallable-instance-p x))
1315
1316
1317 ;;; SET-FUNCALLABLE-INSTANCE-FUNCTION -- Interface
1318 ;;;
1319 ;;; Set the function that is called when FIN is called.
1320 ;;;
1321 (defun set-funcallable-instance-function (fin new-value)
1322 (declare (type function new-value))
1323 (assert (funcallable-instance-p fin))
1324 (ecase (kernel:get-type new-value)
1325 (#.vm:closure-header-type
1326 (let ((len (- (kernel:get-closure-length new-value)
1327 (1- vm:closure-info-offset))))
1328 (cond ((> len fin-name-slot)
1329 (set-funcallable-instance-function
1330 fin
1331 #'(lambda (&rest args)
1332 (apply new-value args))))
1333 (t
1334 (dotimes (i fin-data-offset)
1335 (kernel:%set-funcallable-instance-info
1336 fin i
1337 (if (>= i len)
1338 nil
1339 (kernel:%closure-index-ref new-value i))))
1340 (kernel:%set-funcallable-instance-function
1341 fin
1342 (kernel:%closure-function new-value))))))
1343 (#.vm:function-header-type
1344 (kernel:%set-funcallable-instance-function fin new-value)))
1345 new-value)
1346
1347
1348 ;;; FUNCALLABLE-INSTANCE-NAME, SET-FUNCALLABLE-INSTANCE-NAME -- Interface
1349 ;;;
1350 ;;; Read or set the name slot in a funcallable instance.
1351 ;;;
1352 (defun funcallable-instance-name (fin)
1353 (kernel:%closure-index-ref fin fin-name-slot))
1354 ;;;
1355 (defun set-funcallable-instance-name (fin new-value)
1356 (kernel:%set-funcallable-instance-info fin fin-name-slot new-value)
1357 new-value)
1358 ;;;
1359 (defsetf funcallable-instance-name set-funcallable-instance-name)
1360
1361
1362 ;;; FUNCALLABLE-INSTANCE-DATA-1 -- Interface
1363 ;;;
1364 ;;; If the slot is constant, use CLOSURE-REF with the appropriate offset,
1365 ;;; otherwise do a run-time lookup of the slot offset.
1366 ;;;
1367 (defmacro funcallable-instance-data-1 (fin slot)
1368 (if (constantp slot)
1369 `(sys:%primitive c:closure-ref ,fin
1370 (+ (or (position ,slot funcallable-instance-data)
1371 (error "Unknown slot: ~S." ,slot))
1372 fin-data-offset))
1373 (ext:once-only ((n-slot slot))
1374 `(kernel:%closure-index-ref
1375 ,fin
1376 (+ (or (position ,n-slot funcallable-instance-data)
1377 (error "Unknown slot: ~S." ,n-slot))
1378 fin-data-offset)))))
1379 ;;;
1380 (defmacro %set-funcallable-instance-data-1 (fin slot new-value)
1381 (ext:once-only ((n-fin fin)
1382 (n-slot slot)
1383 (n-val new-value))
1384 `(progn
1385 (kernel:%set-funcallable-instance-info
1386 ,n-fin
1387 (+ (or (position ,n-slot funcallable-instance-data)
1388 (error "Unknown slot: ~S." ,n-slot))
1389 fin-data-offset)
1390 ,n-val)
1391 ,n-val)))
1392 ;;;
1393 (defsetf funcallable-instance-data-1 %set-funcallable-instance-data-1)
1394
1395 ); End of #+cmu progn
1396
1397
1398 ;;;
1399 ;;; Kyoto Common Lisp (KCL)
1400 ;;;
1401 ;;; In KCL, compiled functions and compiled closures are defined as c structs.
1402 ;;; This means that in order to access their fields, we have to use C code!
1403 ;;; The C code we call and the lisp interface to it is in the file kcl-low.
1404 ;;; The lisp interface to this code implements accessors to compiled closures
1405 ;;; and compiled functions of about the same level of abstraction as that
1406 ;;; which is used by the other implementation dependent versions of FINs in
1407 ;;; this file.
1408 ;;;
1409
1410 #+(and KCL (not IBCL))
1411 (progn
1412
1413 (defvar *funcallable-instance-marker* (list "Funcallable Instance Marker"))
1414
1415 (defconstant funcallable-instance-closure-size 15)
1416
1417 (defconstant funcallable-instance-closure-size1
1418 (1- funcallable-instance-closure-size))
1419
1420 (defconstant funcallable-instance-available-size
1421 (- funcallable-instance-closure-size1
1422 (length funcallable-instance-data)))
1423
1424 (defmacro funcallable-instance-marker (x)
1425 `(car (cclosure-env-nthcdr funcallable-instance-closure-size1 ,x)))
1426
1427 (defun allocate-funcallable-instance-1 ()
1428 (let ((fin (allocate-funcallable-instance-2))
1429 (env (make-list funcallable-instance-closure-size :initial-element nil)))
1430 (setf (%cclosure-env fin) env)
1431 #+:turbo-closure (si:turbo-closure fin)
1432 (setf (funcallable-instance-marker fin) *funcallable-instance-marker*)
1433 fin))
1434
1435 (defun allocate-funcallable-instance-2 ()
1436 (let ((what-a-dumb-closure-variable ()))
1437 #'(lambda (&rest args)
1438 (declare (ignore args))
1439 (called-fin-without-function)
1440 (setq what-a-dumb-closure-variable
1441 (dummy-function what-a-dumb-closure-variable)))))
1442
1443 (defun funcallable-instance-p (x)
1444 (eq *funcallable-instance-marker* (funcallable-instance-marker x)))
1445
1446 (si:define-compiler-macro funcallable-instance-p (x)
1447 `(eq *funcallable-instance-marker* (funcallable-instance-marker ,x)))
1448
1449 (defun set-funcallable-instance-function (fin new-value)
1450 (cond ((not (funcallable-instance-p fin))
1451 (error "~S is not a funcallable-instance" fin))
1452 ((not (functionp new-value))
1453 (error "~S is not a function." new-value))
1454 ((and (cclosurep new-value)
1455 (<= (the index (length (the list (%cclosure-env new-value))))
1456 (the index funcallable-instance-available-size)))
1457 (%set-cclosure fin new-value funcallable-instance-available-size))
1458 (t
1459 (set-funcallable-instance-function
1460 fin (make-trampoline new-value))))
1461 fin)
1462
1463 (defmacro funcallable-instance-data-1 (fin data &environment env)
1464 ;; The compiler won't expand macros before deciding on optimizations,
1465 ;; so we must do it here.
1466 (let* ((pos-form (macroexpand `(funcallable-instance-data-position ,data)
1467 env))
1468 (index-form (if (constantp pos-form)
1469 (the index
1470 (- (the index funcallable-instance-closure-size)
1471 (the index (eval pos-form))
1472 2))
1473 `(the index
1474 (- (the index funcallable-instance-closure-size)
1475 (the index (funcallable-instance-data-position ,data))
1476 2)))))
1477 `(car (%cclosure-env-nthcdr ,index-form ,fin))))
1478
1479
1480 #+turbo-closure (clines "#define TURBO_CLOSURE")
1481
1482 (clines "
1483 static make_trampoline_internal();
1484 static make_turbo_trampoline_internal();
1485
1486 static object
1487 make_trampoline(function)
1488 object function;
1489 {
1490 vs_push(MMcons(function,Cnil));
1491 #ifdef TURBO_CLOSURE
1492 if(type_of(function)==t_cclosure)
1493 {if(function->cc.cc_turbo==NULL)turbo_closure(function);
1494 vs_head=make_cclosure(make_turbo_trampoline_internal,Cnil,vs_head,Cnil,NULL,0);
1495 return vs_pop;}
1496 #endif
1497 vs_head=make_cclosure(make_trampoline_internal,Cnil,vs_head,Cnil,NULL,0);
1498 return vs_pop;
1499 }
1500
1501 static
1502 make_trampoline_internal(base0)
1503 object *base0;
1504 {super_funcall_no_event(base0[0]->c.c_car);}
1505
1506 static
1507 make_turbo_trampoline_internal(base0)
1508 object *base0;
1509 { object function=base0[0]->c.c_car;
1510 (*function->cc.cc_self)(function->cc.cc_turbo);
1511 }
1512
1513 ")
1514
1515 (defentry make-trampoline (object) (object make_trampoline))
1516 )
1517
1518 #+IBCL
1519 (progn ; From Rainy Day PCL.
1520
1521 (defvar *funcallable-instance-marker* (list "Funcallable Instance Marker"))
1522
1523 (defconstant funcallable-instance-closure-size 15)
1524
1525 (defun allocate-funcallable-instance-1 ()
1526 (let ((fin (allocate-funcallable-instance-2))
1527 (env
1528 (make-list funcallable-instance-closure-size :initial-element nil)))
1529 (set-cclosure-env fin env)
1530 #+:turbo-closure (si:turbo-closure fin)
1531 (dotimes (i (1- funcallable-instance-closure-size)) (pop env))
1532 (setf (car env) *funcallable-instance-marker*)
1533 fin))
1534
1535 (defun allocate-funcallable-instance-2 ()
1536 (let ((what-a-dumb-closure-variable ()))
1537 #'(lambda (&rest args)
1538 (declare (ignore args))
1539 (called-fin-without-function)
1540 (setq what-a-dumb-closure-variable
1541 (dummy-function what-a-dumb-closure-variable)))))
1542
1543 (defun funcallable-instance-p (x)
1544 (and (cclosurep x)
1545 (let ((env (cclosure-env x)))
1546 (when (listp env)
1547 (dotimes (i (1- funcallable-instance-closure-size)) (pop env))
1548 (eq (car env) *funcallable-instance-marker*)))))
1549
1550 (defun set-funcallable-instance-function (fin new-value)
1551 (cond ((not (funcallable-instance-p fin))
1552 (error "~S is not a funcallable-instance" fin))
1553 ((not (functionp new-value))
1554 (error "~S is not a function." new-value))
1555 ((cclosurep new-value)
1556 (let* ((fin-env (cclosure-env fin))
1557 (new-env (cclosure-env new-value))
1558 (new-env-size (length new-env))
1559 (fin-env-size (- funcallable-instance-closure-size
1560 (length funcallable-instance-data)
1561 1)))
1562 (cond ((<= new-env-size fin-env-size)
1563 (do ((i 0 (+ i 1))
1564 (new-env-tail new-env (cdr new-env-tail))
1565 (fin-env-tail fin-env (cdr fin-env-tail)))
1566 ((= i fin-env-size))
1567 (setf (car fin-env-tail)
1568 (if (< i new-env-size)
1569 (car new-env-tail)
1570 nil)))
1571 (set-cclosure-self fin (cclosure-self new-value))
1572 (set-cclosure-data fin (cclosure-data new-value))
1573 (set-cclosure-start fin (cclosure-start new-value))
1574 (set-cclosure-size fin (cclosure-size new-value)))
1575 (t
1576 (set-funcallable-instance-function
1577 fin
1578 (make-trampoline new-value))))))
1579 ((typep new-value 'compiled-function)
1580 ;; Write NILs into the part of the cclosure environment that is
1581 ;; not being used to store the funcallable-instance-data. Then
1582 ;; copy over the parts of the compiled function that need to be
1583 ;; copied over.
1584 (let ((env (cclosure-env fin)))
1585 (dotimes (i (- funcallable-instance-closure-size
1586 (length funcallable-instance-data)
1587 1))
1588 (setf (car env) nil)
1589 (pop env)))
1590 (set-cclosure-self fin (cfun-self new-value))
1591 (set-cclosure-data fin (cfun-data new-value))
1592 (set-cclosure-start fin (cfun-start new-value))
1593 (set-cclosure-size fin (cfun-size new-value)))
1594 (t
1595 (set-funcallable-instance-function fin
1596 (make-trampoline new-value))))
1597 fin)
1598
1599
1600 (defun make-trampoline (function)
1601 #'(lambda (&rest args)
1602 (apply function args)))
1603
1604 ;; this replaces funcallable-instance-data-1, set-funcallable-instance-data-1
1605 ;; and the defsetf
1606 (defmacro funcallable-instance-data-1 (fin data &environment env)
1607 ;; The compiler won't expand macros before deciding on optimizations,
1608 ;; so we must do it here.
1609 (let* ((pos-form (macroexpand `(funcallable-instance-data-position ,data)
1610 env))
1611 (index-form (if (constantp pos-form)
1612 (- funcallable-instance-closure-size
1613 (eval pos-form)
1614 2)
1615 `(- funcallable-instance-closure-size
1616 (funcallable-instance-data-position ,data)
1617 2))))
1618 #+:turbo-closure `(car (tc-cclosure-env-nthcdr ,index-form ,fin))
1619 #-:turbo-closure `(nth ,index-form (cclosure-env ,fin))))
1620
1621 )
1622
1623
1624 ;;;
1625 ;;; In H.P. Common Lisp
1626 ;;; This code was originally written by:
1627 ;;; kempf@hplabs.hp.com (James Kempf)
1628 ;;; dsouza@hplabs.hp.com (Roy D'Souza)
1629 ;;;
1630 #+HP-HPLabs
1631 (progn
1632
1633 (defmacro fin-closure-size ()`(prim::@* 6 prim::bytes-per-word))
1634
1635 (defmacro fin-set-mem-hword ()
1636 `(prim::@set-mem-hword
1637 (prim::@+ fin (prim::@<< 2 1))
1638 (prim::@+ (prim::@<< 2 8)
1639 (prim::@fundef-info-parms (prim::@fundef-info fundef)))))
1640
1641 (defun allocate-funcallable-instance-1()
1642 (let* ((fundef
1643 #'(lambda (&rest ignore)
1644 (declare (ignore ignore))
1645 (called-fin-without-function)))
1646 (static-link (vector 'lisp::*undefined* NIL NIL NIL NIL NIL))
1647 (fin (prim::@make-fundef (fin-closure-size))))
1648 (fin-set-mem-hword)
1649 (prim::@set-svref fin 2 fundef)
1650 (prim::@set-svref fin 3 static-link)
1651 (prim::@set-svref fin 4 0)
1652 (impl::PlantclosureHook fin)
1653 fin))
1654
1655 (defmacro funcallable-instance-p (possible-fin)
1656 `(= (fin-closure-size) (prim::@header-inf ,possible-fin)))
1657
1658 (defun set-funcallable-instance-function (fin new-function)
1659 (cond ((not (funcallable-instance-p fin))
1660 (error "~S is not a funcallable instance.~%" fin))
1661 ((not (functionp new-function))
1662 (error "~S is not a function." new-function))
1663 (T
1664 (prim::@set-svref fin 2 new-function))))
1665
1666 (defmacro funcallable-instance-data-1 (fin data)
1667 `(prim::@svref (prim::@closure-static-link ,fin)
1668 (+ 2 (funcallable-instance-data-position ,data))))
1669
1670 (defsetf funcallable-instance-data-1 (fin data) (new-value)
1671 `(prim::@set-svref (prim::@closure-static-link ,fin)
1672 (+ (funcallable-instance-data-position ,data) 2)
1673 ,new-value))
1674
1675 (defun funcallable-instance-name (fin)
1676 (prim::@svref (prim::@closure-static-link fin) 1))
1677
1678 (defsetf funcallable-instance-name set-funcallable-instance-name)
1679
1680 (defun set-funcallable-instance-name (fin new-name)
1681 (prim::@set-svref (prim::@closure-static-link fin) 1 new-name))
1682
1683 );end #+HP
1684
1685
1686
1687 ;;;
1688 ;;; In Golden Common Lisp.
1689 ;;; This code was originally written by:
1690 ;;; dan%acorn@Live-Oak.LCS.MIT.edu (Dan Jacobs)
1691 ;;;
1692 ;;; GCLISP supports named structures that are specially marked as funcallable.
1693 ;;; This allows FUNCALLABLE-INSTANCE-P to be a normal structure predicate,
1694 ;;; and allows ALLOCATE-FUNCALLABLE-INSTANCE-1 to be a normal boa-constructor.
1695 ;;;
1696 #+GCLISP
1697 (progn
1698
1699 (defstruct (%funcallable-instance
1700 (:predicate funcallable-instance-p)
1701 (:copier nil)
1702 (:constructor allocate-funcallable-instance-1 ())
1703 (:print-function
1704 (lambda (struct stream depth)
1705 (declare (ignore depth))
1706 (print-object struct stream))))
1707 (function #'(lambda (ignore-this &rest ignore-these-too)
1708 (declare (ignore ignore-this ignore-these-too))
1709 (called-fin-without-function))
1710 :type function)
1711 (%hidden% 'gclisp::funcallable :read-only t)
1712 (data (vector nil nil) :type simple-vector :read-only t))
1713
1714 (proclaim '(inline set-funcallable-instance-function))
1715 (defun set-funcallable-instance-function (fin new-value)
1716 (setf (%funcallable-instance-function fin) new-value))
1717
1718 (defmacro funcallable-instance-data-1 (fin data)
1719 `(svref (%funcallable-instance-data ,fin)
1720 (funcallable-instance-data-position ,data)))
1721
1722 )
1723
1724
1725 ;;;
1726 ;;; Explorer Common Lisp
1727 ;;; This code was originally written by:
1728 ;;; Dussud%Jenner@csl.ti.com
1729 ;;;
1730 #+ti
1731 (progn
1732
1733 #+(or :ti-release-3 (and :ti-release-2 elroy))
1734 (defmacro lexical-closure-environment (l)
1735 `(cdr (si:%make-pointer si:dtp-list
1736 (cdr (si:%make-pointer si:dtp-list ,l)))))
1737
1738 #-(or :ti-release-3 elroy)
1739 (defmacro lexical-closure-environment (l)
1740 `(caar (si:%make-pointer si:dtp-list
1741 (cdr (si:%make-pointer si:dtp-list ,l)))))
1742
1743 (defmacro lexical-closure-function (l)
1744 `(car (si:%make-pointer si:dtp-list ,l)))
1745
1746
1747 (defvar *funcallable-instance-marker* (list "Funcallable Instance Marker"))
1748
1749 (defconstant funcallable-instance-closure-size 15) ; NOTE: In order to avoid
1750 ; hassles with the reader,
1751 (defmacro allocate-funcallable-instance-2 () ; these two 15's are the
1752 (let ((l ())) ; same. Be sure to keep
1753 (dotimes (i 15) ; them consistent.
1754 (push (list (gensym) nil) l))
1755 `(let ,l
1756 #'(lambda (ignore &rest ignore-them-too)
1757 (declare (ignore ignore ignore-them-too))
1758 (called-fin-without-function)
1759 (values . ,(mapcar #'car l))))))
1760
1761 (defun allocate-funcallable-instance-1 ()
1762 (let* ((new-fin (allocate-funcallable-instance-2)))
1763 (setf (car (nthcdr (1- funcallable-instance-closure-size)
1764 (lexical-closure-environment new-fin)))
1765 *funcallable-instance-marker*)
1766 new-fin))
1767
1768 (eval-when (eval) (compile 'allocate-funcallable-instance-1))
1769
1770 (proclaim '(inline funcallable-instance-p))
1771 (defun funcallable-instance-p (x)
1772 (and (typep x #+:ti-release-2 'closure
1773 #+:ti-release-3 'si:lexical-closure)
1774 (let ((env (lexical-closure-environment x)))
1775 (eq (nth (1- funcallable-instance-closure-size) env)
1776 *funcallable-instance-marker*))))
1777
1778 (defun set-funcallable-instance-function (fin new-value)
1779 (cond ((not (funcallable-instance-p fin))
1780 (error "~S is not a funcallable-instance"))
1781 ((not (functionp new-value))
1782 (error "~S is not a function."))
1783 ((typep new-value 'si:lexical-closure)
1784 (let* ((fin-env (lexical-closure-environment fin))
1785 (new-env (lexical-closure-environment new-value))
1786 (new-env-size (length new-env))
1787 (fin-env-size (- funcallable-instance-closure-size
1788 (length funcallable-instance-data)
1789 1)))
1790 (cond ((<= new-env-size fin-env-size)
1791 (do ((i 0 (+ i 1))
1792 (new-env-tail new-env (cdr new-env-tail))
1793 (fin-env-tail fin-env (cdr fin-env-tail)))
1794 ((= i fin-env-size))
1795 (setf (car fin-env-tail)
1796 (if (< i new-env-size)
1797 (car new-env-tail)
1798 nil)))
1799 (setf (lexical-closure-function fin)
1800 (lexical-closure-function new-value)))
1801 (t
1802 (set-funcallable-instance-function
1803 fin
1804 (make-trampoline new-value))))))
1805 (t
1806 (set-funcallable-instance-function fin
1807 (make-trampoline new-value)))))
1808
1809 (defun make-trampoline (function)
1810 (let ((tmp))
1811 #'(lambda (&rest args) tmp
1812 (apply function args))))
1813
1814 (eval-when (eval) (compile 'make-trampoline))
1815
1816 (defmacro funcallable-instance-data-1 (fin data)
1817 `(let ((env (lexical-closure-environment ,fin)))
1818 (nth (- funcallable-instance-closure-size
1819 (funcallable-instance-data-position ,data)
1820 2)
1821 env)))
1822
1823
1824 (defsetf funcallable-instance-data-1 (fin data) (new-value)
1825 `(let ((env (lexical-closure-environment ,fin)))
1826 (setf (car (nthcdr (- funcallable-instance-closure-size
1827 (funcallable-instance-data-position ,data)
1828 2)
1829 env))
1830 ,new-value)))
1831
1832 );end of code for TI
1833
1834
1835 ;;; Implemented by Bein@pyramid -- Tue Aug 25 19:05:17 1987
1836 ;;;
1837 ;;; A FIN is a distinct type of object which FUNCALL,EVAL, and APPLY
1838 ;;; recognize as functions. Both Compiled-Function-P and functionp
1839 ;;; recognize FINs as first class functions.
1840 ;;;
1841 ;;; This does not work with PyrLisp versions earlier than 1.1..
1842
1843 #+pyramid
1844 (progn
1845
1846 (defun make-trampoline (function)
1847 #'(lambda (&rest args) (apply function args)))
1848
1849 (defun un-initialized-fin (&rest trash)
1850 (declare (ignore trash))
1851 (called-fin-without-function))
1852
1853 (eval-when (eval)
1854 (compile 'make-trampoline)
1855 (compile 'un-initialized-fin))
1856
1857 (defun allocate-funcallable-instance-1 ()
1858 (let ((fin (system::alloc-funcallable-instance)))
1859 (system::set-fin-function fin #'un-initialized-fin)
1860 fin))
1861
1862 (defun funcallable-instance-p (object)
1863 (typep object 'lisp::funcallable-instance))
1864
1865 (clc::deftransform funcallable-instance-p trans-fin-p (object)
1866 `(typep ,object 'lisp::funcallable-instance))
1867
1868 (defun set-funcallable-instance-function (fin new-value)
1869 (or (funcallable-instance-p fin)
1870 (error "~S is not a funcallable-instance." fin))
1871 (cond ((not (functionp new-value))
1872 (error "~S is not a function." new-value))
1873 ((not (lisp::compiled-function-p new-value))
1874 (set-funcallable-instance-function fin
1875 (make-trampoline new-value)))
1876 (t
1877 (system::set-fin-function fin new-value))))
1878
1879 (defun funcallable-instance-data-1 (fin data-name)
1880 (system::get-fin-data fin
1881 (funcallable-instance-data-position data-name)))
1882
1883 (defun set-funcallable-instance-data-1 (fin data-name value)
1884 (system::set-fin-data fin
1885 (funcallable-instance-data-position data-name)
1886 value))
1887
1888 (defsetf funcallable-instance-data-1 set-funcallable-instance-data-1)
1889
1890 ); End of #+pyramid
1891
1892
1893 ;;;
1894 ;;; For Coral Lisp
1895 ;;;
1896 #+:coral
1897 (progn
1898
1899 (defconstant ccl::$v_istruct 22)
1900 (defvar ccl::initial-fin-slots (make-list (length funcallable-instance-data)))
1901 (defconstant ccl::fin-function 1)
1902 (defconstant ccl::fin-data (+ ccl::FIN-function 1))
1903
1904 (defun allocate-funcallable-instance-1 ()
1905 (apply #'ccl::%gvector
1906 ccl::$v_istruct
1907 'ccl::funcallable-instance
1908 #'(lambda (&rest ignore)
1909 (declare (ignore ignore))
1910 (called-fin-without-function))
1911 ccl::initial-fin-slots))
1912
1913 #+:ccl-1.3
1914 (eval-when (eval compile load)
1915
1916 ;;; Make uvector-based objects (like funcallable instances) print better.
1917 (defun print-uvector-object (obj stream &optional print-level)
1918 (declare (ignore print-level))
1919 (print-object obj stream))
1920
1921 ;;; Inform the print system about funcallable instance uvectors.
1922 (pushnew (cons 'ccl::funcallable-instance #'print-uvector-object)
1923 ccl:*write-uvector-alist*
1924 :test #'equal)
1925
1926 )
1927
1928 (defun funcallable-instance-p (x)
1929 (and (eq (ccl::%type-of x) 'ccl::internal-structure)
1930 (eq (ccl::%uvref x 0) 'ccl::funcallable-instance)))
1931
1932 (defun set-funcallable-instance-function (fin new-value)
1933 (unless (funcallable-instance-p fin)
1934 (error "~S is not a funcallable-instance." fin))
1935 (unless (functionp new-value)
1936 (error "~S is not a function." new-value))
1937 (ccl::%uvset fin ccl::FIN-function new-value))
1938
1939 (defmacro funcallable-instance-data-1 (fin data-name)
1940 `(ccl::%uvref ,fin
1941 (+ (funcallable-instance-data-position ,data-name)
1942 ccl::FIN-data)))
1943
1944 (defsetf funcallable-instance-data-1 (fin data) (new-value)
1945 `(ccl::%uvset ,fin
1946 (+ (funcallable-instance-data-position ,data) ccl::FIN-data)
1947 ,new-value))
1948
1949 ); End of #+:coral
1950
1951
1952
1953 ;;;; Slightly Higher-Level stuff built on the implementation-dependent stuff.
1954 ;;;
1955 ;;;
1956
1957 (defmacro fsc-instance-p (fin)
1958 `(funcallable-instance-p ,fin))
1959
1960 (defmacro fsc-instance-class (fin)
1961 `(wrapper-class (funcallable-instance-data-1 ,fin 'wrapper)))
1962
1963 (defmacro fsc-instance-wrapper (fin)
1964 `(funcallable-instance-data-1 ,fin 'wrapper))
1965
1966 (defmacro fsc-instance-slots (fin)
1967 `(funcallable-instance-data-1 ,fin 'slots))
1968
1969 (defun allocate-funcallable-instance (wrapper allocate-static-slot-storage-copy)
1970 (declare (type simple-vector allocate-static-slot-storage-copy))
1971 (let ((fin (allocate-funcallable-instance-1))
1972 (slots
1973 (%allocate-static-slot-storage--class
1974 allocate-static-slot-storage-copy)))
1975 (setf (fsc-instance-wrapper fin) wrapper
1976 (fsc-instance-slots fin) slots)
1977 fin))
1978

  ViewVC Help
Powered by ViewVC 1.1.5