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

Contents of /src/pcl/fin.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (hide annotations)
Fri Sep 7 17:39:47 1990 UTC (23 years, 7 months ago) by wlott
Branch: MAIN
Changes since 1.1: +50 -29 lines
Initial CMU version.
1 wlott 1.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 wlott 1.2 (eval-when (compile eval load)
110    
111 wlott 1.1 (defconstant funcallable-instance-data
112     '(wrapper slots)
113     "These are the 'data-slots' which funcallable instances have so that
114     the meta-class funcallable-standard-class can store class, and static
115     slots in them.")
116    
117 wlott 1.2 ); eval-when (compile eval load)
118    
119 wlott 1.1 (defmacro funcallable-instance-data-position (data)
120     (if (and (consp data)
121     (eq (car data) 'quote)
122     (boundp 'funcallable-instance-data))
123     (or (position (cadr data) funcallable-instance-data :test #'eq)
124     (progn
125     (warn "Unknown funcallable-instance data: ~S." (cadr data))
126     `(error "Unknown funcallable-instance data: ~S." ',(cadr data))))
127     `(position ,data funcallable-instance-data :test #'eq)))
128    
129     (defun called-fin-without-function ()
130     (error "Attempt to funcall a funcallable-instance without first~%~
131     setting its funcallable-instance-function."))
132    
133    
134    
135    
136     ;;;
137     ;;; In Lucid Lisp, compiled functions and compiled closures have the same
138     ;;; representation. They are called procedures. A procedure is a basically
139     ;;; just a constants vector, with one slot which points to the CODE. This
140     ;;; means that constants and closure variables are intermixed in the procedure
141     ;;; vector.
142     ;;;
143     ;;; This code was largely written by JonL@Lucid.com. Problems with it should
144     ;;; be referred to him.
145     ;;;
146     #+Lucid
147     (progn
148    
149     (defconstant procedure-is-funcallable-instance-bit-position 10)
150    
151     (defconstant fin-trampoline-fun-index lucid::procedure-literals)
152    
153     (defconstant fin-size (+ fin-trampoline-fun-index
154     (length funcallable-instance-data)
155     1))
156    
157     ;;;
158     ;;; The inner closure of this function will have its code vector replaced
159     ;;; by a hand-coded fast jump to the function that is stored in the
160     ;;; captured-lexical variable. In effect, that code is a hand-
161     ;;; optimized version of the code for this inner closure function.
162     ;;;
163     (defun make-trampoline (function)
164     (declare (optimize (speed 3) (safety 0)))
165     #'(lambda (&rest args)
166     (apply function args)))
167    
168     (eval-when (eval)
169     (compile 'make-trampoline)
170     )
171    
172    
173     (defun binary-assemble (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 (fixnum ncodes))
180     (do ((l codes (cdr l))
181     (i 0 (1+ i)))
182     ((null l) nil)
183     (declare (fixnum 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     #-(or MC68000 SPARC BSP I386 VAX PA)
213     '(0 0 0 0)))
214    
215    
216     (lucid::defsubst funcallable-instance-p (x)
217     (and (lucid::procedurep x)
218     (lucid::logbitp& procedure-is-funcallable-instance-bit-position
219     (lucid::procedure-ref x lucid::procedure-flags))))
220    
221     (lucid::defsubst set-funcallable-instance-p (x)
222     (if (not (lucid::procedurep x))
223     (error "Can't make a non-procedure a fin.")
224     (setf (lucid::procedure-ref x lucid::procedure-flags)
225     (logior (expt 2 procedure-is-funcallable-instance-bit-position)
226     (the fixnum
227     (lucid::procedure-ref x lucid::procedure-flags))))))
228    
229    
230     (defun allocate-funcallable-instance-1 ()
231     #+Prime
232     (declare (notinline lucid::new-procedure)) ;fixes a bug in Prime 1.0 in
233     ;which new-procedure expands
234     ;incorrectly
235     (let ((new-fin (lucid::new-procedure fin-size))
236     (fin-index fin-size))
237     (declare (fixnum fin-index)
238     (type lucid::procedure new-fin))
239     (dotimes (i (length funcallable-instance-data))
240     ;; Initialize the new funcallable-instance. As part of our contract,
241     ;; we have to make sure the initial value of all the funcallable
242     ;; instance data slots is NIL.
243     (decf fin-index)
244     (setf (lucid::procedure-ref new-fin fin-index) nil))
245     ;;
246     ;; "Assemble" the initial function by installing a fast "trampoline" code;
247     ;;
248     (setf (lucid::procedure-ref new-fin lucid::procedure-code)
249     *mattress-pad-code*)
250     ;; Disable argcount checking in the "mattress-pad" code for
251     ;; ports that go through standardized trampolines
252     #+PA (setf (sys:procedure-ref new-fin lucid::procedure-arg-count) -1)
253     #+MIPS (progn
254     (setf (sys:procedure-ref new-fin lucid::procedure-min-args) 0)
255     (setf (sys:procedure-ref new-fin lucid::procedure-max-args)
256     call-arguments-limit))
257     ;; but start out with the function to be run as an error call.
258     (setf (lucid::procedure-ref new-fin fin-trampoline-fun-index)
259     #'called-fin-without-function)
260     ;; Then mark it as a "fin"
261     (set-funcallable-instance-p new-fin)
262     new-fin))
263    
264     (defun set-funcallable-instance-function (fin new-value)
265     (unless (funcallable-instance-p fin)
266     (error "~S is not a funcallable-instance" fin))
267     (if (lucid::procedurep new-value)
268     (progn
269     (setf (lucid::procedure-ref fin fin-trampoline-fun-index) new-value)
270     fin)
271     (progn
272     (unless (functionp new-value)
273     (error "~S is not a function." new-value))
274     ;; 'new-value' is an interpreted function. Install a
275     ;; trampoline to call the interpreted function.
276     (set-funcallable-instance-function fin
277     (make-trampoline new-value)))))
278    
279     (defmacro funcallable-instance-data-1 (instance data)
280     `(lucid::procedure-ref
281     ,instance
282     (the fixnum
283     (- (- fin-size 1)
284     (the fixnum (funcallable-instance-data-position ,data))))))
285    
286     );end of #+Lucid
287    
288    
289     ;;;
290     ;;; In Symbolics Common Lisp, a lexical closure is a pair of an environment
291     ;;; and an ordinary compiled function. The environment is represented as
292     ;;; a CDR-coded list. I know of no way to add a special bit to say that the
293     ;;; closure is a FIN, so for now, closures are marked as FINS by storing a
294     ;;; special marker in the last cell of the environment.
295     ;;;
296     ;;; The new structure of a fin is:
297     ;;; (lex-env lex-fun *marker* fin-data0 fin-data1)
298     ;;; The value returned by allocate is a lexical-closure pointing to the start
299     ;;; of the fin list. Benefits are: no longer ever have to copy environments,
300     ;;; fins can be much smaller (5 words instead of 18), old environments never
301     ;;; get destroyed (so running dcodes dont have the lex env change from under
302     ;;; them any longer).
303     ;;;
304     ;;; Most of the fin operations speed up a little (by as much as 30% on a
305     ;;; 3650), at least one nasty bug is fixed, and so far at least I've not
306     ;;; seen any problems at all with this code. - mike thome (mthome@bbn.com)
307     ;;;
308     #+Genera
309     (progn
310    
311     (defvar *funcallable-instance-marker* (list "Funcallable Instance Marker"))
312    
313     (defun allocate-funcallable-instance-1 ()
314     (let* ((whole-fin (make-list (+ 3 (length funcallable-instance-data))))
315     (new-fin (sys:%make-pointer-offset sys:dtp-lexical-closure
316     whole-fin
317     0)))
318     ;;
319     ;; note that we DO NOT turn the real lex-closure part of the fin into
320     ;; a dotted pair, because (1) the machine doesn't care and (2) if we
321     ;; did the garbage collector would reclaim everything after the lexical
322     ;; function.
323     ;;
324     (setf (sys:%p-contents-offset new-fin 2) *funcallable-instance-marker*)
325     (setf (si:lexical-closure-function new-fin)
326     #'(lambda (ignore &rest ignore-them-too)
327     (declare (ignore ignore ignore-them-too))
328     (called-fin-without-function)))
329     #+ignore
330     (setf (si:lexical-closure-environment new-fin) nil)
331     new-fin))
332    
333     (scl:defsubst funcallable-instance-p (x)
334     (declare (inline si:lexical-closure-p))
335     (and (si:lexical-closure-p x)
336     (= (sys:%p-cdr-code (sys:%make-pointer-offset sys:dtp-compiled-function x 1))
337     sys:cdr-next)
338     (eq (sys:%p-contents-offset x 2) *funcallable-instance-marker*)))
339    
340     (defun set-funcallable-instance-function (fin new-value)
341     (cond ((not (funcallable-instance-p fin))
342     (error "~S is not a funcallable-instance" fin))
343     ((not (or (functionp new-value)
344     (and (consp new-value)
345     (eq (car new-value) 'si:digested-lambda))))
346     (error "~S is not a function." new-value))
347     ((and (si:lexical-closure-p new-value)
348     (compiled-function-p (si:lexical-closure-function new-value)))
349     (let ((env (si:lexical-closure-environment new-value))
350     (fn (si:lexical-closure-function new-value)))
351     ;; we only have to copy the pointers!!
352     (setf (si:lexical-closure-environment fin) env
353     (si:lexical-closure-function fin) fn)
354     ; (dbg:set-env->fin env fin)
355     ))
356     (t
357     (set-funcallable-instance-function fin
358     (make-trampoline new-value)))))
359    
360     (defun make-trampoline (function)
361     #'(lambda (&rest args)
362     (apply function args)))
363    
364     (defmacro funcallable-instance-data-1 (fin data)
365     `(sys:%p-contents-offset ,fin
366     (+ 3 (funcallable-instance-data-position ,data))))
367    
368     (defsetf funcallable-instance-data-1 (fin data) (new-value)
369     `(setf (sys:%p-contents-offset ,fin
370     (+ 3 (funcallable-instance-data-position ,data)))
371     ,new-value))
372    
373     ;;;
374     ;;; Make funcallable instances print out properly.
375     ;;;
376     (defvar *old-print-lexical-closure*)
377    
378     (defvar *print-lexical-closure* nil)
379    
380     (defun pcl-print-lexical-closure (exp stream slashify-p &optional (depth 0))
381     (declare (ignore depth))
382     (if (or (eq *print-lexical-closure* exp)
383     (neq *boot-state* 'complete)
384     (eq (class-of exp) *the-class-t*))
385     (let ((*print-lexical-closure* nil))
386     (funcall *old-print-lexical-closure* exp stream slashify-p))
387     (let ((*print-escape* slashify-p)
388     (*print-lexical-closure* exp))
389     (print-object exp stream))))
390    
391     (eval-when (load eval)
392     (unless (boundp '*old-print-lexical-closure*)
393     (setq *old-print-lexical-closure* #'si:print-lexical-closure)
394     (setf (symbol-function 'si:print-lexical-closure)
395     'pcl-print-lexical-closure)))
396    
397    
398     );end of #+Genera
399    
400    
401    
402     ;;;
403     ;;;
404     ;;; In Xerox Common Lisp, a lexical closure is a pair of an environment and
405     ;;; CCODEP. The environment is represented as a block. There is space in
406     ;;; the top 8 bits of the pointers to the CCODE and the environment to use
407     ;;; to mark the closure as being a FIN.
408     ;;;
409     ;;; To help the debugger figure out when it has found a FIN on the stack, we
410     ;;; reserve the last element of the closure environment to use to point back
411     ;;; to the actual fin.
412     ;;;
413     ;;; Note that there is code in xerox-low which lets us access the fields of
414     ;;; compiled-closures and which defines the closure-overlay record. That
415     ;;; code is there because there are some clients of it in that file.
416     ;;;
417     #+Xerox
418     (progn
419    
420     ;; Don't be fooled. We actually allocate one bigger than this to have a place
421     ;; to store the backpointer to the fin. -smL
422     (defconstant funcallable-instance-closure-size 15)
423    
424     ;; This is only used in the file PCL-ENV.
425     (defvar *fin-env-type*
426     (type-of (il:\\allocblock (1+ funcallable-instance-closure-size) t)))
427    
428     ;; Well, Gregor may be too proud to hack xpointers, but bvm and I aren't. -smL
429    
430     (defstruct fin-env-pointer
431     (pointer nil :type il:fullxpointer))
432    
433     (defun fin-env-fin (fin-env)
434     (fin-env-pointer-pointer
435     (il:\\getbaseptr fin-env (* funcallable-instance-closure-size 2))))
436    
437     (defun |set fin-env-fin| (fin-env new-value)
438     (il:\\rplptr fin-env (* funcallable-instance-closure-size 2)
439     (make-fin-env-pointer :pointer new-value))
440     new-value)
441    
442     (defsetf fin-env-fin |set fin-env-fin|)
443    
444     ;; The finalization function that will clean up the backpointer from the
445     ;; fin-env to the fin. This needs to be careful to not cons at all. This
446     ;; depends on there being no other finalization function on compiled-closures,
447     ;; since there is only one finalization function per datatype. Too bad. -smL
448     (defun finalize-fin (fin)
449     ;; This could use the fn funcallable-instance-p, but if we get here we know
450     ;; that this is a closure, so we can skip that test.
451     (when (il:fetch (closure-overlay funcallable-instance-p) il:of fin)
452     (let ((env (il:fetch (il:compiled-closure il:environment) il:of fin)))
453     (when env
454     (setq env
455     (il:\\getbaseptr env (* funcallable-instance-closure-size 2)))
456     (when (il:typep env 'fin-env-pointer)
457     (setf (fin-env-pointer-pointer env) nil)))))
458     nil) ;Return NIL so GC can proceed
459    
460     (eval-when (load)
461     ;; Install the above finalization function.
462     (when (fboundp 'finalize-fin)
463     (il:\\set.finalization.function 'il:compiled-closure 'finalize-fin)))
464    
465     (defun allocate-funcallable-instance-1 ()
466     (let* ((env (il:\\allocblock (1+ funcallable-instance-closure-size) t))
467     (fin (il:make-compiled-closure nil env)))
468     (setf (fin-env-fin env) fin)
469     (il:replace (closure-overlay funcallable-instance-p) il:of fin il:with 't)
470     (set-funcallable-instance-function fin
471     #'(lambda (&rest ignore)
472     (declare (ignore ignore))
473     (called-fin-without-function)))
474     fin))
475    
476     (xcl:definline funcallable-instance-p (x)
477     (and (typep x 'il:compiled-closure)
478     (il:fetch (closure-overlay funcallable-instance-p) il:of x)))
479    
480     (defun set-funcallable-instance-function (fin new)
481     (cond ((not (funcallable-instance-p fin))
482     (error "~S is not a funcallable-instance" fin))
483     ((not (functionp new))
484     (error "~S is not a function." new))
485     ((typep new 'il:compiled-closure)
486     (let* ((fin-env
487     (il:fetch (il:compiled-closure il:environment) il:of fin))
488     (new-env
489     (il:fetch (il:compiled-closure il:environment) il:of new))
490     (new-env-size (if new-env (il:\\#blockdatacells new-env) 0))
491     (fin-env-size (- funcallable-instance-closure-size
492     (length funcallable-instance-data))))
493     (cond ((and new-env
494     (<= new-env-size fin-env-size))
495     (dotimes (i fin-env-size)
496     (il:\\rplptr fin-env
497     (* i 2)
498     (if (< i new-env-size)
499     (il:\\getbaseptr new-env (* i 2))
500     nil)))
501     (setf (compiled-closure-fnheader fin)
502     (compiled-closure-fnheader new)))
503     (t
504     (set-funcallable-instance-function
505     fin
506     (make-trampoline new))))))
507     (t
508     (set-funcallable-instance-function fin
509     (make-trampoline new)))))
510    
511     (defun make-trampoline (function)
512     #'(lambda (&rest args)
513     (apply function args)))
514    
515    
516     (defmacro funcallable-instance-data-1 (fin data)
517     `(il:\\getbaseptr (il:fetch (il:compiled-closure il:environment) il:of ,fin)
518     (* (- funcallable-instance-closure-size
519     (funcallable-instance-data-position ,data)
520     1) ;Reserve last element to
521     ;point back to actual FIN!
522     2)))
523    
524     (defsetf funcallable-instance-data-1 (fin data) (new-value)
525     `(il:\\rplptr (il:fetch (il:compiled-closure il:environment) il:of ,fin)
526     (* (- funcallable-instance-closure-size
527     (funcallable-instance-data-position ,data)
528     1)
529     2)
530     ,new-value))
531    
532     );end of #+Xerox
533    
534    
535     ;;;
536     ;;; In Franz Common Lisp ExCL
537     ;;; This code was originally written by:
538     ;;; jkf%franz.uucp@berkeley.edu
539     ;;; and hacked by:
540     ;;; smh%franz.uucp@berkeley.edu
541    
542     #+ExCL
543     (progn
544    
545     (defconstant funcallable-instance-flag-bit #x1)
546    
547     (defun funcallable-instance-p (x)
548     (and (excl::function-object-p x)
549     (eq funcallable-instance-flag-bit
550     (logand (excl::fn_flags x)
551     funcallable-instance-flag-bit))))
552    
553     (defun make-trampoline (function)
554     #'(lambda (&rest args)
555     (apply function args)))
556    
557     ;; We initialize a fin's procedure function to this because
558     ;; someone might try to funcall it before it has been set up.
559     (defun init-fin-fun (&rest ignore)
560     (declare (ignore ignore))
561     (called-fin-without-function))
562    
563    
564     (eval-when (eval)
565     (compile 'make-trampoline)
566     (compile 'init-fin-fun))
567    
568    
569     ;; new style
570     #+(and gsgc (not sun4) (not cray) (not mips))
571     (progn
572     ;; set-funcallable-instance-function must work by overwriting the fin itself
573     ;; because the fin must maintain EQ identity.
574     ;; Because the gsgc time needs several of the fields in the function object
575     ;; at gc time in order to walk the stack frame, it is important never to bash
576     ;; a function object that is active in a frame on the stack. Besides, changing
577     ;; the functions closure vector, not to mention overwriting its constant
578     ;; vector, would scramble it's execution when that stack frame continues.
579     ;; Therefore we represent a fin as a funny compiled-function object.
580     ;; The code vector of this object has some hand-coded instructions which
581     ;; do a very fast jump into the real fin handler function. The function
582     ;; which is the fin object *never* creates a frame on the stack.
583    
584    
585     (defun allocate-funcallable-instance-1 ()
586     (let ((fin (compiler::.primcall 'sys::new-function))
587     (init #'init-fin-fun)
588     (mattress-fun #'funcallable-instance-mattress-pad))
589     (setf (excl::fn_symdef fin) 'anonymous-fin)
590     (setf (excl::fn_constant fin) init)
591     (setf (excl::fn_code fin) ; this must be before fn_start
592     (excl::fn_code mattress-fun))
593     (setf (excl::fn_start fin) (excl::fn_start mattress-fun))
594     (setf (excl::fn_flags fin) (logior (excl::fn_flags init)
595     funcallable-instance-flag-bit))
596     (setf (excl::fn_closure fin)
597     (make-array (length funcallable-instance-data)))
598    
599     fin))
600    
601     ;; This function gets its code vector modified with a hand-coded fast jump
602     ;; to the function that is stored in place of its constant vector.
603     ;; This function is never linked in and never appears on the stack.
604    
605     (defun funcallable-instance-mattress-pad ()
606     (declare (optimize (speed 3) (safety 0)))
607     'nil)
608    
609     (eval-when (eval)
610     (compile 'funcallable-instance-mattress-pad))
611    
612    
613     #+(and excl (target-class s))
614     (eval-when (load eval)
615     (let ((codevec (excl::fn_code
616     (symbol-function 'funcallable-instance-mattress-pad))))
617     ;; The entire code vector wants to be:
618     ;; move.l 7(a2),a2 ;#x246a0007
619     ;; jmp 1(a2) ;#x4eea0001
620     (setf (aref codevec 0) #x246a
621     (aref codevec 1) #x0007
622     (aref codevec 2) #x4eea
623     (aref codevec 3) #x0001))
624     )
625    
626     #+(and excl (target-class a))
627     (eval-when (load eval)
628     (let ((codevec (excl::fn_code
629     (symbol-function 'funcallable-instance-mattress-pad))))
630     ;; The entire code vector wants to be:
631     ;; l r5,15(r5) ;#x5850500f
632     ;; l r15,11(r5) ;#x58f0500b
633     ;; br r15 ;#x07ff
634     (setf (aref codevec 0) #x5850
635     (aref codevec 1) #x500f
636     (aref codevec 2) #x58f0
637     (aref codevec 3) #x500b
638     (aref codevec 4) #x07ff
639     (aref codevec 5) #x0000))
640     )
641    
642     #+(and excl (target-class i))
643     (eval-when (load eval)
644     (let ((codevec (excl::fn_code
645     (symbol-function 'funcallable-instance-mattress-pad))))
646     ;; The entire code vector wants to be:
647     ;; movl 7(edx),edx ;#x07528b
648     ;; jmp *3(edx) ;#x0362ff
649     (setf (aref codevec 0) #x8b
650     (aref codevec 1) #x52
651     (aref codevec 2) #x07
652     (aref codevec 3) #xff
653     (aref codevec 4) #x62
654     (aref codevec 5) #x03))
655     )
656    
657     (defun funcallable-instance-data-1 (instance data)
658     (let ((constant (excl::fn_closure instance)))
659     (svref constant (funcallable-instance-data-position data))))
660    
661     (defsetf funcallable-instance-data-1 set-funcallable-instance-data-1)
662    
663     (defun set-funcallable-instance-data-1 (instance data new-value)
664     (let ((constant (excl::fn_closure instance)))
665     (setf (svref constant (funcallable-instance-data-position data))
666     new-value)))
667    
668     (defun set-funcallable-instance-function (fin new-function)
669     (unless (funcallable-instance-p fin)
670     (error "~S is not a funcallable-instance" fin))
671     (unless (functionp new-function)
672     (error "~S is not a function." new-function))
673     (setf (excl::fn_constant fin)
674     (if (excl::function-object-p new-function)
675     new-function
676     ;; The new-function is an interpreted function.
677     ;; Install a trampoline to call the interpreted function.
678     (make-trampoline new-function))))
679    
680    
681     ) ;; end sun3
682    
683    
684     #+(and gsgc (or sun4 mips))
685     (progn
686    
687     (eval-when (compile load eval)
688     (defconstant funcallable-instance-constant-count 15)
689     )
690    
691     (defun allocate-funcallable-instance-1 ()
692     (let ((new-fin (compiler::.primcall
693     'sys::new-function
694     funcallable-instance-constant-count)))
695     ;; Have to set the procedure function to something for two reasons.
696     ;; 1. someone might try to funcall it.
697     ;; 2. the flag bit that says the procedure is a funcallable
698     ;; instance is set by set-funcallable-instance-function.
699     (set-funcallable-instance-function new-fin #'init-fin-fun)
700     new-fin))
701    
702     (defun set-funcallable-instance-function (fin new-value)
703     ;; we actually only check for a function object since
704     ;; this is called before the funcallable instance flag is set
705     (unless (excl::function-object-p fin)
706     (error "~S is not a funcallable-instance" fin))
707    
708     (cond ((not (functionp new-value))
709     (error "~S is not a function." new-value))
710     ((not (excl::function-object-p new-value))
711     ;; new-value is an interpreted function. Install a
712     ;; trampoline to call the interpreted function.
713     (set-funcallable-instance-function fin (make-trampoline new-value)))
714     ((> (+ (excl::function-constant-count new-value)
715     (length funcallable-instance-data))
716     funcallable-instance-constant-count)
717     ; can't fit, must trampoline
718     (set-funcallable-instance-function fin (make-trampoline new-value)))
719     (t
720     ;; tack the instance variables at the end of the constant vector
721    
722     (setf (excl::fn_code fin) ; this must be before fn_start
723     (excl::fn_code new-value))
724     (setf (excl::fn_start fin) (excl::fn_start new-value))
725    
726     (setf (excl::fn_closure fin) (excl::fn_closure new-value))
727     ; only replace the symdef slot if the new value is an
728     ; interned symbol or some other object (like a function spec)
729     (let ((newsym (excl::fn_symdef new-value)))
730     (excl:if* (and newsym (or (not (symbolp newsym))
731     (symbol-package newsym)))
732     then (setf (excl::fn_symdef fin) newsym)))
733     (setf (excl::fn_formals fin) (excl::fn_formals new-value))
734     (setf (excl::fn_cframe-size fin) (excl::fn_cframe-size new-value))
735     (setf (excl::fn_locals fin) (excl::fn_locals new-value))
736     (setf (excl::fn_flags fin) (logior (excl::fn_flags new-value)
737     funcallable-instance-flag-bit))
738    
739     ;; on a sun4 we copy over the constants
740     (dotimes (i (excl::function-constant-count new-value))
741     (setf (excl::function-constant fin i)
742     (excl::function-constant new-value i)))
743     ;(format t "all done copy from ~s to ~s" new-value fin)
744     )))
745    
746     (defmacro funcallable-instance-data-1 (instance data)
747     `(excl::function-constant ,instance
748     (- funcallable-instance-constant-count
749     (funcallable-instance-data-position ,data)
750     1)))
751    
752     ) ;; end sun4 or mips
753    
754     #+(and gsgc cray)
755     (progn
756    
757     ;; The cray is like the sun4 in that the constant vector is included in the
758     ;; function object itself. But a mattress pad must be used anyway, because
759     ;; the function start address is copied in the symbol object, and cannot be
760     ;; updated when the fin is changed.
761     ;; We place the funcallable-instance-function into the first constant slot,
762     ;; and leave enough constant slots after that for the instance data.
763    
764     (eval-when (compile load eval)
765     (defconstant fin-fun-slot 0)
766     (defconstant fin-instance-data-slot 1)
767     )
768    
769    
770     ;; We initialize a fin's procedure function to this because
771     ;; someone might try to funcall it before it has been set up.
772     (defun init-fin-fun (&rest ignore)
773     (declare (ignore ignore))
774     (called-fin-without-function))
775    
776     (defun allocate-funcallable-instance-1 ()
777     (let ((fin (compiler::.primcall 'sys::new-function
778     (1+ (length funcallable-instance-data))
779     "funcallable-instance"))
780     (init #'init-fin-fun)
781     (mattress-fun #'funcallable-instance-mattress-pad))
782     (setf (excl::fn_symdef fin) 'anonymous-fin)
783     (setf (excl::function-constant fin fin-fun-slot) init)
784     (setf (excl::fn_code fin) ; this must be before fn_start
785     (excl::fn_code mattress-fun))
786     (setf (excl::fn_start fin) (excl::fn_start mattress-fun))
787     (setf (excl::fn_flags fin) (logior (excl::fn_flags init)
788     funcallable-instance-flag-bit))
789    
790     fin))
791    
792     ;; This function gets its code vector modified with a hand-coded fast jump
793     ;; to the function that is stored in place of its constant vector.
794     ;; This function is never linked in and never appears on the stack.
795    
796     (defun funcallable-instance-mattress-pad ()
797     (declare (optimize (speed 3) (safety 0)))
798     'nil)
799    
800     (eval-when (eval)
801     (compile 'funcallable-instance-mattress-pad)
802     (compile 'init-fin-fun))
803    
804     (eval-when (load eval)
805     (let ((codevec (excl::fn_code
806     (symbol-function 'funcallable-instance-mattress-pad))))
807     ;; The entire code vector wants to be:
808     ;; a1 b77
809     ;; a2 12,a1
810     ;; a1 1,a2
811     ;; b77 a2
812     ;; b76 a1
813     ;; j b76
814     (setf (aref codevec 0) #o024177
815     (aref codevec 1) #o101200 (aref codevec 2) 12
816     (aref codevec 3) #o102100 (aref codevec 4) 1
817     (aref codevec 5) #o025277
818     (aref codevec 6) #o025176
819     (aref codevec 7) #o005076
820     ))
821     )
822    
823     (defmacro funcallable-instance-data-1 (instance data)
824     `(excl::function-constant ,instance
825     (+ (funcallable-instance-data-position ,data)
826     fin-instance-dtat-slot)))
827    
828    
829     (defun set-funcallable-instance-function (fin new-function)
830     (unless (funcallable-instance-p fin)
831     (error "~S is not a funcallable-instance" fin))
832     (unless (functionp new-function)
833     (error "~S is not a function." new-function))
834     (setf (excl::function-constant fin fin-fun-slot)
835     (if (excl::function-object-p new-function)
836     new-function
837     ;; The new-function is an interpreted function.
838     ;; Install a trampoline to call the interpreted function.
839     (make-trampoline new-function))))
840    
841     ) ;; end cray
842    
843     #-gsgc
844     (progn
845    
846     (defun allocate-funcallable-instance-1 ()
847     (let ((new-fin (compiler::.primcall 'sys::new-function)))
848     ;; Have to set the procedure function to something for two reasons.
849     ;; 1. someone might try to funcall it.
850     ;; 2. the flag bit that says the procedure is a funcallable
851     ;; instance is set by set-funcallable-instance-function.
852     (set-funcallable-instance-function new-fin #'init-fin-fn)
853     new-fin))
854    
855     (defun set-funcallable-instance-function (fin new-value)
856     ;; we actually only check for a function object since
857     ;; this is called before the funcallable instance flag is set
858     (unless (excl::function-object-p fin)
859     (error "~S is not a funcallable-instance" fin))
860     (cond ((not (functionp new-value))
861     (error "~S is not a function." new-value))
862     ((not (excl::function-object-p new-value))
863     ;; new-value is an interpreted function. Install a
864     ;; trampoline to call the interpreted function.
865     (set-funcallable-instance-function fin (make-trampoline new-value)))
866     (t
867     ;; tack the instance variables at the end of the constant vector
868     (setf (excl::fn_start fin) (excl::fn_start new-value))
869     (setf (excl::fn_constant fin) (add-instance-vars
870     (excl::fn_constant new-value)
871     (excl::fn_constant fin)))
872     (setf (excl::fn_closure fin) (excl::fn_closure new-value))
873     ;; In versions prior to 2.0. comment the next line and any other
874     ;; references to fn_symdef or fn_locals.
875     (setf (excl::fn_symdef fin) (excl::fn_symdef new-value))
876     (setf (excl::fn_code fin) (excl::fn_code new-value))
877     (setf (excl::fn_formals fin) (excl::fn_formals new-value))
878     (setf (excl::fn_cframe-size fin) (excl::fn_cframe-size new-value))
879     (setf (excl::fn_locals fin) (excl::fn_locals new-value))
880     (setf (excl::fn_flags fin) (logior (excl::fn_flags new-value)
881     funcallable-instance-flag-bit)))))
882    
883     (defun add-instance-vars (cvec old-cvec)
884     ;; create a constant vector containing everything in the given constant
885     ;; vector plus space for the instance variables
886     (let* ((nconstants (cond (cvec (length cvec)) (t 0)))
887     (ndata (length funcallable-instance-data))
888     (old-cvec-length (if old-cvec (length old-cvec) 0))
889     (new-cvec nil))
890     (cond ((<= (+ nconstants ndata) old-cvec-length)
891     (setq new-cvec old-cvec))
892     (t
893     (setq new-cvec (make-array (+ nconstants ndata)))
894     (when old-cvec
895     (dotimes (i ndata)
896     (setf (svref new-cvec (- (+ nconstants ndata) i 1))
897     (svref old-cvec (- old-cvec-length i 1)))))))
898    
899     (dotimes (i nconstants) (setf (svref new-cvec i) (svref cvec i)))
900    
901     new-cvec))
902    
903     (defun funcallable-instance-data-1 (instance data)
904     (let ((constant (excl::fn_constant instance)))
905     (svref constant (- (length constant)
906     (1+ (funcallable-instance-data-position data))))))
907    
908     (defsetf funcallable-instance-data-1 set-funcallable-instance-data-1)
909    
910     (defun set-funcallable-instance-data-1 (instance data new-value)
911     (let ((constant (excl::fn_constant instance)))
912     (setf (svref constant (- (length constant)
913     (1+ (funcallable-instance-data-position data))))
914     new-value)))
915    
916     );end #-gsgc
917    
918     );end of #+ExCL
919    
920    
921     ;;;
922     ;;; In Vaxlisp
923     ;;; This code was originally written by:
924     ;;; vanroggen%bach.DEC@DECWRL.DEC.COM
925     ;;;
926     #+(and dec vax common)
927     (progn
928    
929     ;;; The following works only in Version 2 of VAXLISP, and will have to
930     ;;; be replaced for later versions.
931    
932     (defun allocate-funcallable-instance-1 ()
933     (list 'system::%compiled-closure%
934     ()
935     #'(lambda (&rest args)
936     (declare (ignore args))
937     (called-fin-without-function))
938     (make-array (length funcallable-instance-data))))
939    
940     (proclaim '(inline funcallable-instance-p))
941     (defun funcallable-instance-p (x)
942     (and (consp x)
943     (eq (car x) 'system::%compiled-closure%)
944     (not (null (cdddr x)))))
945    
946     (defun set-funcallable-instance-function (fin func)
947     (cond ((not (funcallable-instance-p fin))
948     (error "~S is not a funcallable-instance" fin))
949     ((not (functionp func))
950     (error "~S is not a function" func))
951     ((and (consp func) (eq (car func) 'system::%compiled-closure%))
952     (setf (cadr fin) (cadr func)
953     (caddr fin) (caddr func)))
954     (t (set-funcallable-instance-function fin
955     (make-trampoline func)))))
956    
957     (defun make-trampoline (function)
958     #'(lambda (&rest args)
959     (apply function args)))
960    
961     (eval-when (eval) (compile 'make-trampoline))
962    
963     (defmacro funcallable-instance-data-1 (instance data)
964     `(svref (cadddr ,instance)
965     (funcallable-instance-data-position ,data)))
966    
967     );end of Vaxlisp (and dec vax common)
968    
969    
970     ;;; Implementation of funcallable instances for CMU Common Lisp.
971     ;;;
972 wlott 1.2
973 wlott 1.1 #+:CMU
974     (progn
975    
976 wlott 1.2 (defstruct funcallable-instance-info
977     (function #'(lambda (&rest args) (declare (ignore args))
978     (called-fin-without-function))
979     :type function)
980     (name "Unnamed funcallable instance")
981     . #.funcallable-instance-data)
982    
983     (proclaim '(inline funcallable-instance-info funcallable-instance-p))
984    
985    
986     (defun funcallable-instance-info (fin)
987     (system:find-if-in-closure #'funcallable-instance-info-p fin))
988    
989    
990 wlott 1.1 (defun allocate-funcallable-instance-1 ()
991 wlott 1.2 (let ((info (make-funcallable-instance-info)))
992     #'(lambda (&rest args)
993     (apply (funcallable-instance-info-function info) args))))
994 wlott 1.1
995    
996 wlott 1.2 (defun funcallable-instance-p (thing)
997     (and (functionp thing)
998     (= (kernel:get-type thing) vm:closure-header-type)
999     (funcallable-instance-info thing)
1000     t))
1001 wlott 1.1
1002    
1003 wlott 1.2 (defun set-funcallable-instance-function (fin new-value)
1004     (setf (funcallable-instance-info-function (funcallable-instance-info fin))
1005     new-value))
1006 wlott 1.1
1007 wlott 1.2
1008     (defun funcallable-instance-name (fin)
1009     (funcallable-instance-info-name (funcallable-instance-info fin)))
1010    
1011     (defun set-funcallable-instance-name (fin new-value)
1012     (setf (funcallable-instance-info-name (funcallable-instance-info fin))
1013     new-value))
1014    
1015     (defsetf funcallable-instance-name set-funcallable-instance-name)
1016    
1017    
1018     (defmacro funcallable-instance-data-1 (fin slot)
1019     (unless (and (listp slot) (eq (car slot) 'quote))
1020     (error "Non-constant name for funcallable-instance-data-1: ~S" slot))
1021     `(,(intern (concatenate 'simple-string
1022     "FUNCALLABLE-INSTANCE-INFO-"
1023     (string (cadr slot)))
1024     *the-pcl-package*)
1025     (funcallable-instance-info ,fin)))
1026    
1027 wlott 1.1
1028     ); End of :CMU
1029    
1030    
1031    
1032     ;;;
1033     ;;; Kyoto Common Lisp (KCL)
1034     ;;;
1035     ;;; In KCL, compiled functions and compiled closures are defined as c structs.
1036     ;;; This means that in order to access their fields, we have to use C code!
1037     ;;; The C code we call and the lisp interface to it is in the file kcl-low.
1038     ;;; The lisp interface to this code implements accessors to compiled closures
1039     ;;; and compiled functions of about the same level of abstraction as that
1040     ;;; which is used by the other implementation dependent versions of FINs in
1041     ;;; this file.
1042     ;;;
1043    
1044     #+(or KCL IBCL)
1045     (progn
1046    
1047     (defvar *funcallable-instance-marker* (list "Funcallable Instance Marker"))
1048    
1049     (defconstant funcallable-instance-closure-size 15)
1050    
1051     (defconstant funcallable-instance-closure-size1
1052     (1- funcallable-instance-closure-size))
1053    
1054     (defconstant funcallable-instance-available-size
1055     (- funcallable-instance-closure-size1
1056     (length funcallable-instance-data)))
1057    
1058     (defmacro funcallable-instance-marker (x)
1059     `(car (cclosure-env-nthcdr funcallable-instance-closure-size1 ,x)))
1060    
1061     (defun allocate-funcallable-instance-1 ()
1062     (let ((fin (allocate-funcallable-instance-2))
1063     (env (make-list funcallable-instance-closure-size :initial-element nil)))
1064     (setf (%cclosure-env fin) env)
1065     #+:turbo-closure (si:turbo-closure fin)
1066     (setf (funcallable-instance-marker fin) *funcallable-instance-marker*)
1067     fin))
1068    
1069     (defun allocate-funcallable-instance-2 ()
1070     (let ((what-a-dumb-closure-variable ()))
1071     #'(lambda (&rest args)
1072     (declare (ignore args))
1073     (called-fin-without-function)
1074     (setq what-a-dumb-closure-variable
1075     (dummy-function what-a-dumb-closure-variable)))))
1076    
1077     (defun funcallable-instance-p (x)
1078     (eq *funcallable-instance-marker* (funcallable-instance-marker x)))
1079    
1080     (si:define-compiler-macro funcallable-instance-p (x)
1081     `(eq *funcallable-instance-marker* (funcallable-instance-marker ,x)))
1082    
1083     (defun set-funcallable-instance-function (fin new-value)
1084     (cond ((not (funcallable-instance-p fin))
1085     (error "~S is not a funcallable-instance" fin))
1086     ((not (functionp new-value))
1087     (error "~S is not a function." new-value))
1088     ((and (cclosurep new-value)
1089     (<= (length (%cclosure-env new-value))
1090     funcallable-instance-available-size))
1091     (%set-cclosure fin new-value funcallable-instance-available-size))
1092     (t
1093     (set-funcallable-instance-function
1094     fin (make-trampoline new-value))))
1095     fin)
1096    
1097     (defmacro funcallable-instance-data-1 (fin data &environment env)
1098     ;; The compiler won't expand macros before deciding on optimizations,
1099     ;; so we must do it here.
1100     (let* ((pos-form (macroexpand `(funcallable-instance-data-position ,data)
1101     env))
1102     (index-form (if (constantp pos-form)
1103     (- funcallable-instance-closure-size
1104     (eval pos-form)
1105     2)
1106     `(- funcallable-instance-closure-size
1107     (funcallable-instance-data-position ,data)
1108     2))))
1109     `(car (%cclosure-env-nthcdr ,index-form ,fin))))
1110    
1111    
1112     #+turbo-closure (clines "#define TURBO_CLOSURE")
1113    
1114     (clines "
1115     static make_trampoline_internal();
1116     static make_turbo_trampoline_internal();
1117    
1118     static object
1119     make_trampoline(function)
1120     object function;
1121     {
1122     vs_push(MMcons(function,Cnil));
1123     #ifdef TURBO_CLOSURE
1124     if(type_of(function)==t_cclosure)
1125     {if(function->cc.cc_turbo==NULL)turbo_closure(function);
1126     vs_head=make_cclosure(make_turbo_trampoline_internal,Cnil,vs_head,Cnil,NULL,0);
1127     return vs_pop;}
1128     #endif
1129     vs_head=make_cclosure(make_trampoline_internal,Cnil,vs_head,Cnil,NULL,0);
1130     return vs_pop;
1131     }
1132    
1133     static
1134     make_trampoline_internal(base0)
1135     object *base0;
1136     {super_funcall_no_event(base0[0]->c.c_car);}
1137    
1138     static
1139     make_turbo_trampoline_internal(base0)
1140     object *base0;
1141     { object function=base0[0]->c.c_car;
1142     (*function->cc.cc_self)(function->cc.cc_turbo);
1143     }
1144    
1145     ")
1146    
1147     (defentry make-trampoline (object) (object make_trampoline))
1148     )
1149    
1150    
1151     ;;;
1152     ;;; In H.P. Common Lisp
1153     ;;; This code was originally written by:
1154     ;;; kempf@hplabs.hp.com (James Kempf)
1155     ;;; dsouza@hplabs.hp.com (Roy D'Souza)
1156     ;;;
1157     #+HP-HPLabs
1158     (progn
1159    
1160     (defmacro fin-closure-size ()`(prim::@* 6 prim::bytes-per-word))
1161    
1162     (defmacro fin-set-mem-hword ()
1163     `(prim::@set-mem-hword
1164     (prim::@+ fin (prim::@<< 2 1))
1165     (prim::@+ (prim::@<< 2 8)
1166     (prim::@fundef-info-parms (prim::@fundef-info fundef)))))
1167    
1168     (defun allocate-funcallable-instance-1()
1169     (let* ((fundef
1170     #'(lambda (&rest ignore)
1171     (declare (ignore ignore))
1172     (called-fin-without-function)))
1173     (static-link (vector 'lisp::*undefined* NIL NIL NIL NIL NIL))
1174     (fin (prim::@make-fundef (fin-closure-size))))
1175     (fin-set-mem-hword)
1176     (prim::@set-svref fin 2 fundef)
1177     (prim::@set-svref fin 3 static-link)
1178     (prim::@set-svref fin 4 0)
1179     (impl::PlantclosureHook fin)
1180     fin))
1181    
1182     (defmacro funcallable-instance-p (possible-fin)
1183     `(= (fin-closure-size) (prim::@header-inf ,possible-fin)))
1184    
1185     (defun set-funcallable-instance-function (fin new-function)
1186     (cond ((not (funcallable-instance-p fin))
1187     (error "~S is not a funcallable instance.~%" fin))
1188     ((not (functionp new-function))
1189     (error "~S is not a function." new-function))
1190     (T
1191     (prim::@set-svref fin 2 new-function))))
1192    
1193     (defmacro funcallable-instance-data-1 (fin data)
1194     `(prim::@svref (prim::@closure-static-link ,fin)
1195     (+ 2 (funcallable-instance-data-position ,data))))
1196    
1197     (defsetf funcallable-instance-data-1 (fin data) (new-value)
1198     `(prim::@set-svref (prim::@closure-static-link ,fin)
1199     (+ (funcallable-instance-data-position ,data) 2)
1200     ,new-value))
1201    
1202     (defun funcallable-instance-name (fin)
1203     (prim::@svref (prim::@closure-static-link fin) 1))
1204    
1205     (defsetf funcallable-instance-name set-funcallable-instance-name)
1206    
1207     (defun set-funcallable-instance-name (fin new-name)
1208     (prim::@set-svref (prim::@closure-static-link fin) 1 new-name))
1209    
1210     );end #+HP
1211    
1212    
1213    
1214     ;;;
1215     ;;; In Golden Common Lisp.
1216     ;;; This code was originally written by:
1217     ;;; dan%acorn@Live-Oak.LCS.MIT.edu (Dan Jacobs)
1218     ;;;
1219     ;;; GCLISP supports named structures that are specially marked as funcallable.
1220     ;;; This allows FUNCALLABLE-INSTANCE-P to be a normal structure predicate,
1221     ;;; and allows ALLOCATE-FUNCALLABLE-INSTANCE-1 to be a normal boa-constructor.
1222     ;;;
1223     #+GCLISP
1224     (progn
1225    
1226     (defstruct (%funcallable-instance
1227     (:predicate funcallable-instance-p)
1228     (:copier nil)
1229     (:constructor allocate-funcallable-instance-1 ())
1230     (:print-function
1231     (lambda (struct stream depth)
1232     (declare (ignore depth))
1233     (print-object struct stream))))
1234     (function #'(lambda (ignore-this &rest ignore-these-too)
1235     (declare (ignore ignore-this ignore-these-too))
1236     (called-fin-without-function))
1237     :type function)
1238     (%hidden% 'gclisp::funcallable :read-only t)
1239     (data (vector nil nil) :type simple-vector :read-only t))
1240    
1241     (proclaim '(inline set-funcallable-instance-function))
1242     (defun set-funcallable-instance-function (fin new-value)
1243     (setf (%funcallable-instance-function fin) new-value))
1244    
1245     (defmacro funcallable-instance-data-1 (fin data)
1246     `(svref (%funcallable-instance-data ,fin)
1247     (funcallable-instance-data-position ,data)))
1248    
1249     )
1250    
1251    
1252     ;;;
1253     ;;; Explorer Common Lisp
1254     ;;; This code was originally written by:
1255     ;;; Dussud%Jenner@csl.ti.com
1256     ;;;
1257     #+ti
1258     (progn
1259    
1260     #+(or :ti-release-3 (and :ti-release-2 elroy))
1261     (defmacro lexical-closure-environment (l)
1262     `(cdr (si:%make-pointer si:dtp-list
1263     (cdr (si:%make-pointer si:dtp-list ,l)))))
1264    
1265     #-(or :ti-release-3 elroy)
1266     (defmacro lexical-closure-environment (l)
1267     `(caar (si:%make-pointer si:dtp-list
1268     (cdr (si:%make-pointer si:dtp-list ,l)))))
1269    
1270     (defmacro lexical-closure-function (l)
1271     `(car (si:%make-pointer si:dtp-list ,l)))
1272    
1273    
1274     (defvar *funcallable-instance-marker* (list "Funcallable Instance Marker"))
1275    
1276     (defconstant funcallable-instance-closure-size 15) ; NOTE: In order to avoid
1277     ; hassles with the reader,
1278     (defmacro allocate-funcallable-instance-2 () ; these two 15's are the
1279     (let ((l ())) ; same. Be sure to keep
1280     (dotimes (i 15) ; them consistent.
1281     (push (list (gensym) nil) l))
1282     `(let ,l
1283     #'(lambda (ignore &rest ignore-them-too)
1284     (declare (ignore ignore ignore-them-too))
1285     (called-fin-without-function)
1286     (values . ,(mapcar #'car l))))))
1287    
1288     (defun allocate-funcallable-instance-1 ()
1289     (let* ((new-fin (allocate-funcallable-instance-2)))
1290     (setf (car (nthcdr (1- funcallable-instance-closure-size)
1291     (lexical-closure-environment new-fin)))
1292     *funcallable-instance-marker*)
1293     new-fin))
1294    
1295     (eval-when (eval) (compile 'allocate-funcallable-instance-1))
1296    
1297     (proclaim '(inline funcallable-instance-p))
1298     (defun funcallable-instance-p (x)
1299     (and (typep x #+:ti-release-2 'closure
1300     #+:ti-release-3 'si:lexical-closure)
1301     (let ((env (lexical-closure-environment x)))
1302     (eq (nth (1- funcallable-instance-closure-size) env)
1303     *funcallable-instance-marker*))))
1304    
1305     (defun set-funcallable-instance-function (fin new-value)
1306     (cond ((not (funcallable-instance-p fin))
1307     (error "~S is not a funcallable-instance"))
1308     ((not (functionp new-value))
1309     (error "~S is not a function."))
1310     ((typep new-value 'si:lexical-closure)
1311     (let* ((fin-env (lexical-closure-environment fin))
1312     (new-env (lexical-closure-environment new-value))
1313     (new-env-size (length new-env))
1314     (fin-env-size (- funcallable-instance-closure-size
1315     (length funcallable-instance-data)
1316     1)))
1317     (cond ((<= new-env-size fin-env-size)
1318     (do ((i 0 (+ i 1))
1319     (new-env-tail new-env (cdr new-env-tail))
1320     (fin-env-tail fin-env (cdr fin-env-tail)))
1321     ((= i fin-env-size))
1322     (setf (car fin-env-tail)
1323     (if (< i new-env-size)
1324     (car new-env-tail)
1325     nil)))
1326     (setf (lexical-closure-function fin)
1327     (lexical-closure-function new-value)))
1328     (t
1329     (set-funcallable-instance-function
1330     fin
1331     (make-trampoline new-value))))))
1332     (t
1333     (set-funcallable-instance-function fin
1334     (make-trampoline new-value)))))
1335    
1336     (defun make-trampoline (function)
1337     (let ((tmp))
1338     #'(lambda (&rest args) tmp
1339     (apply function args))))
1340    
1341     (eval-when (eval) (compile 'make-trampoline))
1342    
1343     (defmacro funcallable-instance-data-1 (fin data)
1344     `(let ((env (lexical-closure-environment ,fin)))
1345     (nth (- funcallable-instance-closure-size
1346     (funcallable-instance-data-position ,data)
1347     2)
1348     env)))
1349    
1350    
1351     (defsetf funcallable-instance-data-1 (fin data) (new-value)
1352     `(let ((env (lexical-closure-environment ,fin)))
1353     (setf (car (nthcdr (- funcallable-instance-closure-size
1354     (funcallable-instance-data-position ,data)
1355     2)
1356     env))
1357     ,new-value)))
1358    
1359     );end of code for TI
1360    
1361    
1362     ;;; Implemented by Bein@pyramid -- Tue Aug 25 19:05:17 1987
1363     ;;;
1364     ;;; A FIN is a distinct type of object which FUNCALL,EVAL, and APPLY
1365     ;;; recognize as functions. Both Compiled-Function-P and functionp
1366     ;;; recognize FINs as first class functions.
1367     ;;;
1368     ;;; This does not work with PyrLisp versions earlier than 1.1..
1369    
1370     #+pyramid
1371     (progn
1372    
1373     (defun make-trampoline (function)
1374     #'(lambda (&rest args) (apply function args)))
1375    
1376     (defun un-initialized-fin (&rest trash)
1377     (declare (ignore trash))
1378     (called-fin-without-function))
1379    
1380     (eval-when (eval)
1381     (compile 'make-trampoline)
1382     (compile 'un-initialized-fin))
1383    
1384     (defun allocate-funcallable-instance-1 ()
1385     (let ((fin (system::alloc-funcallable-instance)))
1386     (system::set-fin-function fin #'un-initialized-fin)
1387     fin))
1388    
1389     (defun funcallable-instance-p (object)
1390     (typep object 'lisp::funcallable-instance))
1391    
1392     (clc::deftransform funcallable-instance-p trans-fin-p (object)
1393     `(typep ,object 'lisp::funcallable-instance))
1394    
1395     (defun set-funcallable-instance-function (fin new-value)
1396     (or (funcallable-instance-p fin)
1397     (error "~S is not a funcallable-instance." fin))
1398     (cond ((not (functionp new-value))
1399     (error "~S is not a function." new-value))
1400     ((not (lisp::compiled-function-p new-value))
1401     (set-funcallable-instance-function fin
1402     (make-trampoline new-value)))
1403     (t
1404     (system::set-fin-function fin new-value))))
1405    
1406     (defun funcallable-instance-data-1 (fin data-name)
1407     (system::get-fin-data fin
1408     (funcallable-instance-data-position data-name)))
1409    
1410     (defun set-funcallable-instance-data-1 (fin data-name value)
1411     (system::set-fin-data fin
1412     (funcallable-instance-data-position data-name)
1413     value))
1414    
1415     (defsetf funcallable-instance-data-1 set-funcallable-instance-data-1)
1416    
1417     ); End of #+pyramid
1418    
1419    
1420     ;;;
1421     ;;; For Coral Lisp
1422     ;;;
1423     #+:coral
1424     (progn
1425    
1426     (defconstant ccl::$v_istruct 22)
1427     (defvar ccl::initial-fin-slots (make-list (length funcallable-instance-data)))
1428     (defconstant ccl::fin-function 1)
1429     (defconstant ccl::fin-data (+ ccl::FIN-function 1))
1430    
1431     (defun allocate-funcallable-instance-1 ()
1432     (apply #'ccl::%gvector
1433     ccl::$v_istruct
1434     'ccl::funcallable-instance
1435     #'(lambda (&rest ignore)
1436     (declare (ignore ignore))
1437     (called-fin-without-function))
1438     ccl::initial-fin-slots))
1439    
1440     ;;; Make uvector-based objects (like funcallable instances) print better.
1441     #+:ccl-1.3
1442     (defun print-uvector-object (obj stream &optional print-level)
1443     (declare (ignore print-level))
1444     (print-object obj stream))
1445    
1446     ;;; Inform the print system about funcallable instance uvectors.
1447     #+:ccl-1.3
1448     (eval-when (eval compile load)
1449     (pushnew (cons 'ccl::funcallable-instance #'print-uvector-object)
1450     ccl:*write-uvector-alist*
1451     :test #'equal))
1452    
1453     (defun funcallable-instance-p (x)
1454     (and (eq (ccl::%type-of x) 'ccl::internal-structure)
1455     (eq (ccl::%uvref x 0) 'ccl::funcallable-instance)))
1456    
1457     (defun set-funcallable-instance-function (fin new-value)
1458     (unless (funcallable-instance-p fin)
1459     (error "~S is not a funcallable-instance." fin))
1460     (unless (functionp new-value)
1461     (error "~S is not a function." new-value))
1462     (ccl::%uvset fin ccl::FIN-function new-value))
1463    
1464     (defmacro funcallable-instance-data-1 (fin data-name)
1465     `(ccl::%uvref ,fin
1466     (+ (funcallable-instance-data-position ,data-name)
1467     ccl::FIN-data)))
1468    
1469     (defsetf funcallable-instance-data-1 (fin data) (new-value)
1470     `(ccl::%uvset ,fin
1471     (+ (funcallable-instance-data-position ,data) ccl::FIN-data)
1472     ,new-value))
1473    
1474     ); End of #+:coral
1475    
1476    
1477    
1478     ;;;; Slightly Higher-Level stuff built on the implementation-dependent stuff.
1479     ;;;
1480     ;;;
1481    
1482     (defmacro fsc-instance-p (fin)
1483     `(funcallable-instance-p ,fin))
1484    
1485     (defmacro fsc-instance-class (fin)
1486     `(wrapper-class (funcallable-instance-data-1 ,fin 'wrapper)))
1487    
1488     (defmacro fsc-instance-wrapper (fin)
1489     `(funcallable-instance-data-1 ,fin 'wrapper))
1490    
1491     (defmacro fsc-instance-slots (fin)
1492     `(funcallable-instance-data-1 ,fin 'slots))
1493    
1494     (defun allocate-funcallable-instance (wrapper number-of-static-slots)
1495     (let ((fin (allocate-funcallable-instance-1))
1496     (slots
1497     (%allocate-static-slot-storage--class number-of-static-slots)))
1498     (setf (fsc-instance-wrapper fin) wrapper
1499     (fsc-instance-slots fin) slots)
1500     fin))

  ViewVC Help
Powered by ViewVC 1.1.5