changes in sbcl-0.9.4 relative to sbcl-0.9.3:
* enhancement: SBCL on MIPS platforms now has a much larger dynamic
space for its heap. (thanks to Thiemo Seufer)
+ * minor incompatible change: eof selects abort in the debugger.
+ * minor incompatible change: *INVOKE-DEBUGGER-HOOK* is run before
+ *DEBUGGER-HOOK* => *DEBUGGER-HOOK* is not run when the debugger
+ is disabled.
+ * minor incompatible change: SB-KERNEL:INSTANCE-LAMBDA is
+ deprecated, and will go away in a future revision of SBCL.
* bug fix: discriminating functions for generic function classes
with non-standard methods for COMPUTE-APPLICABLE-METHODS no longer
make invalid assumptions about method precedence order. (reported
(thanks to Kevin Reid)
* bug fix: complex VOP definitions in "user-space" no longer trigger
package locks. (reported by Zach Beane)
+ * fixed bug 343: SB-KERNEL:INSTANCE-LAMBDA is no longer necessary
+ for funcallable-instance functions, and is no different from
+ regular LAMBDA.
* optimizations: REMOVE-DUPLICATES now runs in linear time on
lists in some cases. This partially fixes bug 384.
* flush all standard streams before prompting in the REPL and the
debugger.
- * minor incompatible change: eof selects abort in the debugger.
- * minor incompatible change: *INVOKE-DEBUGGER-HOOK* is run before
- *DEBUGGER-HOOK* => *DEBUGGER-HOOK* is not run when the debugger
- is disabled.
* threads
** bug fix: RELEASE-FOREGROUND doesn't choke on session lock if
there is only one thread in the session
(case (first object)
((setf)
(fdefinition object))
- ((lambda instance-lambda)
+ ((lambda)
;; FIXME: If we go to a compiler-only implementation, this can
;; become COMPILE instead of EVAL, which seems nicer to me.
(eval `(function ,object)))
+ ((instance-lambda)
+ (deprecation-warning 'instance-lambda 'lambda)
+ (eval `(function ,object)))
(t
(error 'simple-type-error
:datum object
(t
(inst bis alloc-tn fun-pointer-lowtag result)))
(storew temp result 0 fun-pointer-lowtag))
+ (storew result result closure-self-slot fun-pointer-lowtag)
(storew function result closure-fun-slot fun-pointer-lowtag))))
;;; The compiler likes to be able to directly make value cells.
(define-primitive-object (closure :lowtag fun-pointer-lowtag
:widetag closure-header-widetag)
(fun :init :arg :ref-trans %closure-fun)
+ ;; This SELF slot needs explanation.
+ ;;
+ ;; Ordinary closures did not need this slot before version 0.9.3.xx,
+ ;; as the closure object was already in some dedicated register --
+ ;; EAX/RAX on x86(-64), reg_LEXENV on register-rich platforms -- and
+ ;; consequently setting up the environment (from the INFO slot,
+ ;; below) was easy.
+ ;;
+ ;; However, it is not easy to support calling FUNCALLABLE-INSTANCEs
+ ;; in the same way; in a FUNCALLABLE-INSTANCE, there are
+ ;; conceptually two variable-length data areas: the closure
+ ;; environment, if any, and the slots of the instance.
+ ;;
+ ;; Until sbcl-0.9.3.xx, it was required that closures to be set as a
+ ;; FUNCALLABLE-INSTANCE-FUNCTION be defined using the magical
+ ;; keyword SB-KERNEL:INSTANCE-LAMBDA, rather than ordinary LAMBDA;
+ ;; this caused an extra indirection to be compiled into the closure
+ ;; code to load the closure from the FUNCALLABLE-INSTANCE-LEXENV
+ ;; slot before setting up the environment for the function body.
+ ;; Failure to obey this protocol yielded confusing error messages as
+ ;; either INSTANCE-LAMBDAs tried to dereference environments that
+ ;; weren't there, or ordinary LAMBDAs got hold of the LAYOUT and
+ ;; LEXENV slots of a FUNCALLABLE-INSTANCE.
+ ;;
+ ;; By adding this SELF slot, which is at the same offset in a
+ ;; regular CLOSURE as the LEXENV slot is in a FUNCALLABLE-INSTANCE,
+ ;; we enable the extra indirection (VOP FUNCALLABLE-INSTANCE-LEXENV,
+ ;; in src/compiler/ir2tran.lisp) to be compiled unconditionally
+ ;; (provided that we set this slot to the closure object itself).
+ ;; Relative to the code before, this adds a word to the space
+ ;; requirements of a closure, and one instruction (a memory fetch)
+ ;; to the body of a closure function.
+ ;;
+ ;; There are potentially other implementation strategies which would
+ ;; remove the need for this extra indirection in regular closures,
+ ;; such as setting up a trampoline for funcallable instances (though
+ ;; it was not clear to me that there are enough registers free in
+ ;; the x86 backend to permit this). This indirection should not be
+ ;; too disastrous, given that for regular closures the fetch is from
+ ;; memory which is known to be active.
+ ;;
+ ;; CSR, 2005-08-05
+ (self) ; KLUDGE (see above comment)
(info :rest-p t))
(define-primitive-object (funcallable-instance
+;;;; allocation VOPs for the HPPA
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
(in-package "SB!VM")
\f
(inst dep fun-pointer-lowtag 31 3 result)
(inst li (logior (ash (1- size) n-widetag-bits) closure-header-widetag) temp)
(storew temp result 0 fun-pointer-lowtag)))
+ (storew result result closure-self-slot fun-pointer-lowtag)
(storew function result closure-fun-slot fun-pointer-lowtag)))
;;; The compiler likes to be able to directly make value cells.
:source-name source-name
:debug-name debug-name))
((instance-lambda)
- (let ((res (ir1-convert-lambda `(lambda ,@(cdr thing))
- :source-name source-name
- :debug-name debug-name)))
- (setf (getf (functional-plist res) :fin-function) t)
- res))
+ (deprecation-warning 'instance-lambda 'lambda)
+ (ir1-convert-lambda `(lambda ,@(cdr thing))
+ :source-name source-name
+ :debug-name debug-name))
((named-lambda)
(let ((name (cadr thing))
(lambda-expression `(lambda ,@(cddr thing))))
(if (ir2-physenv-closure env)
(let ((closure (make-normal-tn *backend-t-primitive-type*)))
(vop setup-closure-environment node block start-label closure)
- (when (getf (functional-plist ef) :fin-function)
- (vop funcallable-instance-lexenv node block closure closure))
+ ;; KLUDGE: see the comment around the definition of
+ ;; CLOSURE objects in src/compiler/objdef.lisp
+ (vop funcallable-instance-lexenv node block closure closure)
(let ((n -1))
(dolist (loc (ir2-physenv-closure env))
(vop closure-ref node block closure (incf n) (cdr loc)))))
+;;;; allocation VOPs for Mips
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
(in-package "SB!VM")
\f
(pseudo-atomic (pa-flag :extra (pad-data-block size))
(inst or result alloc-tn fun-pointer-lowtag)
(storew temp result 0 fun-pointer-lowtag))
+ (storew result result closure-self-slot fun-pointer-lowtag)
(storew function result closure-fun-slot fun-pointer-lowtag))))
;;; The compiler likes to be able to directly make value cells.
-;;;; allocation VOPs
+;;;; allocation VOPs for the PPC
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
(storew temp result 0 fun-pointer-lowtag)))
;(inst lis temp (ash 18 10))
;(storew temp result closure-jump-insn-slot function-pointer-type)
+ (storew result result closure-self-slot fun-pointer-lowtag)
(storew function result closure-fun-slot fun-pointer-lowtag)))
;;; The compiler likes to be able to directly make value cells.
(inst or result fun-pointer-lowtag)))
(inst li temp (logior (ash (1- size) n-widetag-bits) closure-header-widetag))
(storew temp result 0 fun-pointer-lowtag))
+ (storew result result closure-self-slot fun-pointer-lowtag)
(storew function result closure-fun-slot fun-pointer-lowtag))))
;;; The compiler likes to be able to directly make value cells.
-;;;; allocation VOPs for the x86
+;;;; allocation VOPs for the x86-64
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
(make-ea :byte :base result :disp fun-pointer-lowtag))
(storew (logior (ash (1- size) n-widetag-bits) closure-header-widetag)
result 0 fun-pointer-lowtag))
+ (storew result result closure-self-slot fun-pointer-lowtag)
(loadw temp function closure-fun-slot fun-pointer-lowtag)
(storew temp result closure-fun-slot fun-pointer-lowtag))))
(make-ea :byte :base result :disp fun-pointer-lowtag))
(storew (logior (ash (1- size) n-widetag-bits) closure-header-widetag)
result 0 fun-pointer-lowtag))
+ (storew result result closure-self-slot fun-pointer-lowtag)
(loadw temp function closure-fun-slot fun-pointer-lowtag)
(storew temp result closure-fun-slot fun-pointer-lowtag))))
fin
(or function
(if (eq spec 'print-object)
- #'(instance-lambda (instance stream)
+ #'(lambda (instance stream)
(print-unreadable-object (instance stream :identity t)
(format stream "std-instance")))
- #'(instance-lambda (&rest args)
+ #'(lambda (&rest args)
(declare (ignore args))
(error "The function of the funcallable-instance ~S~
has not been set." fin)))))
(get-instance-hash-code))))
(set-funcallable-instance-function
fin
- #'(instance-lambda (&rest args)
+ #'(lambda (&rest args)
(declare (ignore args))
(error "The function of the funcallable-instance ~S has not been set."
fin)))
(when (or force-p (ctor-class ctor))
(setf (ctor-class ctor) nil)
(setf (funcallable-instance-fun ctor)
- #'(instance-lambda (&rest args)
+ #'(lambda (&rest args)
(install-optimized-constructor ctor)
(apply ctor args)))
(setf (%funcallable-instance-info ctor 1)
;;
;; (except maybe for optimization qualities? -- CSR,
;; 2004-07-12)
+ ;;
+ ;; FIXME: INSTANCE-LAMBDA is no more. We could change this.
(eval `(function ,(constructor-function-form ctor))))))
(defun constructor-function-form (ctor)
(defun fallback-generator (ctor ii-methods si-methods)
(declare (ignore ii-methods si-methods))
- `(instance-lambda ,(make-ctor-parameter-list ctor)
+ `(lambda ,(make-ctor-parameter-list ctor)
;; The CTOR MAKE-INSTANCE optimization only kicks in when the
;; first argument to MAKE-INSTANCE is a constant symbol: by
;; calling it with a class, as here, we inhibit the optimization,
(defun optimizing-generator (ctor ii-methods si-methods)
(multiple-value-bind (body before-method-p)
(fake-initialization-emf ctor ii-methods si-methods)
- `(instance-lambda ,(make-ctor-parameter-list ctor)
+ `(lambda ,(make-ctor-parameter-list ctor)
(declare #.*optimize-speed*)
,(wrap-in-allocate-forms ctor body before-method-p))))
(defun make-initial-dfun (gf)
(let ((initial-dfun
- #'(instance-lambda (&rest args)
+ #'(lambda (&rest args)
(initial-dfun gf args))))
(multiple-value-bind (dfun cache info)
(cond
(let* ((methods (early-gf-methods gf))
(slot-name (early-method-standard-accessor-slot-name (car methods))))
(ecase type
- (reader #'(instance-lambda (instance)
+ (reader #'(lambda (instance)
(let* ((class (class-of instance))
(class-name (!bootstrap-get-slot 'class class 'name)))
(!bootstrap-get-slot class-name instance slot-name))))
- (boundp #'(instance-lambda (instance)
+ (boundp #'(lambda (instance)
(let* ((class (class-of instance))
(class-name (!bootstrap-get-slot 'class class 'name)))
(not (eq +slot-unbound+
(!bootstrap-get-slot class-name
instance slot-name))))))
- (writer #'(instance-lambda (new-value instance)
+ (writer #'(lambda (new-value instance)
(let* ((class (class-of instance))
(class-name (!bootstrap-get-slot 'class class 'name)))
(!bootstrap-set-slot class-name instance slot-name new-value)))))))
specls all-same-p)
(cond ((null methods)
(values
- #'(instance-lambda (&rest args)
+ #'(lambda (&rest args)
(apply #'no-applicable-method gf args))
nil
(no-methods-dfun-info)))
(if function-p
(lambda (method-alist wrappers)
(declare (ignore method-alist wrappers))
- #'(instance-lambda (&rest args)
+ #'(lambda (&rest args)
(apply #'no-applicable-method gf args)))
(lambda (method-alist wrappers)
(declare (ignore method-alist wrappers))
(lambda `(lambda ,closure-variables
,@(when (member 'miss-fn closure-variables)
`((declare (type function miss-fn))))
- #'(instance-lambda ,args
+ #'(lambda ,args
(let ()
(declare #.*optimize-speed*)
,form)))))
(if cached-emf-p
(lambda (cache miss-fn)
(declare (type function miss-fn))
- #'(instance-lambda (&rest args)
+ #'(lambda (&rest args)
(declare #.*optimize-speed*)
(with-dfun-wrappers (args metatypes)
(dfun-wrappers invalid-wrapper-p)
(invoke-emf emf args))))))))
(lambda (cache emf miss-fn)
(declare (type function miss-fn))
- #'(instance-lambda (&rest args)
+ #'(lambda (&rest args)
(declare #.*optimize-speed*)
(with-dfun-wrappers (args metatypes)
(dfun-wrappers invalid-wrapper-p)
(make-dfun-lambda-list metatypes applyp)
(make-fast-method-call-lambda-list metatypes applyp))))
(multiple-value-bind (cfunction constants)
- (get-fun1 `(,(if function-p
- 'instance-lambda
- 'lambda)
+ (get-fun1 `(lambda
,arglist
,@(unless function-p
`((declare (ignore .pv-cell.
--- /dev/null
+;;;; miscellaneous side-effectful tests of the MOP
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+;;; This file contains tests for COMPUTE-DISCRIMINATING-FUNCTION on
+;;; subclasses of generic functions. However, at present it is
+;;; impossible to have more than one of these in the same image,
+;;; because of a vicious metacircle. Once the vicious metacircle is
+;;; dealt with, uncomment the test cases.
+
+(defpackage "MOP-4"
+ (:use "CL" "SB-MOP"))
+
+(in-package "MOP-4")
+
+;;; bug 343
+(defclass my-generic-function1 (standard-generic-function) ()
+ (:metaclass funcallable-standard-class))
+
+(defmethod compute-discriminating-function ((gf my-generic-function1))
+ (let ((dfun (call-next-method)))
+ (lambda (&rest args)
+ (1+ (apply dfun args)))))
+
+(defgeneric foo (x)
+ (:generic-function-class my-generic-function1))
+
+(defmethod foo (x) (+ x x))
+
+(assert (= (foo 5) 11))
+
+#|
+
+;;; from PCL sources
+
+(defmethod compute-discriminating-function ((gf my-generic-function))
+ (let ((std (call-next-method)))
+ (lambda (arg)
+ (print (list 'call-to-gf gf arg))
+ (funcall std arg))))
+
+and
+
+(defmethod compute-discriminating-function ((gf my-generic-function))
+ (lambda (arg)
+ (cond (<some condition>
+ <store some info in the generic function>
+ (set-funcallable-instance-function
+ gf
+ (compute-discriminating-function gf))
+ (funcall gf arg))
+ (t
+ <call-a-method-of-gf>))))
+
+|#
+
+#|
+
+;;; from clisp's test suite
+
+(progn
+ (defclass traced-generic-function (standard-generic-function)
+ ()
+ (:metaclass clos:funcallable-standard-class))
+ (defvar *last-traced-arguments* nil)
+ (defvar *last-traced-values* nil)
+ (defmethod clos:compute-discriminating-function ((gf traced-generic-function)) (let ((orig-df (call-next-method))
+ (name (clos:generic-function-name gf)))
+ #'(lambda (&rest arguments)
+ (declare (compile))
+ (format *trace-output* "~%=> ~S arguments: ~:S" name arguments)
+ (setq *last-traced-arguments* arguments)
+ (let ((values (multiple-value-list (apply orig-df arguments))))
+ (format *trace-output* "~%<= ~S values: ~:S" name values)
+ (setq *last-traced-values* values)
+ (values-list values)))))
+ (defgeneric testgf15 (x) (:generic-function-class traced-generic-function)
+ (:method ((x number)) (values x (- x) (* x x) (/ x))))
+ (testgf15 5)
+ (list *last-traced-arguments* *last-traced-values*))
+
+;;; also we might be in a position to run the "application example"
+;;; from mop.tst in clisp's test suite
+
+|#
+
+(sb-ext:quit :unix-status 104)
--- /dev/null
+;;;; miscellaneous side-effectful tests of the MOP
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+;;; This file contains simple tests for
+;;; SET-FUNCALLABLE-INSTANCE-FUNCTION on FUNCALLABLE-INSTANCEs
+
+
+;;; from Justin Dubs on comp.lang.lisp
+(defclass fn ()
+ ()
+ (:metaclass sb-mop:funcallable-standard-class))
+
+(defvar *fn*)
+
+(defmethod initialize-instance :after ((fn fn) &rest initargs &key
+ &allow-other-keys)
+ (declare (ignore initargs))
+ (sb-mop:set-funcallable-instance-function fn
+ (lambda (x)
+ (setf *fn* fn)
+ (1+ x))))
+
+(let ((fun (make-instance 'fn)))
+ (assert (= (funcall fun 42) 43))
+ (assert (eq *fn* fun)))
+
+;;; from Tony Martinez sbcl-devel
+(defclass counter ()
+ ((number :initarg :start :accessor counter))
+ (:metaclass sb-pcl::funcallable-standard-class))
+
+(defun make-counter (&key (start 0))
+ (let ((instance (make-instance 'counter :start start)))
+ (sb-mop:set-funcallable-instance-function
+ instance
+ ;; When run, this function doesn't print the instance, but (what
+ ;; I think is) itself.
+ (lambda () (print instance)))
+ instance))
+
+(defparameter *counter* (make-counter :start 666))
+
+(assert (eq (funcall *counter*) *counter*))
+
+(sb-ext:quit :unix-status 104)
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.9.3.31"
+"0.9.3.32"
projects / sbcl.git / commitdiff