236 lines
10 KiB
Common Lisp
236 lines
10 KiB
Common Lisp
;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
|
|
|
|
|
|
;;; File converted on 26-Mar-91 10:33:34 from source fin
|
|
;;;. Original source {dsk}<usr>local>users>welch>lisp>clos>rev4>il-format>fin.;3 created 19-Feb-91 16:21:49
|
|
|
|
;;;. Copyright (c) 1991 by Venue
|
|
|
|
|
|
|
|
|
|
(in-package "CLOS")
|
|
|
|
;;; Shadow, Export, Require, Use-package, and Import forms should follow here
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;;
|
|
|
|
|
|
|
|
;;; FUNCALLABLE INSTANCES
|
|
|
|
|
|
|
|
;;
|
|
|
|
|
|
|
|
;;; The first part of the file contains the implementation dependent code to implement funcallable
|
|
;;; instances. Each implementation must provide the following functions and macros:
|
|
;;; ALLOCATE-FUNCALLABLE-INSTANCE-1 () should create and return a new funcallable instance. The
|
|
;;; funcallable-instance-data slots must be initialized to NIL. This is called by
|
|
;;; allocate-funcallable-instance and by the bootstrapping code. FUNCALLABLE-INSTANCE-P (x) the
|
|
;;; obvious predicate. This should be an INLINE function. it must be funcallable, but it would be
|
|
;;; nice if it compiled open. SET-FUNCALLABLE-INSTANCE-FUNCTION (fin new-value) change the fin so
|
|
;;; that when it is funcalled, the new-value function is called. Note that it is legal for
|
|
;;; new-value to be copied before it is installed in the fin, specifically there is no accessor for
|
|
;;; a FIN's function so this function does not have to preserve the actual new value. The new-value
|
|
;;; argument can be any funcallable thing, a closure, lambda compiled code etc. This function must
|
|
;;; coerce those values if necessary. NOTE: new-value is almost always a compiled closure. This is
|
|
;;; the important case to optimize. FUNCALLABLE-INSTANCE-DATA-1 (fin data-name) should return the
|
|
;;; value of the data named data-name in the fin. data-name is one of the symbols in the list which
|
|
;;; is the value of funcallable-instance-data. Since data-name is almost always a quoted symbol and
|
|
;;; funcallable-instance-data is a constant, it is possible (and worthwhile) to optimize the
|
|
;;; computation of data-name's offset in the data part of the fin. This must be SETF'able.
|
|
|
|
|
|
(defconstant funcallable-instance-data '(wrapper slots)
|
|
"These are the 'data-slots' which funcallable instances have so that
|
|
the meta-class funcallable-standard-class can store class, and static
|
|
slots in them.")
|
|
|
|
(defmacro funcallable-instance-data-position (data)
|
|
(if (and (consp data)
|
|
(eq (car data)
|
|
'quote)
|
|
(boundp 'funcallable-instance-data))
|
|
(or (position (cadr data)
|
|
funcallable-instance-data :test #'eq)
|
|
(progn (warn "Unknown funcallable-instance data: ~S." (cadr data))
|
|
`(error "Unknown funcallable-instance data: ~S." ',(cadr data))))
|
|
`(position ,data funcallable-instance-data :test #'eq)))
|
|
|
|
(defun called-fin-without-function nil (error "Attempt to funcall a funcallable-instance without first~%~
|
|
setting its funcallable-instance-function."))
|
|
|
|
|
|
;;; In Xerox Common Lisp, a lexical closure is a pair of an environment and CCODEP. The environment
|
|
;;; is represented as a block. There is space in the top 8 bits of the pointers to the CCODE and
|
|
;;; the environment to use to mark the closure as being a FIN. To help the debugger figure out when
|
|
;;; it has found a FIN on the stack, we reserve the last element of the closure environment to use
|
|
;;; to point back to the actual fin. Note that there is code in xerox-low which lets us access the
|
|
;;; fields of compiled-closures and which defines the closure-overlay record. That code is there
|
|
;;; because there are some clients of it in that file.
|
|
|
|
|
|
|
|
;; Don't be fooled. We actually allocate one bigger than this to have a place to store the
|
|
;; backpointer to the fin. -smL
|
|
|
|
|
|
(defconstant funcallable-instance-closure-size 15)
|
|
|
|
(defvar *fin-env-type* (type-of (il:\\allocblock (1+ funcallable-instance-closure-size)
|
|
t)))
|
|
|
|
|
|
;; Well, Gregor may be too proud to hack xpointers, but bvm and I aren't. -smL
|
|
|
|
|
|
(defstruct fin-env-pointer (pointer nil :type il:fullxpointer))
|
|
|
|
(defun fin-env-fin (fin-env)
|
|
(fin-env-pointer-pointer (il:\\getbaseptr fin-env (* funcallable-instance-closure-size 2))))
|
|
|
|
(defun |set fin-env-fin| (fin-env new-value)
|
|
(il:\\rplptr fin-env (* funcallable-instance-closure-size 2)
|
|
(make-fin-env-pointer :pointer new-value))
|
|
new-value)
|
|
|
|
(defsetf fin-env-fin |set fin-env-fin|)
|
|
|
|
|
|
;; The finalization function that will clean up the backpointer from the fin-env to the fin. This
|
|
;; needs to be careful to not cons at all. This depends on there being no other finalization
|
|
;; function on compiled-closures, since there is only one finalization function per datatype. Too
|
|
;; bad. -smL
|
|
|
|
|
|
(defun finalize-fin (fin)
|
|
|
|
;; This could use the fn funcallable-instance-p, but if we get here we know that this is a
|
|
;; closure, so we can skip that test.
|
|
(when (il:fetch (closure-overlay funcallable-instance-p)
|
|
il:of fin)
|
|
(let ((env (il:fetch (il:compiled-closure il:environment)
|
|
il:of fin)))
|
|
(when env
|
|
(setq env (il:\\getbaseptr env (* funcallable-instance-closure-size 2)))
|
|
(when (typep env 'fin-env-pointer)
|
|
(setf (fin-env-pointer-pointer env)
|
|
nil)))))
|
|
nil)
|
|
|
|
(eval-when (load)
|
|
|
|
;; Install the above finalization function.
|
|
(when (fboundp 'finalize-fin)
|
|
(il:\\set.finalization.function 'il:compiled-closure 'finalize-fin)))
|
|
|
|
(defun allocate-funcallable-instance-1 nil (let* ((env (il:\\allocblock (1+
|
|
funcallable-instance-closure-size
|
|
)
|
|
t))
|
|
(fin (il:make-compiled-closure nil env)))
|
|
(setf (fin-env-fin env)
|
|
fin)
|
|
(il:replace (closure-overlay funcallable-instance-p)
|
|
il:of fin il:with 't)
|
|
(set-funcallable-instance-function
|
|
fin
|
|
#'(lambda (&rest ignore)
|
|
(declare (ignore ignore))
|
|
(called-fin-without-function)))
|
|
fin))
|
|
|
|
(xcl:definline funcallable-instance-p (x)
|
|
(and (typep x 'il:compiled-closure)
|
|
(il:fetch (closure-overlay funcallable-instance-p)
|
|
il:of x)))
|
|
|
|
(defun set-funcallable-instance-function (fin new)
|
|
(cond ((not (funcallable-instance-p fin))
|
|
(error "~S is not a funcallable-instance" fin))
|
|
((not (functionp new))
|
|
(error "~S is not a function." new))
|
|
((typep new 'il:compiled-closure)
|
|
(let* ((fin-env (il:fetch (il:compiled-closure il:environment)
|
|
il:of fin))
|
|
(new-env (il:fetch (il:compiled-closure il:environment)
|
|
il:of new))
|
|
(new-env-size (if new-env
|
|
(il:\\#blockdatacells new-env)
|
|
0))
|
|
(fin-env-size (- funcallable-instance-closure-size (length
|
|
funcallable-instance-data
|
|
))))
|
|
(cond ((and new-env (<= new-env-size fin-env-size))
|
|
(dotimes (i fin-env-size)
|
|
(il:\\rplptr fin-env (* i 2)
|
|
(if (< i new-env-size)
|
|
(il:\\getbaseptr new-env (* i 2))
|
|
nil)))
|
|
(setf (compiled-closure-fnheader fin)
|
|
(compiled-closure-fnheader new)))
|
|
(t (set-funcallable-instance-function fin (make-trampoline new))))))
|
|
(t (set-funcallable-instance-function fin (make-trampoline new)))))
|
|
|
|
(defun make-trampoline (function)
|
|
#'(lambda (&rest args)
|
|
(apply function args)))
|
|
|
|
(defmacro funcallable-instance-data-1 (fin data)
|
|
`(il:\\getbaseptr (il:fetch (il:compiled-closure il:environment)
|
|
il:of
|
|
,fin)
|
|
(* (- funcallable-instance-closure-size (funcallable-instance-data-position
|
|
,data)
|
|
1)
|
|
; Reserve last element to point back to
|
|
; actual FIN!
|
|
2)))
|
|
|
|
(defsetf funcallable-instance-data-1 (fin data)
|
|
(new-value)
|
|
`(il:\\rplptr (il:fetch (il:compiled-closure il:environment)
|
|
il:of
|
|
,fin)
|
|
(* (- funcallable-instance-closure-size (funcallable-instance-data-position
|
|
,data)
|
|
1)
|
|
2)
|
|
,new-value))
|
|
|
|
; end of #+Xerox
|
|
|
|
|
|
|
|
;;;
|
|
|
|
|
|
(defmacro fsc-instance-p (fin)
|
|
`(funcallable-instance-p ,fin))
|
|
|
|
(defmacro fsc-instance-class (fin)
|
|
`(wrapper-class (funcallable-instance-data-1 ,fin 'wrapper)))
|
|
|
|
(defmacro fsc-instance-wrapper (fin)
|
|
`(funcallable-instance-data-1 ,fin 'wrapper))
|
|
|
|
(defmacro fsc-instance-slots (fin)
|
|
`(funcallable-instance-data-1 ,fin 'slots))
|
|
|
|
(defun allocate-funcallable-instance (wrapper number-of-static-slots)
|
|
(let ((fin (allocate-funcallable-instance-1))
|
|
(slots (%allocate-static-slot-storage--class number-of-static-slots)))
|
|
(setf (fsc-instance-wrapper fin)
|
|
wrapper
|
|
(fsc-instance-slots fin)
|
|
slots)
|
|
fin))
|