From ehuelsmann at common-lisp.net Thu Feb 3 22:40:56 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 03 Feb 2011 17:40:56 -0500 Subject: [armedbear-cvs] r13202 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Feb 3 17:40:53 2011 New Revision: 13202 Log: Add some documentation and indicate the direction to work on. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Thu Feb 3 17:40:53 2011 @@ -52,6 +52,50 @@ (in-package #:mop) +;; +;; +;; +;; In order to bootstrap CLOS, first implement the required API as +;; normal functions which only apply to the "root" metaclass +;; STANDARD-CLASS. +;; +;; After putting the normal functions in place, the building blocks +;; are in place to gradually swap the normal functions with +;; generic functions and methods. +;; +;; Some functionality implemented in the temporary regular functions +;; needs to be available later as a method definition to be dispatched +;; to for the STANDARD-CLASS case. To prevent repeated code, the +;; functions are implemented in functions by the same name as the +;; API functions, but with the STD- prefix. +;; +;; When hacking this file, note that some important parts are implemented +;; in the Java world. These Java bits can be found in the files +;; +;; * LispClass.java +;; * SlotClass.java +;; * StandardClass.java +;; * BuiltInClass.java +;; * StandardObject.java +;; * StandardObjectFunctions.java +;; * Layout.java +;; +;; In case of function names, those defined on the Java side can be +;; recognized by their prefixed percent sign. +;; +;; The API functions need to be declaimed NOTINLINE explicitly, because +;; that prevents inlining in the current FASL (which is allowed by the +;; CLHS without the declaration); this is a hard requirement to in order +;; to be able to swap the symbol's function slot with a generic function +;; later on - with it actually being used. +;; +;; +;; +;; ### Note that the "declares all API functions as regular functions" +;; isn't true when I write the above, but it's definitely the target. +;; +;; + (export '(class-precedence-list class-slots)) (defconstant +the-standard-class+ (find-class 'standard-class)) (defconstant +the-structure-class+ (find-class 'structure-class)) From ehuelsmann at common-lisp.net Sat Feb 5 22:58:43 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 05 Feb 2011 17:58:43 -0500 Subject: [armedbear-cvs] r13203 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Feb 5 17:58:42 2011 New Revision: 13203 Log: Create ATOMIC-DEFGENERIC macro, in order to eliminate FMAKUNBOUND calls and the resulting windows where no function is bound to symbols which are the most essential building blocks in CLOS/AMOP. Note: This change should help making CLOS bootstrapping less confusing and less tedious to hack. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sat Feb 5 17:58:42 2011 @@ -470,6 +470,11 @@ (std-compute-class-default-initargs class)) (setf (class-finalized-p class) t)) +(declaim (notinline finalize-inheritance)) +(defun finalize-inheritance (class) + (std-finalize-inheritance class)) + + ;;; Class precedence lists (defun std-compute-class-precedence-list (class) @@ -2249,6 +2254,24 @@ (autocompile fast-function)) ))) +(defmacro atomic-defgeneric (function-name &rest rest) + "Macro to define a generic function and 'swap it into place' after +it's been fully defined with all its methods. + +Note: the user should really use the (:method ..) method description +way of defining methods; there's not much use in atomically defining +generic functions without providing sensible behaviour..." + (let ((temp-sym (gensym))) + `(progn + (defgeneric ,temp-sym , at rest) + (let ((gf (symbol-function ',temp-sym))) + (setf ,(if (and (consp function-name) + (eq (car function-name) 'setf)) + `(get ',(second function-name) 'setf-function) + `(symbol-function ',function-name)) gf) + (%set-generic-function-name gf ',function-name) + gf)))) + (defmacro redefine-class-forwarder (name slot) "Define a generic function on a temporary symbol as an accessor for the slot `slot'. Then, when definition is complete (including @@ -2262,35 +2285,26 @@ (if (consp name) (symbol-name 'set-) "") (symbol-name $name)) - (find-package "SYS"))) - (alternative-name (gensym))) - (if (consp name) - `(progn ;; setter - (defgeneric ,alternative-name (new-value class)) - (defmethod ,alternative-name (new-value (class built-in-class)) - (,%name new-value class)) - (defmethod ,alternative-name (new-value (class forward-referenced-class)) - (,%name new-value class)) - (defmethod ,alternative-name (new-value (class structure-class)) - (,%name new-value class)) - (defmethod ,alternative-name (new-value (class standard-class)) - (setf (slot-value class ',slot) new-value)) - (let ((gf (symbol-function ',alternative-name))) - (setf (get ',$name 'SETF-FUNCTION) gf) - (%set-generic-function-name gf ',name))) - `(progn ;; getter - (defgeneric ,alternative-name (class)) - (defmethod ,alternative-name ((class built-in-class)) - (,%name class)) - (defmethod ,alternative-name ((class forward-referenced-class)) - (,%name class)) - (defmethod ,alternative-name ((class structure-class)) - (,%name class)) - (defmethod ,alternative-name ((class standard-class)) - (slot-value class ',slot)) - (let ((gf (symbol-function ',alternative-name))) - (setf (symbol-function ',$name) gf) - (%set-generic-function-name gf ',name)))))) + (find-package "SYS")))) + `(atomic-defgeneric ,name (;; splice a new-value parameter for setters + ,@(when (consp name) (list 'new-value)) + class) + ,@(mapcar (if (consp name) + #'(lambda (class-name) + `(:method (new-value (class ,class-name)) + (,%name new-value class))) + #'(lambda (class-name) + `(:method ((class ,class-name)) + (,%name class)))) + '(built-in-class + forward-referenced-class + structure-class)) + (:method (,@(when (consp name) (list 'new-value)) + (class standard-class)) + ,(if (consp name) + `(setf (slot-value class ',slot) new-value) + `(slot-value class ',slot)))))) + (redefine-class-forwarder class-name name) (redefine-class-forwarder (setf class-name) name) @@ -2327,22 +2341,18 @@ (declare (ignore initargs)) +the-effective-slot-definition-class+) -(fmakunbound 'documentation) -(defgeneric documentation (x doc-type)) - -(defgeneric (setf documentation) (new-value x doc-type)) +(atomic-defgeneric documentation (x doc-type) + (:method ((x symbol) doc-type) + (%documentation x doc-type)) + (:method ((x function) doc-type) + (%documentation x doc-type))) + +(atomic-defgeneric (setf documentation) (new-value x doc-type) + (:method (new-value (x symbol) doc-type) + (%set-documentation x doc-type new-value)) + (:method (new-value (x function) doc-type) + (%set-documentation x doc-type new-value))) -(defmethod documentation ((x symbol) doc-type) - (%documentation x doc-type)) - -(defmethod (setf documentation) (new-value (x symbol) doc-type) - (%set-documentation x doc-type new-value)) - -(defmethod documentation ((x function) doc-type) - (%documentation x doc-type)) - -(defmethod (setf documentation) (new-value (x function) doc-type) - (%set-documentation x doc-type new-value)) ;; FIXME This should be a weak hashtable! (defvar *list-documentation-hashtable* (make-hash-table :test #'equal)) @@ -2750,10 +2760,9 @@ ;;; Finalize inheritance -(defgeneric finalize-inheritance (class)) - -(defmethod finalize-inheritance ((class standard-class)) - (std-finalize-inheritance class)) +(atomic-defgeneric finalize-inheritance (class) + (:method ((class standard-class)) + (std-finalize-inheritance class))) ;;; Class precedence lists @@ -2801,19 +2810,6 @@ ;;; Slot definition accessors -(map nil (lambda (sym) - (fmakunbound sym) ;;we need to redefine them as GFs - (fmakunbound `(setf ,sym)) - (export sym)) - '(slot-definition-allocation - slot-definition-initargs - slot-definition-initform - slot-definition-initfunction - slot-definition-name - slot-definition-readers - slot-definition-writers - slot-definition-allocation-class)) - (defmacro slot-definition-dispatch (slot-definition std-form generic-form) `(let (($cl (class-of ,slot-definition))) (case $cl @@ -2823,109 +2819,110 @@ ,std-form) (t ,generic-form)))) -(defgeneric slot-definition-allocation (slot-definition) +(atomic-defgeneric slot-definition-allocation (slot-definition) (:method ((slot-definition slot-definition)) (slot-definition-dispatch slot-definition (%slot-definition-allocation slot-definition) (slot-value slot-definition 'sys::allocation)))) -(defgeneric (setf slot-definition-allocation) (value slot-definition) +(atomic-defgeneric (setf slot-definition-allocation) (value slot-definition) (:method (value (slot-definition slot-definition)) (slot-definition-dispatch slot-definition (set-slot-definition-allocation slot-definition value) (setf (slot-value slot-definition 'sys::allocation) value)))) -(defgeneric slot-definition-initargs (slot-definition) +(atomic-defgeneric slot-definition-initargs (slot-definition) (:method ((slot-definition slot-definition)) (slot-definition-dispatch slot-definition (%slot-definition-initargs slot-definition) (slot-value slot-definition 'sys::initargs)))) -(defgeneric (setf slot-definition-initargs) (value slot-definition) +(atomic-defgeneric (setf slot-definition-initargs) (value slot-definition) (:method (value (slot-definition slot-definition)) (slot-definition-dispatch slot-definition (set-slot-definition-initargs slot-definition value) (setf (slot-value slot-definition 'sys::initargs) value)))) -(defgeneric slot-definition-initform (slot-definition) +(atomic-defgeneric slot-definition-initform (slot-definition) (:method ((slot-definition slot-definition)) (slot-definition-dispatch slot-definition (%slot-definition-initform slot-definition) (slot-value slot-definition 'sys::initform)))) -(defgeneric (setf slot-definition-initform) (value slot-definition) +(atomic-defgeneric (setf slot-definition-initform) (value slot-definition) (:method (value (slot-definition slot-definition)) (slot-definition-dispatch slot-definition (set-slot-definition-initform slot-definition value) (setf (slot-value slot-definition 'sys::initform) value)))) -(defgeneric slot-definition-initfunction (slot-definition) +(atomic-defgeneric slot-definition-initfunction (slot-definition) (:method ((slot-definition slot-definition)) (slot-definition-dispatch slot-definition (%slot-definition-initfunction slot-definition) (slot-value slot-definition 'sys::initfunction)))) -(defgeneric (setf slot-definition-initfunction) (value slot-definition) +(atomic-defgeneric (setf slot-definition-initfunction) (value slot-definition) (:method (value (slot-definition slot-definition)) (slot-definition-dispatch slot-definition (set-slot-definition-initfunction slot-definition value) (setf (slot-value slot-definition 'sys::initfunction) value)))) -(defgeneric slot-definition-name (slot-definition) +(atomic-defgeneric slot-definition-name (slot-definition) (:method ((slot-definition slot-definition)) (slot-definition-dispatch slot-definition (%slot-definition-name slot-definition) (slot-value slot-definition 'sys::name)))) -(defgeneric (setf slot-definition-name) (value slot-definition) +(atomic-defgeneric (setf slot-definition-name) (value slot-definition) (:method (value (slot-definition slot-definition)) (slot-definition-dispatch slot-definition (set-slot-definition-name slot-definition value) (setf (slot-value slot-definition 'sys::name) value)))) -(defgeneric slot-definition-readers (slot-definition) +(atomic-defgeneric slot-definition-readers (slot-definition) (:method ((slot-definition slot-definition)) (slot-definition-dispatch slot-definition (%slot-definition-readers slot-definition) (slot-value slot-definition 'sys::readers)))) -(defgeneric (setf slot-definition-readers) (value slot-definition) +(atomic-defgeneric (setf slot-definition-readers) (value slot-definition) (:method (value (slot-definition slot-definition)) (slot-definition-dispatch slot-definition (set-slot-definition-readers slot-definition value) (setf (slot-value slot-definition 'sys::readers) value)))) -(defgeneric slot-definition-writers (slot-definition) +(atomic-defgeneric slot-definition-writers (slot-definition) (:method ((slot-definition slot-definition)) (slot-definition-dispatch slot-definition (%slot-definition-writers slot-definition) (slot-value slot-definition 'sys::writers)))) -(defgeneric (setf slot-definition-writers) (value slot-definition) +(atomic-defgeneric (setf slot-definition-writers) (value slot-definition) (:method (value (slot-definition slot-definition)) (slot-definition-dispatch slot-definition (set-slot-definition-writers slot-definition value) (setf (slot-value slot-definition 'sys::writers) value)))) -(defgeneric slot-definition-allocation-class (slot-definition) +(atomic-defgeneric slot-definition-allocation-class (slot-definition) (:method ((slot-definition slot-definition)) (slot-definition-dispatch slot-definition (%slot-definition-allocation-class slot-definition) (slot-value slot-definition 'sys::allocation-class)))) -(defgeneric (setf slot-definition-allocation-class) (value slot-definition) +(atomic-defgeneric (setf slot-definition-allocation-class) + (value slot-definition) (:method (value (slot-definition slot-definition)) (slot-definition-dispatch slot-definition (set-slot-definition-allocation-class slot-definition value) (setf (slot-value slot-definition 'sys::allocation-class) value)))) -(defgeneric slot-definition-location (slot-definition) +(atomic-defgeneric slot-definition-location (slot-definition) (:method ((slot-definition slot-definition)) (slot-definition-dispatch slot-definition (%slot-definition-location slot-definition) (slot-value slot-definition 'sys::location)))) -(defgeneric (setf slot-definition-location) (value slot-definition) +(atomic-defgeneric (setf slot-definition-location) (value slot-definition) (:method (value (slot-definition slot-definition)) (slot-definition-dispatch slot-definition (set-slot-definition-location slot-definition value) @@ -3018,13 +3015,15 @@ (let ((message (apply #'format nil format-control args))) (error "Method combination error in CLOS dispatch:~% ~A" message))) -(fmakunbound 'no-applicable-method) -(defgeneric no-applicable-method (generic-function &rest args)) -(defmethod no-applicable-method (generic-function &rest args) - (error "There is no applicable method for the generic function ~S when called with arguments ~S." - generic-function - args)) +(atomic-defgeneric no-applicable-method (generic-function &rest args) + (:method (generic-function &rest args) + (error "There is no applicable method for the generic function ~S ~ + when called with arguments ~S." + generic-function + args))) + + (defgeneric find-method (generic-function qualifiers From ehuelsmann at common-lisp.net Sun Feb 6 16:00:19 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 06 Feb 2011 11:00:19 -0500 Subject: [armedbear-cvs] r13204 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Feb 6 11:00:16 2011 New Revision: 13204 Log: FINALIZE-INHERITANCE (more) AMOP compatible. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Feb 6 11:00:16 2011 @@ -424,6 +424,10 @@ (class-precedence-list class))) (defun std-finalize-inheritance (class) + ;; In case the class is already finalized, return + ;; immediately, as per AMOP. + (when (class-finalized-p class) + (return-from std-finalize-inheritance)) (setf (class-precedence-list class) (funcall (if (eq (class-of class) +the-standard-class+) #'std-compute-class-precedence-list @@ -780,7 +784,8 @@ (t ;; We're redefining the class. (%make-instances-obsolete old-class) - (check-initargs old-class t all-keys) + (setf (class-finalized-p old-class) nil) + (check-initargs old-class t all-keys) (apply #'std-after-initialization-for-classes old-class all-keys) old-class))) (t From ehuelsmann at common-lisp.net Sun Feb 6 16:26:40 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 06 Feb 2011 11:26:40 -0500 Subject: [armedbear-cvs] r13205 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Feb 6 11:26:40 2011 New Revision: 13205 Log: Upon defining a forward referenced class, assign the CLASS-DIRECT-SUBCLASSES slot to the actual class rather than loosing that information. Note: This causes a regression in REINITIALIZE-INSTANCE.ERROR.1; however, the issue is truely with REINITIALIZE-INSTANCE. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Feb 6 11:26:40 2011 @@ -776,6 +776,8 @@ +the-standard-class+ :name name all-keys))) (%set-find-class name new-class) + (setf (class-direct-subclasses new-class) + (class-direct-subclasses old-class)) (dolist (subclass (class-direct-subclasses old-class)) (setf (class-direct-superclasses subclass) (substitute new-class old-class From ehuelsmann at common-lisp.net Sun Feb 6 20:03:29 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 06 Feb 2011 15:03:29 -0500 Subject: [armedbear-cvs] r13206 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Feb 6 15:03:28 2011 New Revision: 13206 Log: Simplify argument passing in CHECK-INITARGS. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Feb 6 15:03:28 2011 @@ -2560,24 +2560,19 @@ (error 'program-error :format-control "Odd number of keyword arguments.")) (unless (getf initargs :allow-other-keys) - (let ((methods - (nconc - (compute-applicable-methods - #'shared-initialize - (if initargs - `(,instance ,shared-initialize-param , at initargs) - (list instance shared-initialize-param))) - (compute-applicable-methods - #'initialize-instance - (if initargs - `(,instance , at initargs) - (list instance))))) - (slots (class-slots (class-of instance)))) + (let ((methods + (nconc + (compute-applicable-methods #'shared-initialize + (list* instance shared-initialize-param + initargs)) + (compute-applicable-methods #'initialize-instance + (list* instance initargs)))) + (slots (class-slots (class-of instance)))) (do* ((tail initargs (cddr tail)) (initarg (car tail) (car tail))) ((null tail)) (unless (or (valid-initarg-p initarg slots) - (valid-methodarg-p initarg methods) + (valid-methodarg-p initarg methods) (eq initarg :allow-other-keys)) (error 'program-error :format-control "Invalid initarg ~S." From ehuelsmann at common-lisp.net Tue Feb 8 17:59:11 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 08 Feb 2011 12:59:11 -0500 Subject: [armedbear-cvs] r13207 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Feb 8 12:59:09 2011 New Revision: 13207 Log: Fix CHECK-INITARGS checking the wrong generic functions by making it general purpose and ask for more parameters. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Tue Feb 8 12:59:09 2011 @@ -690,7 +690,9 @@ documentation) (declare (ignore metaclass)) (let ((class (std-allocate-instance +the-standard-class+))) - (check-initargs class t initargs) + (check-initargs (list #'allocate-instance #'initialize-instance) + (list* class initargs) + class t initargs) (%set-class-name name class) (%set-class-layout nil class) (%set-class-direct-subclasses () class) @@ -787,7 +789,9 @@ ;; We're redefining the class. (%make-instances-obsolete old-class) (setf (class-finalized-p old-class) nil) - (check-initargs old-class t all-keys) + (check-initargs (list #'allocate-instance #'initialize-instance) + (list* old-class all-keys) + old-class t all-keys) (apply #'std-after-initialization-for-classes old-class all-keys) old-class))) (t @@ -2555,7 +2559,7 @@ ;; methods, along with the predefined initialization argument :ALLOW-OTHER-KEYS." ;; 7.1.2 -(defun check-initargs (instance shared-initialize-param initargs) +(defun check-initargs (gf-list args instance shared-initialize-param initargs) (when (oddp (length initargs)) (error 'program-error :format-control "Odd number of keyword arguments.")) @@ -2565,8 +2569,9 @@ (compute-applicable-methods #'shared-initialize (list* instance shared-initialize-param initargs)) - (compute-applicable-methods #'initialize-instance - (list* instance initargs)))) + (mapcan #'(lambda (gf) + (compute-applicable-methods gf args)) + gf-list))) (slots (class-slots (class-of instance)))) (do* ((tail initargs (cddr tail)) (initarg (car tail) (car tail))) @@ -2617,7 +2622,9 @@ (setf initargs (append initargs default-initargs))))) (let ((instance (std-allocate-instance class))) - (check-initargs instance t initargs) + (check-initargs (list #'allocate-instance #'initialize-instance) + (list* instance initargs) + instance t initargs) (apply #'initialize-instance instance initargs) instance)) @@ -2723,7 +2730,9 @@ (slot-exists-p old slot-name)) (mapcar 'slot-definition-name (class-slots (class-of new)))))) - (check-initargs new added-slots initargs) + (check-initargs (list #'update-instance-for-different-class) + (list old new initargs) + new added-slots initargs) (apply #'shared-initialize new added-slots initargs))) ;;; make-instances-obsolete @@ -2752,7 +2761,10 @@ discarded-slots property-list &rest initargs) - (check-initargs instance added-slots initargs) + (check-initargs (list #'update-instance-for-redefined-class) + (list* instance added-slots discarded-slots + property-list initargs) + instance added-slots initargs) (apply #'shared-initialize instance added-slots initargs)) ;;; Methods having to do with class metaobjects. From ehuelsmann at common-lisp.net Tue Feb 8 18:01:21 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 08 Feb 2011 13:01:21 -0500 Subject: [armedbear-cvs] r13208 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Feb 8 13:01:19 2011 New Revision: 13208 Log: Add documentation. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Tue Feb 8 13:01:19 2011 @@ -2560,6 +2560,11 @@ ;; 7.1.2 (defun check-initargs (gf-list args instance shared-initialize-param initargs) + "Checks the validity of `initargs' for the generic functions in `gf-list' when +called with `args' by calculating the applicable methods for each gf. +The applicable methods for SHARED-INITIALIZE based on `instance', +`shared-initialize-param' and `initargs' are added to the list of +applicable methods." (when (oddp (length initargs)) (error 'program-error :format-control "Odd number of keyword arguments.")) From ehuelsmann at common-lisp.net Tue Feb 8 21:46:49 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 08 Feb 2011 16:46:49 -0500 Subject: [armedbear-cvs] r13209 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Feb 8 16:46:47 2011 New Revision: 13209 Log: Add documentation to STD-SHARED-INITIALIZE and add initarg checking to REINITIALIZE-INSTANCE. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Tue Feb 8 16:46:47 2011 @@ -2650,18 +2650,23 @@ ;; slots should be initialized according to their initforms), and the initargs ;; it received." (defmethod reinitialize-instance ((instance standard-object) &rest initargs) + (check-initargs (list #'reinitialize-instance) (list* instance initargs) + instance () initargs) (apply #'shared-initialize instance () initargs)) (defun std-shared-initialize (instance slot-names all-keys) (when (oddp (length all-keys)) (error 'program-error :format-control "Odd number of keyword arguments.")) + ;; do a quick scan of the arguments list to see if it's a real + ;; 'initialization argument list' (which is not the same as + ;; checking initarg validity (do* ((tail all-keys (cddr tail)) - (initarg (car tail) (car tail))) + (initarg (car tail) (car tail))) ((null tail)) (when (and initarg (not (symbolp initarg))) (error 'program-error - :format-control "Invalid initarg ~S." - :format-arguments (list initarg)))) + :format-control "Invalid initarg ~S." + :format-arguments (list initarg)))) (dolist (slot (class-slots (class-of instance))) (let ((slot-name (slot-definition-name slot))) (multiple-value-bind (init-key init-value foundp) From ehuelsmann at common-lisp.net Wed Feb 9 10:38:22 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 09 Feb 2011 05:38:22 -0500 Subject: [armedbear-cvs] r13210 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Feb 9 05:38:19 2011 New Revision: 13210 Log: Reduce complexity of a test: no need to check initarg is not NIL, NIL is symbolp too. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Wed Feb 9 05:38:19 2011 @@ -2663,7 +2663,7 @@ (do* ((tail all-keys (cddr tail)) (initarg (car tail) (car tail))) ((null tail)) - (when (and initarg (not (symbolp initarg))) + (unless (symbolp initarg) (error 'program-error :format-control "Invalid initarg ~S." :format-arguments (list initarg)))) From mevenson at common-lisp.net Fri Feb 11 06:43:23 2011 From: mevenson at common-lisp.net (Mark Evenson) Date: Fri, 11 Feb 2011 01:43:23 -0500 Subject: [armedbear-cvs] r13211 - trunk/abcl Message-ID: Author: mevenson Date: Fri Feb 11 01:43:21 2011 New Revision: 13211 Log: 'abcl.source.jar' now produces a source archive intended for Maven. Refactored UNIX/Windows EOL fixes into separate target. The 'abcl.source.jar' target currently uses UNIX EOL conventions. Modified: trunk/abcl/build.xml Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml (original) +++ trunk/abcl/build.xml Fri Feb 11 01:43:21 2011 @@ -625,7 +625,7 @@ - + @@ -642,7 +642,9 @@ eol="lf"> + + @@ -652,7 +654,7 @@ - + @@ -669,14 +671,29 @@ eol="lf"> + + - + + + + + + + + + + + + + + From mevenson at common-lisp.net Fri Feb 11 09:04:55 2011 From: mevenson at common-lisp.net (Mark Evenson) Date: Fri, 11 Feb 2011 04:04:55 -0500 Subject: [armedbear-cvs] r13212 - trunk/abcl Message-ID: Author: mevenson Date: Fri Feb 11 04:04:54 2011 New Revision: 13212 Log: Added Ant targets to generate javadoc. 'abcl.javadoc' generates the javadoc documentation under 'build/javadoc'. 'abcl.javadoc.jar' packages the javadoc documentation into 'dist/abcl-${abcl.version}-javadoc.jar'. Modified: trunk/abcl/build.xml Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml (original) +++ trunk/abcl/build.xml Fri Feb 11 04:04:54 2011 @@ -694,6 +694,21 @@ + + + + + + + + + + + + + + From astalla at common-lisp.net Fri Feb 11 23:06:27 2011 From: astalla at common-lisp.net (Alessio Stalla) Date: Fri, 11 Feb 2011 18:06:27 -0500 Subject: [armedbear-cvs] r13213 - in trunk/abcl: . src/org/armedbear/lisp Message-ID: Author: astalla Date: Fri Feb 11 18:06:24 2011 New Revision: 13213 Log: Added Maven POM for deployment. Fixed a primitive class name in Java.java. Added: trunk/abcl/pom.xml Modified: trunk/abcl/src/org/armedbear/lisp/Java.java Added: trunk/abcl/pom.xml ============================================================================== --- (empty file) +++ trunk/abcl/pom.xml Fri Feb 11 18:06:24 2011 @@ -0,0 +1,58 @@ + + + + + + 4.0.0 + + org.sonatype.oss + oss-parent + 6 + + org.armedbear.lisp + abcl + jar + ABCL - Armed Bear Common Lisp + 0.24.0 + Common Lisp implementation running on the JVM + http://common-lisp/project/armedbear + + + GNU General Public License with Classpath exception + http://www.gnu.org/software/classpath/license.html + repo + + + + scm:svn:svn://common-lisp.net/project/armedbear/svn/trunk/ + scm:svn:svn+ssh://common-lisp.net/project/armedbear/svn/trunk/ + http://common-lisp.net/websvn/listing.php?repname=armedbear + + + + ehu + Erik Huelsmann + ehuels at gmail.com + + + easyE + Mark Evenson + evenson at panix.com + + + V-ille + Ville Voutilainen + ville.voutilainen at gmail.com + + + astalla + Alessio Stalla + alessiostalla at gmail.com + + + + + + Modified: trunk/abcl/src/org/armedbear/lisp/Java.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Java.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Java.java Fri Feb 11 18:06:24 2011 @@ -1207,13 +1207,13 @@ } }; - private static final Primitive JRUN_EXCEPTION_PROTECTED = new pf_jrun_exception_protection(); + private static final Primitive JRUN_EXCEPTION_PROTECTED = new pf_jrun_exception_protected(); @DocString(name="jrun-exception-protected", args="closure", doc="Invokes the function CLOSURE and returns the result. "+ "Signals an error if stack or heap exhaustion occurs.") - private static final class pf_jrun_exception_protection extends Primitive + private static final class pf_jrun_exception_protected extends Primitive { - pf_jrun_exception_protection() + pf_jrun_exception_protected() { super("jrun-exception-protected", PACKAGE_JAVA, true); } @@ -1229,6 +1229,7 @@ return error(new StorageCondition("Out of memory " + oom.getMessage())); } catch (StackOverflowError oos) { + oos.printStackTrace(); return error(new StorageCondition("Stack overflow.")); } } From ehuelsmann at common-lisp.net Sat Feb 12 18:10:10 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 12 Feb 2011 13:10:10 -0500 Subject: [armedbear-cvs] r13214 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Feb 12 13:10:07 2011 New Revision: 13214 Log: Finalize subclasses as soon as a forward-referenced class gets defined (and itself can be finalized). Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sat Feb 12 13:10:07 2011 @@ -784,6 +784,7 @@ (setf (class-direct-superclasses subclass) (substitute new-class old-class (class-direct-superclasses subclass)))) + (finalize-class-subtree new-class) new-class)) (t ;; We're redefining the class. @@ -804,6 +805,13 @@ (%set-find-class name class) class))))) + +(defun finalize-class-subtree (class) + (when (every #'class-finalized-p (class-direct-superclasses class)) + (finalize-inheritance class) + (dolist (subclass (class-direct-subclasses class)) + (finalize-class-subtree subclass)))) + (defmacro defclass (&whole form name direct-superclasses direct-slots &rest options) (unless (>= (length form) 3) (error 'program-error "Wrong number of arguments for DEFCLASS.")) @@ -2577,12 +2585,12 @@ (mapcan #'(lambda (gf) (compute-applicable-methods gf args)) gf-list))) - (slots (class-slots (class-of instance)))) + (slots (class-slots (class-of instance)))) (do* ((tail initargs (cddr tail)) (initarg (car tail) (car tail))) ((null tail)) (unless (or (valid-initarg-p initarg slots) - (valid-methodarg-p initarg methods) + (valid-methodarg-p initarg methods) (eq initarg :allow-other-keys)) (error 'program-error :format-control "Invalid initarg ~S." @@ -2661,12 +2669,12 @@ ;; 'initialization argument list' (which is not the same as ;; checking initarg validity (do* ((tail all-keys (cddr tail)) - (initarg (car tail) (car tail))) + (initarg (car tail) (car tail))) ((null tail)) (unless (symbolp initarg) (error 'program-error - :format-control "Invalid initarg ~S." - :format-arguments (list initarg)))) + :format-control "Invalid initarg ~S." + :format-arguments (list initarg)))) (dolist (slot (class-slots (class-of instance))) (let ((slot-name (slot-definition-name slot))) (multiple-value-bind (init-key init-value foundp) From ehuelsmann at common-lisp.net Sat Feb 12 18:36:24 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 12 Feb 2011 13:36:24 -0500 Subject: [armedbear-cvs] r13215 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Feb 12 13:36:23 2011 New Revision: 13215 Log: Untabify. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sat Feb 12 13:36:23 2011 @@ -2600,15 +2600,15 @@ (when (symbolp initarg) (dolist (method methods nil) (let ((valid-initargs (method-lambda-list method))) - (when (find (symbol-value initarg) valid-initargs - :test #'(lambda (a b) - (if (listp b) - (string= a (car b)) - (or - (string= a b) - (string= b "&ALLOW-OTHER-KEYS"))))) + (when (find (symbol-value initarg) valid-initargs + :test #'(lambda (a b) + (if (listp b) + (eq a (car b)) + (or + (eq a b) + (eq b 'cl:&allow-other-keys))))) - (return t)))))) + (return t)))))) (defun valid-initarg-p (initarg slots) (dolist (slot slots nil) From ehuelsmann at common-lisp.net Sun Feb 13 11:02:16 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 13 Feb 2011 06:02:16 -0500 Subject: [armedbear-cvs] r13216 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Feb 13 06:02:14 2011 New Revision: 13216 Log: Fixes to checking initargs: - Use only keyword arguments for the check (not the full lambda-list) - Add support for keyword args explicitly naming their keyword [((:e d))] Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Feb 13 06:02:14 2011 @@ -2577,44 +2577,59 @@ (error 'program-error :format-control "Odd number of keyword arguments.")) (unless (getf initargs :allow-other-keys) - (let ((methods - (nconc - (compute-applicable-methods #'shared-initialize - (list* instance shared-initialize-param - initargs)) - (mapcan #'(lambda (gf) - (compute-applicable-methods gf args)) - gf-list))) - (slots (class-slots (class-of instance)))) - (do* ((tail initargs (cddr tail)) - (initarg (car tail) (car tail))) - ((null tail)) - (unless (or (valid-initarg-p initarg slots) - (valid-methodarg-p initarg methods) - (eq initarg :allow-other-keys)) - (error 'program-error - :format-control "Invalid initarg ~S." - :format-arguments (list initarg))))))) - -(defun valid-methodarg-p (initarg methods) - (when (symbolp initarg) - (dolist (method methods nil) - (let ((valid-initargs (method-lambda-list method))) - (when (find (symbol-value initarg) valid-initargs - :test #'(lambda (a b) - (if (listp b) - (eq a (car b)) - (or - (eq a b) - (eq b 'cl:&allow-other-keys))))) - - (return t)))))) - -(defun valid-initarg-p (initarg slots) - (dolist (slot slots nil) - (let ((valid-initargs (slot-definition-initargs slot))) - (when (memq initarg valid-initargs) - (return t))))) + (let* ((methods + (nconc + (compute-applicable-methods #'shared-initialize + (list* instance + shared-initialize-param + initargs)) + (mapcan #'(lambda (gf) + (compute-applicable-methods gf args)) + gf-list))) + (method-keyword-args + (reduce #'merge-initargs-sets + (mapcar #'method-lambda-list methods) + :key #'extract-lambda-list-keywords + :initial-value nil)) + (slots-initargs + (mapappend #'slot-definition-initargs + (class-slots (class-of instance)))) + (allowable-initargs + (merge-initargs-sets + (merge-initargs-sets slots-initargs method-keyword-args) + '(:allow-other-keys)))) ;; allow-other-keys is always allowed + (unless (eq t allowable-initargs) + (do* ((tail initargs (cddr tail)) + (initarg (car tail) (car tail))) + ((null tail)) + (unless (memq initarg allowable-initargs) + (error 'program-error + :format-control "Invalid initarg ~S." + :format-arguments (list initarg)))))))) + +(defun merge-initargs-sets (list1 list2) + (cond + ((eq list1 t) t) + ((eq list2 t) t) + (t (union list1 list2)))) + +(defun extract-lambda-list-keywords (lambda-list) + "Returns a list of keywords acceptable as keyword arguments, +or T when any keyword is acceptable due to presence of +&allow-other-keys." + (when (member '&allow-other-keys lambda-list) + (return-from extract-lambda-list-keywords t)) + (let* ((keyword-args (cdr (memq '&key lambda-list))) + (aux-vars (position '&aux keyword-args))) + (when keyword-args + (when aux-vars + (setq keyword-args (subseq keyword-args 0 aux-vars))) + (let (result) + (dolist (key keyword-args result) + (when (listp key) + (setq key (car key))) + (push (if (symbolp key) (make-keyword key) (car key)) result)))))) + (defgeneric make-instance (class &rest initargs &key &allow-other-keys)) From ehuelsmann at common-lisp.net Sun Feb 13 11:41:57 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 13 Feb 2011 06:41:57 -0500 Subject: [armedbear-cvs] r13217 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Feb 13 06:41:56 2011 New Revision: 13217 Log: Move checking for FORWARD-REFERENCED-CLASS superclasses from FINALIZE-INHERITANCE to COMPUTE-CLASS-PRECEDENCE-LIST, as per AMOP, which says C-C-P-L should generate an error in such a case. At the same time, STD-AFTER-INITIALIZATION-FOR-CLASSES doesn't call FINALIZE-INHERITANCE directly - it generates an error now. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Feb 13 06:41:56 2011 @@ -433,9 +433,6 @@ #'std-compute-class-precedence-list #'compute-class-precedence-list) class)) - (dolist (class (class-precedence-list class)) - (when (typep class 'forward-referenced-class) - (return-from std-finalize-inheritance))) (setf (class-slots class) (funcall (if (eq (class-of class) +the-standard-class+) #'std-compute-slots @@ -483,6 +480,10 @@ (defun std-compute-class-precedence-list (class) (let ((classes-to-order (collect-superclasses* class))) + (dolist (super classes-to-order) + (when (typep super 'forward-referenced-class) + (error "Can't compute class precedence list for class ~A ~ + which depends on forward referenced class ~A." class super))) (topological-sort classes-to-order (remove-duplicates (mapappend #'local-precedence-ordering @@ -729,10 +730,7 @@ (dolist (writer (slot-definition-writers direct-slot)) (add-writer-method class writer (slot-definition-name direct-slot))))) (setf (class-direct-default-initargs class) direct-default-initargs) - (funcall (if (eq (class-of class) +the-standard-class+) - #'std-finalize-inheritance - #'finalize-inheritance) - class) + (maybe-finalize-class-subtree class) (values)) (defun canonical-slot-name (canonical-slot) @@ -784,7 +782,7 @@ (setf (class-direct-superclasses subclass) (substitute new-class old-class (class-direct-superclasses subclass)))) - (finalize-class-subtree new-class) + (maybe-finalize-class-subtree new-class) new-class)) (t ;; We're redefining the class. @@ -806,11 +804,11 @@ class))))) -(defun finalize-class-subtree (class) +(defun maybe-finalize-class-subtree (class) (when (every #'class-finalized-p (class-direct-superclasses class)) (finalize-inheritance class) (dolist (subclass (class-direct-subclasses class)) - (finalize-class-subtree subclass)))) + (maybe-finalize-class-subtree subclass)))) (defmacro defclass (&whole form name direct-superclasses direct-slots &rest options) (unless (>= (length form) 3) From ehuelsmann at common-lisp.net Sun Feb 13 15:29:42 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 13 Feb 2011 10:29:42 -0500 Subject: [armedbear-cvs] r13218 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Feb 13 10:29:42 2011 New Revision: 13218 Log: Replace algorithm in EXTRACT-LAMBDA-LIST-KEYWORDS to make a single iteration through the lambda list. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Feb 13 10:29:42 2011 @@ -2617,16 +2617,14 @@ &allow-other-keys." (when (member '&allow-other-keys lambda-list) (return-from extract-lambda-list-keywords t)) - (let* ((keyword-args (cdr (memq '&key lambda-list))) - (aux-vars (position '&aux keyword-args))) - (when keyword-args - (when aux-vars - (setq keyword-args (subseq keyword-args 0 aux-vars))) - (let (result) - (dolist (key keyword-args result) - (when (listp key) - (setq key (car key))) - (push (if (symbolp key) (make-keyword key) (car key)) result)))))) + (loop with keyword-args = (cdr (memq '&key lambda-list)) + for key in keyword-args + when (eq key '&aux) do (loop-finish) + when (eq key '&allow-other-keys) do (return t) + when (listp key) do (setq key (car key)) + collect (if (symbolp key) + (make-keyword key) + (car key)))) (defgeneric make-instance (class &rest initargs &key &allow-other-keys)) From ehuelsmann at common-lisp.net Sun Feb 13 21:08:32 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 13 Feb 2011 16:08:32 -0500 Subject: [armedbear-cvs] r13219 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Feb 13 16:08:31 2011 New Revision: 13219 Log: Add caching to CHECK-INITARGS: cache sets of allowable initargs per class. Note: This change *only* implements caching for "case 1" out of the 4 cases that check-initargs now supports. (Case 1 being instance creation.) Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Feb 13 16:08:31 2011 @@ -693,7 +693,8 @@ (let ((class (std-allocate-instance +the-standard-class+))) (check-initargs (list #'allocate-instance #'initialize-instance) (list* class initargs) - class t initargs) + class t initargs + *make-instance-initargs-cache*) (%set-class-name name class) (%set-class-layout nil class) (%set-class-direct-subclasses () class) @@ -740,6 +741,10 @@ (list (find-class 'sequence) (find-class 'java:java-object))) +(defvar *make-instance-initargs-cache* + (make-hash-table :test #'eq) + "Cached sets of allowable initargs, keyed on the class they belong to.") + (defun ensure-class (name &rest all-keys &key metaclass &allow-other-keys) ;; Check for duplicate slots. (remf all-keys :metaclass) @@ -786,11 +791,14 @@ new-class)) (t ;; We're redefining the class. + (remhash old-class *make-instance-initargs-cache*) (%make-instances-obsolete old-class) (setf (class-finalized-p old-class) nil) - (check-initargs (list #'allocate-instance #'initialize-instance) + (check-initargs (list #'allocate-instance + #'initialize-instance) (list* old-class all-keys) - old-class t all-keys) + old-class t all-keys + nil) (apply #'std-after-initialization-for-classes old-class all-keys) old-class))) (t @@ -1585,10 +1593,31 @@ all of the keyword arguments defined for the ~ generic function." method-lambda-list name))))) +(defvar *gf-initialize-instance* nil + "Cached value of the INITIALIZE-INSTANCE generic function. +Initialized with the true value near the end of the file.") +(defvar *gf-allocate-instance* nil + "Cached value of the ALLOCATE-INSTANCE generic function. +Initialized with the true value near the end of the file.") +(defvar *gf-shared-initialize* nil + "Cached value of the SHARED-INITIALIZE generic function. +Initialized with the true value near the end of the file.") +(defvar *gf-reinitialize-instance* nil + "Cached value of the REINITIALIZE-INSTANCE generic function. +Initialized with the true value near the end of the file.") + (declaim (ftype (function * method) ensure-method)) (defun ensure-method (name &rest all-keys) (let ((method-lambda-list (getf all-keys :lambda-list)) (gf (find-generic-function name nil))) + (when (or (eq gf *gf-initialize-instance*) + (eq gf *gf-allocate-instance*) + (eq gf *gf-shared-initialize*) + (eq gf *gf-reinitialize-instance*)) + ;; ### Clearly, this can be targeted much more exact + ;; as we only need to remove the specializing class and all + ;; its subclasses from the hash. + (clrhash *make-instance-initargs-cache*)) (if gf (check-method-lambda-list name method-lambda-list (generic-function-lambda-list gf)) @@ -2565,18 +2594,11 @@ ;; methods, along with the predefined initialization argument :ALLOW-OTHER-KEYS." ;; 7.1.2 -(defun check-initargs (gf-list args instance shared-initialize-param initargs) - "Checks the validity of `initargs' for the generic functions in `gf-list' when -called with `args' by calculating the applicable methods for each gf. -The applicable methods for SHARED-INITIALIZE based on `instance', -`shared-initialize-param' and `initargs' are added to the list of -applicable methods." - (when (oddp (length initargs)) - (error 'program-error - :format-control "Odd number of keyword arguments.")) - (unless (getf initargs :allow-other-keys) - (let* ((methods - (nconc +(defun calculate-allowable-initargs (gf-list args instance + shared-initialize-param + initargs) + (let* ((methods + (nconc (compute-applicable-methods #'shared-initialize (list* instance shared-initialize-param @@ -2584,26 +2606,48 @@ (mapcan #'(lambda (gf) (compute-applicable-methods gf args)) gf-list))) - (method-keyword-args - (reduce #'merge-initargs-sets - (mapcar #'method-lambda-list methods) - :key #'extract-lambda-list-keywords - :initial-value nil)) - (slots-initargs - (mapappend #'slot-definition-initargs - (class-slots (class-of instance)))) - (allowable-initargs - (merge-initargs-sets - (merge-initargs-sets slots-initargs method-keyword-args) - '(:allow-other-keys)))) ;; allow-other-keys is always allowed - (unless (eq t allowable-initargs) - (do* ((tail initargs (cddr tail)) - (initarg (car tail) (car tail))) - ((null tail)) - (unless (memq initarg allowable-initargs) - (error 'program-error - :format-control "Invalid initarg ~S." - :format-arguments (list initarg)))))))) + (method-keyword-args + (reduce #'merge-initargs-sets + (mapcar #'method-lambda-list methods) + :key #'extract-lambda-list-keywords + :initial-value nil)) + (slots-initargs + (mapappend #'slot-definition-initargs + (class-slots (class-of instance))))) + (merge-initargs-sets + (merge-initargs-sets slots-initargs method-keyword-args) + '(:allow-other-keys)))) ;; allow-other-keys is always allowed + +(defun check-initargs (gf-list args instance + shared-initialize-param initargs + cache) + "Checks the validity of `initargs' for the generic functions in `gf-list' +when called with `args' by calculating the applicable methods for each gf. +The applicable methods for SHARED-INITIALIZE based on `instance', +`shared-initialize-param' and `initargs' are added to the list of +applicable methods." + (when (oddp (length initargs)) + (error 'program-error + :format-control "Odd number of keyword arguments.")) + (unless (getf initargs :allow-other-keys) + (multiple-value-bind (allowable-initargs present-p) + (when cache + (gethash (class-of instance) cache)) + (unless present-p + (setf allowable-initargs + (calculate-allowable-initargs gf-list args instance + shared-initialize-param initargs)) + (when cache + (setf (gethash (class-of instance) cache) + allowable-initargs))) + (unless (eq t allowable-initargs) + (do* ((tail initargs (cddr tail)) + (initarg (car tail) (car tail))) + ((null tail)) + (unless (memq initarg allowable-initargs) + (error 'program-error + :format-control "Invalid initarg ~S." + :format-arguments (list initarg)))))))) (defun merge-initargs-sets (list1 list2) (cond @@ -2648,7 +2692,8 @@ (let ((instance (std-allocate-instance class))) (check-initargs (list #'allocate-instance #'initialize-instance) (list* instance initargs) - instance t initargs) + instance t initargs + *make-instance-initargs-cache*) (apply #'initialize-instance instance initargs) instance)) @@ -2670,7 +2715,8 @@ ;; it received." (defmethod reinitialize-instance ((instance standard-object) &rest initargs) (check-initargs (list #'reinitialize-instance) (list* instance initargs) - instance () initargs) + instance () initargs + nil) (apply #'shared-initialize instance () initargs)) (defun std-shared-initialize (instance slot-names all-keys) @@ -2761,7 +2807,8 @@ (class-slots (class-of new)))))) (check-initargs (list #'update-instance-for-different-class) (list old new initargs) - new added-slots initargs) + new added-slots initargs + nil) (apply #'shared-initialize new added-slots initargs))) ;;; make-instances-obsolete @@ -2793,7 +2840,8 @@ (check-initargs (list #'update-instance-for-redefined-class) (list* instance added-slots discarded-slots property-list initargs) - instance added-slots initargs) + instance added-slots initargs + nil) (apply #'shared-initialize instance added-slots initargs)) ;;; Methods having to do with class metaobjects. @@ -3101,6 +3149,11 @@ ;; FIXME (defgeneric function-keywords (method)) + +(setf *gf-initialize-instance* (symbol-function 'initialize-instance)) +(setf *gf-allocate-instance* (symbol-function 'allocate-instance)) +(setf *gf-shared-initialize* (symbol-function 'shared-initialize)) +(setf *gf-reinitialize-instance* (symbol-function 'reinitialize-instance)) (setf *clos-booting* nil) (defgeneric class-prototype (class)) From ehuelsmann at common-lisp.net Sun Feb 13 21:27:48 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 13 Feb 2011 16:27:48 -0500 Subject: [armedbear-cvs] r13220 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Feb 13 16:27:48 2011 New Revision: 13220 Log: Add REINITIALIZE-INSTANCE initargs cache. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Feb 13 16:27:48 2011 @@ -744,6 +744,9 @@ (defvar *make-instance-initargs-cache* (make-hash-table :test #'eq) "Cached sets of allowable initargs, keyed on the class they belong to.") +(defvar *reinitialize-instance-initargs-cache* + (make-hash-table :test #'eq) + "Cached sets of allowable initargs, keyed on the class they belong to.") (defun ensure-class (name &rest all-keys &key metaclass &allow-other-keys) ;; Check for duplicate slots. @@ -792,6 +795,7 @@ (t ;; We're redefining the class. (remhash old-class *make-instance-initargs-cache*) + (remhash old-class *reinitialize-instance-initargs-cache*) (%make-instances-obsolete old-class) (setf (class-finalized-p old-class) nil) (check-initargs (list #'allocate-instance @@ -1617,7 +1621,8 @@ ;; ### Clearly, this can be targeted much more exact ;; as we only need to remove the specializing class and all ;; its subclasses from the hash. - (clrhash *make-instance-initargs-cache*)) + (clrhash *make-instance-initargs-cache*) + (clrhash *reinitialize-instance-initargs-cache*)) (if gf (check-method-lambda-list name method-lambda-list (generic-function-lambda-list gf)) @@ -2716,7 +2721,7 @@ (defmethod reinitialize-instance ((instance standard-object) &rest initargs) (check-initargs (list #'reinitialize-instance) (list* instance initargs) instance () initargs - nil) + *reinitialize-instance-initargs-cache*) (apply #'shared-initialize instance () initargs)) (defun std-shared-initialize (instance slot-names all-keys) From astalla at common-lisp.net Mon Feb 14 23:03:15 2011 From: astalla at common-lisp.net (Alessio Stalla) Date: Mon, 14 Feb 2011 18:03:15 -0500 Subject: [armedbear-cvs] r13221 - in trunk/abcl: . src/org/armedbear/lisp Message-ID: Author: astalla Date: Mon Feb 14 18:03:12 2011 New Revision: 13221 Log: Fix LispClass.subclassp(LispObject) used by register-java-exception. More checks in register-java-exception. Modified: trunk/abcl/pom.xml trunk/abcl/src/org/armedbear/lisp/Java.java trunk/abcl/src/org/armedbear/lisp/LispClass.java Modified: trunk/abcl/pom.xml ============================================================================== --- trunk/abcl/pom.xml (original) +++ trunk/abcl/pom.xml Mon Feb 14 18:03:12 2011 @@ -13,9 +13,9 @@ org.armedbear.lisp abcl + 0.24.0 jar ABCL - Armed Bear Common Lisp - 0.24.0 Common Lisp implementation running on the JVM http://common-lisp/project/armedbear Modified: trunk/abcl/src/org/armedbear/lisp/Java.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Java.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Java.java Mon Feb 14 18:03:12 2011 @@ -91,9 +91,9 @@ public LispObject execute(LispObject className, LispObject symbol) { - // FIXME Verify that CONDITION-SYMBOL is a symbol that names a condition. + LispClass lispClass = (LispClass) LispClass.findClass(symbol, true); // FIXME Signal a continuable error if the exception is already registered. - if ((symbol instanceof Symbol) && isJavaException(LispClass.findClass((Symbol) symbol))) { + if (isJavaException(lispClass)) { registeredExceptions.put(classForName(className.getStringValue()), (Symbol)symbol); return T; @@ -122,13 +122,15 @@ } }; - static Symbol getCondition(Class cl) - { - Class o = classForName("java.lang.Object"); - for (Class c = cl ; c != o ; c = c.getSuperclass()) { + static Symbol getCondition(Class cl) { + Class o = classForName("java.lang.Object"); + for (Class c = cl ; c != o ; c = c.getSuperclass()) { Object object = registeredExceptions.get(c); - if (object != null && isJavaException(LispClass.findClass((Symbol) object))) { - return (Symbol) object; + if (object instanceof Symbol) { + LispClass lispClass = (LispClass) LispClass.findClass((Symbol) object, true); + if(isJavaException(lispClass)) { + return (Symbol) object; + } } } return null; Modified: trunk/abcl/src/org/armedbear/lisp/LispClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispClass.java (original) +++ trunk/abcl/src/org/armedbear/lisp/LispClass.java Mon Feb 14 18:03:12 2011 @@ -287,7 +287,7 @@ public boolean subclassp(LispObject obj) { - return false; + return subclassp(this, obj); } public static boolean subclassp(LispObject cls, LispObject obj) @@ -305,11 +305,6 @@ return true; cpl = ((Cons)cpl).cdr; } - - if (cls instanceof LispClass) - // additional checks (currently because of JavaClass) - return ((LispClass)cls).subclassp(obj); - return false; } From ehuelsmann at common-lisp.net Tue Feb 15 22:29:25 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 15 Feb 2011 17:29:25 -0500 Subject: [armedbear-cvs] r13222 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Feb 15 17:29:22 2011 New Revision: 13222 Log: Backport 'unsafe-p-removal' branch: this commit pushes back the responsibility of maintaining stack consistency in generated (byte) code to pass2, from a shared pass1/pass2 responsibility. The issue why it can't happen in pass1 is because in pass1 the full structure of the lisp code isn't known yet, due to lambda and local function inlining. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp trunk/abcl/src/org/armedbear/lisp/jvm.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Tue Feb 15 17:29:22 2011 @@ -398,24 +398,7 @@ (setf (cdr form) (p1-body (cdr form))) form) -(defknown p1-if (t) t) -(defun p1-if (form) - (let ((test (cadr form))) - (cond ((unsafe-p test) - (cond ((and (consp test) - (memq (%car test) '(GO RETURN-FROM THROW))) - (p1 test)) - (t - (let* ((var (gensym)) - (new-form - `(let ((,var ,test)) - (if ,var ,(third form) ,(fourth form))))) - (p1 new-form))))) - (t - (p1-default form))))) - - -(defmacro p1-let/let*-vars +(defmacro p1-let/let*-vars (block varlist variables-var var body1 body2) (let ((varspec (gensym)) (initform (gensym)) @@ -468,6 +451,7 @@ (declare (type cons form)) (let* ((*visible-variables* *visible-variables*) (block (make-let/let*-node)) + (*block* block) (op (%car form)) (varlist (cadr form)) (body (cddr form))) @@ -506,6 +490,7 @@ (defun p1-locally (form) (let* ((*visible-variables* *visible-variables*) (block (make-locally-node)) + (*block* block) (free-specials (process-declarations-for-vars (cdr form) nil block))) (setf (locally-free-specials block) free-specials) (dolist (special free-specials) @@ -523,6 +508,7 @@ (return-from p1-m-v-b (p1-let/let* new-form)))) (let* ((*visible-variables* *visible-variables*) (block (make-m-v-b-node)) + (*block* block) (varlist (cadr form)) ;; Process the values-form first. ("The scopes of the name binding and ;; declarations do not include the values-form.") @@ -552,6 +538,7 @@ (defun p1-block (form) (let* ((block (make-block-node (cadr form))) + (*block* block) (*blocks* (cons block *blocks*))) (setf (cddr form) (p1-body (cddr form))) (setf (block-form block) form) @@ -568,6 +555,7 @@ (let* ((tag (p1 (cadr form))) (body (cddr form)) (block (make-catch-node)) + (*block* block) ;; our subform processors need to know ;; they're enclosed in a CATCH block (*blocks* (cons block *blocks*)) @@ -591,6 +579,7 @@ (let* ((synchronized-object (p1 (cadr form))) (body (cddr form)) (block (make-synchronized-node)) + (*block* block) (*blocks* (cons block *blocks*)) result) (dolist (subform body) @@ -614,6 +603,7 @@ ;; However, p1 transforms the forms being processed, so, we ;; need to copy the forms to create a second copy. (let* ((block (make-unwind-protect-node)) + (*block* block) ;; a bit of jumping through hoops... (unwinding-forms (p1-body (copy-tree (cddr form)))) (unprotected-forms (p1-body (cddr form))) @@ -629,11 +619,9 @@ (defknown p1-return-from (t) t) (defun p1-return-from (form) - (let ((new-form (rewrite-return-from form))) - (when (neq form new-form) - (return-from p1-return-from (p1 new-form)))) (let* ((name (second form)) - (block (find-block name))) + (block (find-block name)) + non-local-p) (when (null block) (compiler-error "RETURN-FROM ~S: no block named ~S is currently visible." name name)) @@ -647,20 +635,26 @@ (let ((protected (enclosed-by-protected-block-p block))) (dformat t "p1-return-from protected = ~S~%" protected) (if protected - (setf (block-non-local-return-p block) t) + (setf (block-non-local-return-p block) t + non-local-p t) ;; non-local GO's ensure environment restoration ;; find out about this local GO (when (null (block-needs-environment-restoration block)) (setf (block-needs-environment-restoration block) (enclosed-by-environment-setting-block-p block)))))) (t - (setf (block-non-local-return-p block) t))) + (setf (block-non-local-return-p block) t + non-local-p t))) (when (block-non-local-return-p block) - (dformat t "non-local return from block ~S~%" (block-name block)))) - (list* 'RETURN-FROM (cadr form) (mapcar #'p1 (cddr form)))) + (dformat t "non-local return from block ~S~%" (block-name block))) + (let ((value-form (p1 (caddr form)))) + (push value-form (block-return-value-forms block)) + (make-jump-node (list 'RETURN-FROM name value-form) + non-local-p block)))) (defun p1-tagbody (form) (let* ((block (make-tagbody-node)) + (*block* block) (*blocks* (cons block *blocks*)) (*visible-tags* *visible-tags*) (local-tags '()) @@ -705,12 +699,14 @@ (unless tag (error "p1-go: tag not found: ~S" name)) (setf (tag-used tag) t) - (let ((tag-block (tag-block tag))) + (let ((tag-block (tag-block tag)) + non-local-p) (cond ((eq (tag-compiland tag) *current-compiland*) ;; Does the GO leave an enclosing UNWIND-PROTECT or CATCH? (if (enclosed-by-protected-block-p tag-block) (setf (tagbody-non-local-go-p tag-block) t - (tag-used-non-locally tag) t) + (tag-used-non-locally tag) t + non-local-p t) ;; non-local GO's ensure environment restoration ;; find out about this local GO (when (null (tagbody-needs-environment-restoration tag-block)) @@ -718,8 +714,9 @@ (enclosed-by-environment-setting-block-p tag-block))))) (t (setf (tagbody-non-local-go-p tag-block) t - (tag-used-non-locally tag) t))))) - form) + (tag-used-non-locally tag) t + non-local-p t))) + (make-jump-node form non-local-p tag-block tag)))) (defun validate-function-name (name) (unless (or (symbolp name) (setf-function-name-p name)) @@ -927,6 +924,7 @@ ((with-saved-compiler-policy (process-optimization-declarations (cddr form)) (let* ((block (make-flet-node)) + (*block* block) (*blocks* (cons block *blocks*)) (body (cddr form)) (*visible-variables* *visible-variables*)) @@ -965,6 +963,7 @@ (*current-compiland* (local-function-compiland local-function))) (p1-compiland (local-function-compiland local-function)))) (let* ((block (make-labels-node)) + (*block* block) (*blocks* (cons block *blocks*)) (body (cddr form)) (*visible-variables* *visible-variables*)) @@ -1068,13 +1067,10 @@ (defknown p1-progv (t) t) (defun p1-progv (form) ;; We've already checked argument count in PRECOMPILE-PROGV. - - (let ((new-form (rewrite-progv form))) - (when (neq new-form form) - (return-from p1-progv (p1 new-form)))) (let* ((symbols-form (p1 (cadr form))) (values-form (p1 (caddr form))) (block (make-progv-node)) + (*block* block) (*blocks* (cons block *blocks*)) (body (cdddr form))) ;; The (commented out) block below means to detect compile-time @@ -1090,20 +1086,6 @@ `(progv ,symbols-form ,values-form ,@(p1-body body))) block)) -(defknown rewrite-progv (t) t) -(defun rewrite-progv (form) - (let ((symbols-form (cadr form)) - (values-form (caddr form)) - (body (cdddr form))) - (cond ((or (unsafe-p symbols-form) (unsafe-p values-form)) - (let ((g1 (gensym)) - (g2 (gensym))) - `(let ((,g1 ,symbols-form) - (,g2 ,values-form)) - (progv ,g1 ,g2 , at body)))) - (t - form)))) - (defun p1-quote (form) (unless (= (length form) 2) (compiler-error "Wrong number of arguments for special operator ~A (expected 1, but received ~D)." @@ -1168,84 +1150,8 @@ (1- (length form)))) (list 'TRULY-THE (%cadr form) (p1 (%caddr form)))) -(defknown unsafe-p (t) t) -(defun unsafe-p (args) - "Determines whether the args can cause 'stack unsafe situations'. -Returns T if this is the case. - -When a 'stack unsafe situation' is encountered, the stack cannot -be used for temporary storage of intermediary results. This happens -because one of the forms in ARGS causes a local transfer of control -- local GO instruction - which assumes an empty stack, or if one of -the args causes a Java exception handler to be installed, which -- when triggered - clears out the stack. -" - (cond ((node-p args) - (unsafe-p (node-form args))) - ((atom args) - nil) - (t - (case (%car args) - (QUOTE - nil) -;; (LAMBDA -;; nil) - ((RETURN-FROM GO CATCH THROW UNWIND-PROTECT BLOCK) - t) - (t - (dolist (arg args) - (when (unsafe-p arg) - (return t)))))))) - -(defknown rewrite-return-from (t) t) -(defun rewrite-return-from (form) - (let* ((args (cdr form)) - (result-form (second args)) - (var (gensym))) - (if (unsafe-p (cdr args)) - (if (single-valued-p result-form) - `(let ((,var ,result-form)) - (return-from ,(first args) ,var)) - `(let ((,var (multiple-value-list ,result-form))) - (return-from ,(first args) (values-list ,var)))) - form))) - - -(defknown rewrite-throw (t) t) -(defun rewrite-throw (form) - (let ((args (cdr form))) - (if (unsafe-p args) - (let ((syms ()) - (lets ())) - ;; Tag. - (let ((arg (first args))) - (if (constantp arg) - (push arg syms) - (let ((sym (gensym))) - (push sym syms) - (push (list sym arg) lets)))) - ;; Result. "If the result-form produces multiple values, then all the - ;; values are saved." - (let ((arg (second args))) - (if (constantp arg) - (push arg syms) - (let ((sym (gensym))) - (cond ((single-valued-p arg) - (push sym syms) - (push (list sym arg) lets)) - (t - (push (list 'VALUES-LIST sym) syms) - (push (list sym - (list 'MULTIPLE-VALUE-LIST arg)) - lets)))))) - (list 'LET* (nreverse lets) (list* 'THROW (nreverse syms)))) - form))) - (defknown p1-throw (t) t) (defun p1-throw (form) - (let ((new-form (rewrite-throw form))) - (when (neq new-form form) - (return-from p1-throw (p1 new-form)))) (list* 'THROW (mapcar #'p1 (cdr form)))) (defknown rewrite-function-call (t) t) @@ -1255,32 +1161,12 @@ ((and (eq op 'funcall) (listp (car args)) (eq (caar args) 'lambda)) ;;(funcall (lambda (...) ...) ...) (let ((op (car args)) (args (cdr args))) - (expand-function-call-inline form (cadr op) (copy-tree (cddr op)) - args))) + (expand-function-call-inline form (cadr op) (copy-tree (cddr op)) + args))) ((and (listp op) (eq (car op) 'lambda)) ;;((lambda (...) ...) ...) (expand-function-call-inline form (cadr op) (copy-tree (cddr op)) args)) - (t (if (unsafe-p args) - (let ((arg1 (car args))) - (cond ((and (consp arg1) (eq (car arg1) 'GO)) - arg1) - (t - (let ((syms ()) - (lets ())) - ;; Preserve the order of evaluation of the arguments! - (dolist (arg args) - (cond ((constantp arg) - (push arg syms)) - ((and (consp arg) (eq (car arg) 'GO)) - (return-from rewrite-function-call - (list 'LET* (nreverse lets) arg))) - (t - (let ((sym (gensym))) - (push sym syms) - (push (list sym arg) lets))))) - (list 'LET* (nreverse lets) - (list* (car form) (nreverse syms))))))) - form))))) + (t form)))) (defknown p1-function-call (t) t) (defun p1-function-call (form) @@ -1406,7 +1292,11 @@ (FUNCALL p1-funcall) (FUNCTION p1-function) (GO p1-go) - (IF p1-if) + (IF p1-default) + ;; used to be p1-if, which was used to rewrite the test + ;; form to a LET-binding; that's not necessary, because + ;; the test form doesn't lead to multiple operands on the + ;; operand stack (LABELS p1-labels) (LAMBDA p1-lambda) (LET p1-let/let*) Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Tue Feb 15 17:29:22 2011 @@ -345,12 +345,6 @@ (compiler-subtypep the-type (make-compiler-type type))) (return-from type-representation (caar types)))))) -(defun representation-size (representation) - (ecase representation - ((NIL :int :boolean :float :char) 1) - ((:long :double) 2))) - - (defknown emit-unbox-boolean () t) (defun emit-unbox-boolean () (emit-instanceof +lisp-nil+) @@ -579,9 +573,29 @@ (defknown single-valued-p (t) t) (defun single-valued-p (form) (cond ((node-p form) - (if (tagbody-node-p form) - (not (unsafe-p (node-form form))) - (single-valued-p (node-form form)))) + (cond ((tagbody-node-p form) + t) + ((block-node-p form) + (and (single-valued-p (car (last (node-form form)))) + ;; return-from value forms + (every #'single-valued-p + (block-return-value-forms form)))) + ((or (flet-node-p form) + (labels-node-p form) + (let/let*-node-p form) + (m-v-b-node-p form) + (progv-node-p form) + (locally-node-p form) + (synchronized-node-p form)) + (single-valued-p (car (last (node-form form))))) + ((unwind-protect-node-p form) + (single-valued-p (second (node-form form)))) + ((catch-node-p form) + nil) + ((jump-node-p form) + (single-valued-p (node-form form))) + (t + (assert (not "SINGLE-VALUED-P unhandled NODE-P branch"))))) ((var-ref-p form) t) ((atom form) @@ -590,15 +604,15 @@ (let ((op (%car form)) result-type compiland) + (assert (not (member op '(LET LET* FLET LABELS TAGBODY CATCH + MULTIPLE-VALUE-BIND + UNWIND-PROTECT BLOCK PROGV + LOCALLY)))) (cond ((eq op 'IF) (and (single-valued-p (third form)) (single-valued-p (fourth form)))) ((eq op 'PROGN) (single-valued-p (car (last form)))) - ((eq op 'BLOCK) - (single-valued-p (car (last form)))) - ((memq op '(LET LET*)) - (single-valued-p (car (last (cddr form))))) ((memq op '(AND OR)) (every #'single-valued-p (cdr form))) ((eq op 'RETURN-FROM) @@ -645,6 +659,126 @@ collecting form))) (apply #'maybe-emit-clear-values forms-for-emit-clear))) + +(declaim (special *saved-operands* *operand-representations*)) +(defmacro with-operand-accumulation ((&body argument-accumulation-body) + &body call-body) + "Macro used to operand-stack-safely collect arguments in the +`argument-accumulation-body' to be available on the stack upon entry of the +`call-body'. The argument-accumulation-body code may not assume arguments +are actually on the stack while accumulating. + +This macro closes over a code-generating block. Operands can be collected +using the `accumulate-operand', `compile-operand', `emit-variable-operand' +and `emit-load-externalized-object-operand'." + `(let (*saved-operands* + *operand-representations* + (*register* *register*) + ) ;; hmm can we do this?? either body + ;; could allocate registers ... + , at argument-accumulation-body + (load-saved-operands) + , at call-body)) + +(defmacro accumulate-operand ((representation &key unsafe-p) + &body body) + "Macro used to collect a single operand. + +This macro closes over a code-generating block. The generated code should +leave a single operand on the stack, with representation `representation'. +The value `unsafe-p', when provided, is an expression evaluated at run time +to indicate if the body is opstack unsafe." + `(progn + ,@(when unsafe-p + `((when ,unsafe-p + (save-existing-operands)))) + , at body + (save-operand ,representation))) + +(defun load-saved-operands () + "Load any operands which have been saved into registers +back onto the stack in preparation of the execution of the opcode." + (mapcar #'emit-push-register + (reverse *saved-operands*) + (reverse *operand-representations*))) + +(defun save-existing-operands () + "If any operands have been compiled to the stack, +save them in registers." + (when (null *saved-operands*) + (dolist (representation *operand-representations*) + (let ((register (allocate-register representation))) + (push register *saved-operands*) + (emit-move-from-stack register representation))) + + (setf *saved-operands* (nreverse *saved-operands*)))) + +(defun save-operand (representation) + "Saves an operand from the stack (with `representation') to +a register and updates associated operand collection variables." + (push representation *operand-representations*) + + (when *saved-operands* + (let ((register (allocate-register representation))) + (push register *saved-operands*) + (emit-move-from-stack register representation)))) + +(defun compile-operand (form representation &optional cast) + "Compiles `form' into `representation', storing the resulting value +on the operand stack, if it's safe to do so. Otherwise stores the value +in a register" + (let ((unsafe (or *saved-operands* + (some-nested-block #'node-opstack-unsafe-p + (find-enclosed-blocks form))))) + (when (and unsafe (null *saved-operands*)) + (save-existing-operands)) + + (compile-form form 'stack representation) + (when cast + (emit-checkcast cast)) + (when unsafe + (let ((register (allocate-register representation))) + (push register *saved-operands*) + (emit-move-from-stack register representation))) + + (push representation *operand-representations*))) + +(defun emit-variable-operand (variable) + "Pushes a variable onto the operand stack, if it's safe to do so. Otherwise +stores the value in a register." + (push (variable-representation variable) *operand-representations*) + (cond + ((and *saved-operands* + (variable-register variable)) + ;; we're in 'safe mode' and the variable is in a register, + ;; instead of binding a new register, just load the existing one + (push (variable-register variable) *saved-operands*)) + (t + (emit-push-variable variable) + (when *saved-operands* ;; safe-mode + (let ((register (allocate-register (variable-representation variable)))) + (push register *saved-operands*) + (emit-move-from-stack register (variable-representation variable))))))) + +(defun emit-register-operand (register representation) + (push representation *operand-representations*) + (cond (*saved-operands* + (push register *saved-operands*)) + (t + (emit-push-register register representation)))) + +(defun emit-thread-operand () + (ensure-thread-var-initialized) + (emit-register-operand *thread* nil)) + +(defun emit-load-externalized-object-operand (object) + (push nil *operand-representations*) + (emit-load-externalized-object object) + (when *saved-operands* ;; safe-mode + (let ((register (allocate-register nil))) + (push register *saved-operands*) + (emit 'astore register)))) + (defknown emit-unbox-fixnum () t) (defun emit-unbox-fixnum () (declare (optimize speed)) @@ -728,6 +862,19 @@ (sys::%format t "emit-move-from-stack general case~%") (aver nil)))) +(defknown emit-push-register (t &optional t) t) +(defun emit-push-register (source &optional representation) + (declare (optimize speed)) + (assert (fixnump source)) + (emit (ecase representation + ((:int :boolean :char) + 'iload) + (:long 'lload) + (:float 'fload) + (:double 'dload) + ((nil) 'aload)) + source)) + ;; Expects value on stack. (defknown emit-invoke-method (t t t) t) (defun emit-invoke-method (method-name target representation) @@ -808,7 +955,7 @@ keys-p more-keys-p) (with-code-to-method (class method) - (allocate-register) + (allocate-register nil) (unless (eq super +lisp-compiled-primitive+) (multiple-value-bind (req opt key key-p rest @@ -824,7 +971,7 @@ (emit-push-constant-int (length ,params)) (emit-anewarray +lisp-closure-parameter+) (astore (setf ,register *registers-allocated*)) - (allocate-register) + (allocate-register nil) (do* ((,count-sym 0 (1+ ,count-sym)) (,params ,params (cdr ,params)) (,param (car ,params) (car ,params))) @@ -1494,10 +1641,12 @@ (defun compile-binary-operation (op args target representation) (let ((arg1 (car args)) (arg2 (cadr args))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) - (emit-invokevirtual +lisp-object+ op - (lisp-object-arg-types 1) +lisp-object+) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2)) + (emit-invokevirtual +lisp-object+ op + (lisp-object-arg-types 1) +lisp-object+)) (fix-boxing representation nil) (emit-move-from-stack target representation))) @@ -1547,16 +1696,18 @@ (args (%cdr form)) (arg1 (%car args)) (arg2 (%cadr args))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) - (let ((LABEL1 (gensym)) - (LABEL2 (gensym))) - (emit (if (eq op 'EQ) 'if_acmpne 'if_acmpeq) LABEL1) - (emit-push-true representation) - (emit 'goto LABEL2) - (label LABEL1) - (emit-push-false representation) - (label LABEL2)) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2)) + (let ((LABEL1 (gensym)) + (LABEL2 (gensym))) + (emit (if (eq op 'EQ) 'if_acmpne 'if_acmpeq) LABEL1) + (emit-push-true representation) + (emit 'goto LABEL2) + (label LABEL1) + (emit-push-false representation) + (label LABEL2))) (emit-move-from-stack target representation)) t) @@ -1574,8 +1725,10 @@ (type2 (derive-compiler-type arg2))) (cond ((and (fixnum-type-p type1) (fixnum-type-p type2)) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack :int) + (with-operand-accumulation + ((compile-operand arg1 :int) + (compile-operand arg2 :int) + (maybe-emit-clear-values arg1 arg2))) (let ((label1 (gensym)) (label2 (gensym))) (emit 'if_icmpeq label1) @@ -1585,26 +1738,36 @@ (emit-push-true representation) (label label2))) ((fixnum-type-p type2) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 :int) + (maybe-emit-clear-values arg1 arg2))) (emit-ifne-for-eql representation '(:int))) ((fixnum-type-p type1) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 :int) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (emit 'swap) (emit-ifne-for-eql representation '(:int))) ((eq type2 'CHARACTER) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :char) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 :char) + (maybe-emit-clear-values arg1 arg2))) (emit-ifne-for-eql representation '(:char))) ((eq type1 'CHARACTER) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :char - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 :char) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (emit 'swap) (emit-ifne-for-eql representation '(:char))) (t - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (ecase representation (:boolean (emit-invokevirtual +lisp-object+ "eql" @@ -1621,8 +1784,10 @@ (let* ((args (cdr form)) (arg1 (first args)) (arg2 (second args))) - (compile-form arg1 'stack nil) - (compile-form arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (emit-invokestatic +lisp+ "memq" (lisp-object-arg-types 2) :boolean) (emit-move-from-stack target representation))) @@ -1637,8 +1802,10 @@ (arg1 (first args)) (arg2 (second args)) (type1 (derive-compiler-type arg1))) - (compile-form arg1 'stack nil) - (compile-form arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (cond ((eq type1 'SYMBOL) ; FIXME (emit-invokestatic +lisp+ "memq" (lisp-object-arg-types 2) :boolean)) @@ -1666,13 +1833,12 @@ (arg3 (third args))) (case (length args) ((2 3) - (compile-form arg1 'stack nil) - (compile-form arg2 'stack nil) - (cond ((null arg3) - (maybe-emit-clear-values arg1 arg2)) - (t - (compile-form arg3 'stack nil) - (maybe-emit-clear-values arg1 arg2 arg3))) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (when arg3 + (compile-operand arg3 nil)) + (maybe-emit-clear-values arg1 arg2 arg3))) (emit-invokestatic +lisp+ "get" (lisp-object-arg-types (if arg3 3 2)) +lisp-object+) @@ -1692,9 +1858,11 @@ (let ((arg1 (first args)) (arg2 (second args)) (arg3 (third args))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil - arg3 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (compile-operand arg3 nil) + (maybe-emit-clear-values arg1 arg2 arg3))) (emit-invokestatic +lisp+ "getf" (lisp-object-arg-types 3) +lisp-object+) (fix-boxing representation nil) @@ -1709,10 +1877,10 @@ (eq (derive-type (%caddr form)) 'HASH-TABLE)) (let ((key-form (%cadr form)) (ht-form (%caddr form))) - (compile-form ht-form 'stack nil) - (emit-checkcast +lisp-hash-table+) - (compile-form key-form 'stack nil) - (maybe-emit-clear-values ht-form key-form) + (with-operand-accumulation + ((compile-operand ht-form nil +lisp-hash-table+) + (compile-operand key-form nil) + (maybe-emit-clear-values ht-form key-form))) (emit-invokevirtual +lisp-hash-table+ "gethash1" (lisp-object-arg-types 1) +lisp-object+) (fix-boxing representation nil) @@ -1727,11 +1895,11 @@ (let ((key-form (%cadr form)) (ht-form (%caddr form)) (value-form (fourth form))) - (compile-form ht-form 'stack nil) - (emit-checkcast +lisp-hash-table+) - (compile-form key-form 'stack nil) - (compile-form value-form 'stack nil) - (maybe-emit-clear-values ht-form key-form value-form) + (with-operand-accumulation + ((compile-operand ht-form nil +lisp-hash-table+) + (compile-operand key-form nil) + (compile-operand value-form nil) + (maybe-emit-clear-values ht-form key-form value-form))) (cond (target (emit-invokevirtual +lisp-hash-table+ "puthash" (lisp-object-arg-types 2) +lisp-object+) @@ -1756,8 +1924,8 @@ (t nil))) -(defknown process-args (t) t) -(defun process-args (args) +(defknown process-args (t t) t) +(defun process-args (args stack) "Compiles forms specified as function call arguments. The results are either accumulated on the stack or in an array @@ -1765,27 +1933,76 @@ itself is *not* compiled by this function." (when args (let ((numargs (length args))) - (let ((must-clear-values nil)) + (let ((must-clear-values nil) + (unsafe-args (some-nested-block #'node-opstack-unsafe-p + (mapcan #'find-enclosed-blocks + args)))) (declare (type boolean must-clear-values)) - (cond ((<= numargs call-registers-limit) + (cond ((and unsafe-args + (<= numargs call-registers-limit)) + (let ((*register* *register*) + operand-registers) + (dolist (stack-item stack) + (let ((register (allocate-register nil))) + (push register operand-registers) + (emit-move-from-stack register stack-item))) + (setf operand-registers (reverse operand-registers)) + (dolist (arg args) + (push (allocate-register nil) operand-registers) + (compile-form arg (car operand-registers) nil) + (unless must-clear-values + (unless (single-valued-p arg) + (setf must-clear-values t)))) + (dolist (register (nreverse operand-registers)) + (aload register)))) + ((<= numargs call-registers-limit) (dolist (arg args) (compile-form arg 'stack nil) (unless must-clear-values (unless (single-valued-p arg) (setf must-clear-values t))))) (t - (emit-push-constant-int numargs) - (emit-anewarray +lisp-object+) - (let ((i 0)) - (dolist (arg args) - (emit 'dup) - (emit-push-constant-int i) - (compile-form arg 'stack nil) - (emit 'aastore) ; store value in array - (unless must-clear-values - (unless (single-valued-p arg) - (setf must-clear-values t))) - (incf i))))) + (let* ((*register* *register*) ;; ### FIXME: this doesn't work, but why not? + (array-register (allocate-register nil)) + saved-stack) + (when unsafe-args + (dolist (stack-item stack) + (let ((register (allocate-register nil))) + (push register saved-stack) + (emit-move-from-stack register stack-item)))) + (emit-push-constant-int numargs) + (emit-anewarray +lisp-object+) + ;; be operand stack safe by not accumulating + ;; any arguments on the stack. + ;; + ;; The overhead of storing+loading the array register + ;; at the beginning and ending is small: there are at + ;; least nine parameters to be calculated. + (astore array-register) + (let ((i 0)) + (dolist (arg args) + (cond + ((not (some-nested-block #'node-opstack-unsafe-p + (find-enclosed-blocks arg))) + (aload array-register) + (emit-push-constant-int i) + (compile-form arg 'stack nil)) + (t + (compile-form arg 'stack nil) + (aload array-register) + (emit 'swap) + (emit-push-constant-int i) + (emit 'swap))) + (emit 'aastore) ; store value in array + (unless must-clear-values + (unless (single-valued-p arg) + (setf must-clear-values t))) + (incf i)) + (when unsafe-args + (mapcar #'emit-push-register + saved-stack + (reverse stack))) + (aload array-register))))) (when must-clear-values (emit-clear-values))))) t) @@ -1853,26 +2070,28 @@ (aload 0))) (t (emit-load-externalized-object op))) - (process-args args) + (process-args args + (if (or (<= *speed* *debug*) *require-stack-frame*) + '(nil nil) '(nil))) (if (or (<= *speed* *debug*) *require-stack-frame*) (emit-call-thread-execute numargs) (emit-call-execute numargs)) (fix-boxing representation (derive-compiler-type form)) (emit-move-from-stack target representation)))) -(defun compile-call (args) +(defun compile-call (args stack) "Compiles a function call. Depending on the `*speed*' and `*debug*' settings, a stack frame is registered (or not)." (let ((numargs (length args))) (cond ((> *speed* *debug*) - (process-args args) + (process-args args stack) (emit-call-execute numargs)) (t (emit-push-current-thread) (emit 'swap) ; Stack: thread function - (process-args args) + (process-args args (list* (car stack) nil (cdr stack))) (emit-call-thread-execute numargs))))) (define-source-transform funcall (&whole form fun &rest args) @@ -1939,14 +2158,14 @@ (when (> *debug* *speed*) (return-from p2-funcall (compile-function-call form target representation))) (compile-forms-and-maybe-emit-clear-values (cadr form) 'stack nil) - (compile-call (cddr form)) + (compile-call (cddr form) '(nil)) (fix-boxing representation nil) (emit-move-from-stack target)) (defun duplicate-closure-array (compiland) (let* ((*register* *register*) - (register (allocate-register))) + (register (allocate-register nil))) (aload (compiland-closure-register compiland)) ;; src (emit-push-constant-int 0) ;; srcPos (emit-push-constant-int (length *closure-variables*)) @@ -2004,7 +2223,7 @@ (emit-invokestatic +lisp+ "makeCompiledClosure" (list +lisp-object+ +closure-binding-array+) +lisp-object+))))) - (process-args args) + (process-args args '(nil)) (emit-call-execute (length args)) (fix-boxing representation nil) (emit-move-from-stack target representation)) @@ -2059,15 +2278,16 @@ (common-rep (let ((LABEL1 (gensym)) (LABEL2 (gensym))) - (compile-forms-and-maybe-emit-clear-values - arg1 'stack common-rep - arg2 'stack common-rep) - (emit-numeric-comparison op common-rep LABEL1) - (emit-push-true representation) - (emit 'goto LABEL2) - (label LABEL1) - (emit-push-false representation) - (label LABEL2)) + (with-operand-accumulation + ((compile-operand arg1 common-rep) + (compile-operand arg2 common-rep) + (maybe-emit-clear-values arg1 arg2)) + (emit-numeric-comparison op common-rep LABEL1) + (emit-push-true representation) + (emit 'goto LABEL2) + (label LABEL1) + (emit-push-false representation) + (label LABEL2))) (emit-move-from-stack target representation) (return-from p2-numeric-comparison)) ((fixnump arg2) @@ -2108,20 +2328,20 @@ (unless (and (or (node-constant-p arg2) (var-ref-p arg2)) (node-constant-p arg3)) - (allocate-register))) + (allocate-register nil))) (arg3-register - (unless (node-constant-p arg3) (allocate-register)))) - (compile-form arg1 'stack :int) - (compile-form arg2 'stack :int) - (when arg2-register - (emit 'dup) - (emit 'istore arg2-register)) - (cond (arg3-register - (compile-form arg3 'stack :int) - (emit 'istore arg3-register) - (maybe-emit-clear-values arg1 arg2 arg3)) - (t - (maybe-emit-clear-values arg1 arg2))) + (unless (node-constant-p arg3) (allocate-register nil)))) + (with-operand-accumulation + ((compile-operand arg1 :int) + (compile-operand arg2 :int) + (when arg3-register + (compile-operand arg3 :int)) + (maybe-emit-clear-values arg1 arg2 arg3)) + (when arg3-register + (emit 'istore arg3-register)) + (when arg2-register + (emit 'dup) + (emit 'istore arg2-register))) ;; First test. (emit test LABEL1) ;; Second test. @@ -2371,16 +2591,20 @@ (when (check-arg-count form 2) (let* ((arg1 (%cadr form)) (arg2 (%caddr form))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :char - arg2 'stack :char) + (with-operand-accumulation + ((compile-operand arg1 :char) + (compile-operand arg2 :char) + (maybe-emit-clear-values arg1 arg2))) 'if_icmpne))) (defun p2-test-eq (form) (when (check-arg-count form 2) (let ((arg1 (%cadr form)) (arg2 (%caddr form))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) 'if_acmpne))) (defun p2-test-and (form) @@ -2409,38 +2633,52 @@ (type1 (derive-compiler-type arg1)) (type2 (derive-compiler-type arg2))) (cond ((and (fixnum-type-p type1) (fixnum-type-p type2)) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack :int) + (with-operand-accumulation + ((compile-operand arg1 :int) + (compile-operand arg2 :int) + (maybe-emit-clear-values arg1 arg2))) 'if_icmpne) ((and (eq type1 'CHARACTER) (eq type2 'CHARACTER)) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :char - arg2 'stack :char) + (with-operand-accumulation + ((compile-operand arg1 :char) + (compile-operand arg2 :char) + (maybe-emit-clear-values arg1 arg2))) 'if_icmpne) ((eq type2 'CHARACTER) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :char) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 :char) + (maybe-emit-clear-values arg1 arg2))) (emit-invokevirtual +lisp-object+ "eql" '(:char) :boolean) 'ifeq) ((eq type1 'CHARACTER) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :char - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 :char) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (emit 'swap) (emit-invokevirtual +lisp-object+ "eql" '(:char) :boolean) 'ifeq) ((fixnum-type-p type2) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 :int) + (maybe-emit-clear-values arg1 arg2))) (emit-invokevirtual +lisp-object+ "eql" '(:int) :boolean) 'ifeq) ((fixnum-type-p type1) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 :int) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (emit 'swap) (emit-invokevirtual +lisp-object+ "eql" '(:int) :boolean) 'ifeq) (t - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (emit-invokevirtual +lisp-object+ "eql" (lisp-object-arg-types 1) :boolean) 'ifeq))))) @@ -2454,14 +2692,18 @@ (arg1 (%cadr form)) (arg2 (%caddr form))) (cond ((fixnum-type-p (derive-compiler-type arg2)) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 :int) + (maybe-emit-clear-values arg1 arg2))) (emit-invokevirtual +lisp-object+ translated-op '(:int) :boolean)) (t - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (emit-invokevirtual +lisp-object+ translated-op (lisp-object-arg-types 1) :boolean))) @@ -2471,8 +2713,10 @@ (when (check-arg-count form 2) (let ((arg1 (%cadr form)) (arg2 (%caddr form))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (emit-invokevirtual +lisp-object+ "typep" (lisp-object-arg-types 1) +lisp-object+) (emit-push-nil) @@ -2482,8 +2726,10 @@ (when (check-arg-count form 2) (let ((arg1 (%cadr form)) (arg2 (%caddr form))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (emit-invokestatic +lisp+ "memq" (lisp-object-arg-types 2) :boolean) 'ifeq))) @@ -2492,8 +2738,10 @@ (when (check-arg-count form 2) (let ((arg1 (%cadr form)) (arg2 (%caddr form))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (emit-invokestatic +lisp+ "memql" (lisp-object-arg-types 2) :boolean) 'ifeq))) @@ -2508,25 +2756,33 @@ (if (/= arg1 arg2) :consequent :alternate)) ((and (fixnum-type-p type1) (fixnum-type-p type2)) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack :int) + (with-operand-accumulation + ((compile-operand arg1 :int) + (compile-operand arg2 :int) + (maybe-emit-clear-values arg1 arg2))) 'if_icmpeq) ((fixnum-type-p type2) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 :int) + (maybe-emit-clear-values arg1 arg2))) (emit-invokevirtual +lisp-object+ "isNotEqualTo" '(:int) :boolean) 'ifeq) ((fixnum-type-p type1) ;; FIXME Compile the args in reverse order and avoid the swap if ;; either arg is a fixnum or a lexical variable. - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 :int) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (emit 'swap) (emit-invokevirtual +lisp-object+ "isNotEqualTo" '(:int) :boolean) 'ifeq) (t - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (emit-invokevirtual +lisp-object+ "isNotEqualTo" (lisp-object-arg-types 1) :boolean) 'ifeq))))) @@ -2543,8 +2799,10 @@ (cond ((and (fixnump arg1) (fixnump arg2)) (if (funcall op arg1 arg2) :consequent :alternate)) ((and (fixnum-type-p type1) (fixnum-type-p type2)) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack :int) + (with-operand-accumulation + ((compile-operand arg1 :int) + (compile-operand arg2 :int) + (maybe-emit-clear-values arg1 arg2))) (ecase op (< 'if_icmpge) (<= 'if_icmpgt) @@ -2552,8 +2810,10 @@ (>= 'if_icmplt) (= 'if_icmpne))) ((and (java-long-type-p type1) (java-long-type-p type2)) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :long - arg2 'stack :long) + (with-operand-accumulation + ((compile-operand arg1 :long) + (compile-operand arg2 :long) + (maybe-emit-clear-values arg1 arg2))) (emit 'lcmp) (ecase op (< 'ifge) @@ -2562,8 +2822,10 @@ (>= 'iflt) (= 'ifne))) ((fixnum-type-p type2) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 :int) + (maybe-emit-clear-values arg1 arg2))) (emit-invokevirtual +lisp-object+ (ecase op (< "isLessThan") @@ -2576,8 +2838,10 @@ ((fixnum-type-p type1) ;; FIXME We can compile the args in reverse order and avoid ;; the swap if either arg is a fixnum or a lexical variable. - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 :int) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (emit 'swap) (emit-invokevirtual +lisp-object+ (ecase op @@ -2589,8 +2853,10 @@ '(:int) :boolean) 'ifeq) (t - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (emit-invokevirtual +lisp-object+ (ecase op (< "isLessThan") @@ -2621,8 +2887,10 @@ ;; ERROR CHECKING HERE! (let ((arg1 (second arg)) (arg2 (third arg))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (emit 'if_acmpeq LABEL1))) ((eq (derive-compiler-type arg) 'BOOLEAN) (compile-forms-and-maybe-emit-clear-values arg 'stack :boolean) @@ -2741,8 +3009,8 @@ (defun compile-multiple-value-prog1 (form target representation) (let ((first-subform (cadr form)) (subforms (cddr form)) - (result-register (allocate-register)) - (values-register (allocate-register))) + (result-register (allocate-register nil)) + (values-register (allocate-register nil))) ;; Make sure there are no leftover values from previous calls. (emit-clear-values) (compile-form first-subform result-register nil) @@ -2773,7 +3041,7 @@ (emit-invokevirtual +lisp-object+ "execute" nil +lisp-object+)) (3 (let* ((*register* *register*) - (function-register (allocate-register))) + (function-register (allocate-register nil))) (compile-form (second form) function-register nil) (compile-form (third form) 'stack nil) (aload function-register) @@ -2784,8 +3052,8 @@ (t ;; The general case. (let* ((*register* *register*) - (function-register (allocate-register)) - (values-register (allocate-register))) + (function-register (allocate-register nil)) + (values-register (allocate-register nil))) (compile-form (second form) 'stack nil) (emit-invokestatic +lisp+ "coerceToFunction" (lisp-object-arg-types 1) +lisp-object+) @@ -2903,8 +3171,8 @@ ) (defun restore-environment-and-make-handler (register label-START) - (let ((label-END (gensym)) - (label-EXIT (gensym))) + (let ((label-END (gensym "U")) + (label-EXIT (gensym "E"))) (emit 'goto label-EXIT) (label label-END) (restore-dynamic-environment register) @@ -2921,19 +3189,20 @@ (vars (second form)) (bind-special-p nil) (variables (m-v-b-vars block)) - (label-START (gensym))) + (label-START (gensym "F"))) (dolist (variable variables) (let ((special-p (variable-special-p variable))) (cond (special-p (setf bind-special-p t)) (t (unless (variable-closure-index variable) - (setf (variable-register variable) (allocate-register))))))) + (setf (variable-register variable) + (allocate-register nil))))))) ;; If we're going to bind any special variables... (when bind-special-p (dformat t "p2-m-v-b-node lastSpecialBinding~%") ;; Save current dynamic environment. - (setf (m-v-b-environment-register block) (allocate-register)) + (setf (m-v-b-environment-register block) (allocate-register nil)) (save-dynamic-environment (m-v-b-environment-register block)) (label label-START)) ;; Make sure there are no leftover values from previous calls. @@ -2945,8 +3214,8 @@ (compile-binding (car variables))) (t (let* ((*register* *register*) - (result-register (allocate-register)) - (values-register (allocate-register)) + (result-register (allocate-register nil)) + (values-register (allocate-register nil)) (LABEL1 (gensym)) (LABEL2 (gensym))) ;; Store primary value from values form in result register. @@ -3101,9 +3370,7 @@ (defun allocate-variable-register (variable) (setf (variable-register variable) - (if (= 2 (representation-size (variable-representation variable))) - (allocate-register-pair) - (allocate-register)))) + (allocate-register (variable-representation variable)))) (defun emit-move-to-variable (variable) (let ((representation (variable-representation variable))) @@ -3213,9 +3480,9 @@ (allocate-variable-register variable)) (when (variable-special-p variable) (setf (variable-binding-register variable) - (allocate-register))) + (allocate-register nil))) (cond ((variable-special-p variable) - (let ((temp-register (allocate-register))) + (let ((temp-register (allocate-register nil))) ;; FIXME: this permanently allocates a register ;; which has only a single local use (push (cons temp-register variable) @@ -3277,7 +3544,8 @@ (not (variable-special-p variable)) (eq (variable-declared-type variable) 'BOOLEAN)) (setf (variable-representation variable) :boolean) - (setf (variable-register variable) (allocate-register)) + (setf (variable-register variable) + (allocate-register nil)) (emit 'iconst_0) (emit 'istore (variable-register variable)) (setf boundp t)) @@ -3307,11 +3575,13 @@ (unless (or boundp (variable-special-p variable)) (unless (or (variable-closure-index variable) (variable-register variable)) - (setf (variable-register variable) (allocate-register)))) + (setf (variable-register variable) + (allocate-register nil)))) (push variable *visible-variables*) (unless boundp (when (variable-special-p variable) - (setf (variable-binding-register variable) (allocate-register))) + (setf (variable-binding-register variable) + (allocate-register nil))) (compile-binding variable)) (maybe-generate-type-check variable))) (when must-clear-values @@ -3324,7 +3594,7 @@ (form (let-form block)) (*visible-variables* *visible-variables*) (specialp nil) - (label-START (gensym))) + (label-START (gensym "F"))) ;; Walk the variable list looking for special bindings and unused lexicals. (dolist (variable (let-vars block)) (cond ((variable-special-p variable) @@ -3334,7 +3604,7 @@ ;; If there are any special bindings... (when specialp ;; We need to save current dynamic environment. - (setf (let-environment-register block) (allocate-register)) + (setf (let-environment-register block) (allocate-register nil)) (save-dynamic-environment (let-environment-register block)) (label label-START)) (propagate-vars block) @@ -3371,13 +3641,13 @@ (*register* *register*) (form (tagbody-form block)) (body (cdr form)) - (BEGIN-BLOCK (gensym)) - (END-BLOCK (gensym)) - (RETHROW (gensym)) - (EXIT (gensym)) + (BEGIN-BLOCK (gensym "F")) + (END-BLOCK (gensym "U")) + (RETHROW (gensym "T")) + (EXIT (gensym "E")) (must-clear-values nil) (specials-register (when (tagbody-non-local-go-p block) - (allocate-register)))) + (allocate-register nil)))) ;; Scan for tags. (dolist (tag (tagbody-tags block)) (push tag *visible-tags*)) @@ -3411,11 +3681,11 @@ (emit 'goto EXIT) (when (tagbody-non-local-go-p block) ; We need a handler to catch non-local GOs. - (let* ((HANDLER (gensym)) - (EXTENT-EXIT-HANDLER (gensym)) + (let* ((HANDLER (gensym "H")) + (EXTENT-EXIT-HANDLER (gensym "HE")) (*register* *register*) - (go-register (allocate-register)) - (tag-register (allocate-register))) + (go-register (allocate-register nil)) + (tag-register (allocate-register nil))) (label HANDLER) ;; The Go object is on the runtime stack. Stack depth is 1. (emit 'dup) @@ -3465,9 +3735,11 @@ (defun p2-go (form target representation) ;; FIXME What if we're called with a non-NIL representation? (declare (ignore target representation)) - (let* ((name (cadr form)) - (tag (find-tag name)) - (tag-block (when tag (tag-block tag)))) + (let* ((node form) + (form (node-form form)) + (name (cadr form)) + (tag (jump-target-tag node)) + (tag-block (when tag (jump-target-block node)))) (unless tag (error "p2-go: tag not found: ~S" name)) (when (and (eq (tag-compiland tag) *current-compiland*) @@ -3571,11 +3843,11 @@ (aver (block-node-p block))) (let* ((*blocks* (cons block *blocks*)) (*register* *register*) - (BEGIN-BLOCK (gensym)) - (END-BLOCK (gensym)) + (BEGIN-BLOCK (gensym "F")) + (END-BLOCK (gensym "U")) (BLOCK-EXIT (block-exit block)) (specials-register (when (block-non-local-return-p block) - (allocate-register)))) + (allocate-register nil)))) (setf (block-target block) target) (when (block-id-variable block) ;; we have a block variable; that should be a closure variable @@ -3595,8 +3867,8 @@ (when (block-non-local-return-p block) ;; We need a handler to catch non-local RETURNs. (emit 'goto BLOCK-EXIT) ; Jump over handler, when inserting one - (let ((HANDLER (gensym)) - (EXTENT-EXIT-HANDLER (gensym)) + (let ((HANDLER (gensym "H")) + (EXTENT-EXIT-HANDLER (gensym "HE")) (THIS-BLOCK (gensym))) (label HANDLER) ;; The Return object is on the runtime stack. Stack depth is 1. @@ -3631,9 +3903,11 @@ (defun p2-return-from (form target representation) ;; FIXME What if we're called with a non-NIL representation? (declare (ignore target representation)) - (let* ((name (second form)) + (let* ((node form) + (form (node-form form)) + (name (second form)) (result-form (third form)) - (block (find-block name))) + (block (jump-target-block node))) (when (null block) (error "No block named ~S is currently visible." name)) (let ((compiland *current-compiland*)) @@ -3651,12 +3925,13 @@ (return-from p2-return-from)))) ;; Non-local RETURN. (aver (block-non-local-return-p block)) - (emit-push-variable (block-id-variable block)) - (emit-load-externalized-object (block-name block)) (emit-clear-values) - (compile-form result-form 'stack nil) - (emit-invokestatic +lisp+ "nonLocalReturn" (lisp-object-arg-types 3) - +lisp-object+) + (with-operand-accumulation + ((emit-variable-operand (block-id-variable block)) + (emit-load-externalized-object-operand (block-name block)) + (compile-operand result-form nil)) + (emit-invokestatic +lisp+ "nonLocalReturn" (lisp-object-arg-types 3) + +lisp-object+)) ;; Following code will not be reached, but is needed for JVM stack ;; consistency. (emit 'areturn))) @@ -3683,15 +3958,26 @@ (define-inlined-function p2-cons (form target representation) ((check-arg-count form 2)) - (emit-new +lisp-cons+) - (emit 'dup) (let* ((args (%cdr form)) (arg1 (%car args)) - (arg2 (%cadr args))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil)) - (emit-invokespecial-init +lisp-cons+ (lisp-object-arg-types 2)) - (emit-move-from-stack target)) + (arg2 (%cadr args)) + (cons-register (when (some-nested-block #'node-opstack-unsafe-p + (find-enclosed-blocks args)) + (allocate-register nil)))) + (emit-new +lisp-cons+) + (if cons-register + (astore cons-register) + (emit 'dup)) + (with-operand-accumulation + ((when cons-register + (emit-register-operand cons-register nil)) + (compile-operand arg1 nil) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) + (emit-invokespecial-init +lisp-cons+ (lisp-object-arg-types 2)) + (when cons-register + (emit-push-register cons-register nil)) + (emit-move-from-stack target))) (defun compile-progn (form target representation) (compile-progn-body (cdr form) target) @@ -3721,19 +4007,20 @@ (values-form (caddr form)) (*register* *register*) (environment-register - (setf (progv-environment-register block) (allocate-register))) - (label-START (gensym))) - (compile-form symbols-form 'stack nil) - (compile-form values-form 'stack nil) - (unless (and (single-valued-p symbols-form) - (single-valued-p values-form)) - (emit-clear-values)) - (save-dynamic-environment environment-register) - (label label-START) - ;; Compile call to Lisp.progvBindVars(). - (emit-push-current-thread) - (emit-invokestatic +lisp+ "progvBindVars" - (list +lisp-object+ +lisp-object+ +lisp-thread+) nil) + (setf (progv-environment-register block) (allocate-register nil))) + (label-START (gensym "F"))) + (with-operand-accumulation + ((compile-operand symbols-form nil) + (compile-operand values-form nil)) + (unless (and (single-valued-p symbols-form) + (single-valued-p values-form)) + (emit-clear-values)) + (save-dynamic-environment environment-register) + (label label-START) + ;; Compile call to Lisp.progvBindVars(). + (emit-push-current-thread) + (emit-invokestatic +lisp+ "progvBindVars" + (list +lisp-object+ +lisp-object+ +lisp-thread+) nil)) ;; Implicit PROGN. (let ((*blocks* (cons block *blocks*))) (compile-progn-body (cdddr form) target representation)) @@ -3762,32 +4049,52 @@ (define-inlined-function p2-rplacd (form target representation) ((check-arg-count form 2)) - (let ((args (cdr form))) - (compile-form (first args) 'stack nil) - (when target - (emit 'dup)) - (compile-form (second args) 'stack nil) + (let* ((args (cdr form)) + (*register* *register*) + (target-register (allocate-register nil))) + (with-operand-accumulation + ((accumulate-operand (nil + :unsafe-p (some-nested-block + #'node-opstack-unsafe-p + (find-enclosed-blocks (first args)))) + (compile-form (first args) 'stack nil) + (when target-register + (emit 'dup) + (astore target-register))) + (compile-operand (second args) nil))) + (maybe-emit-clear-values (car args) (cadr args)) (emit-invokevirtual +lisp-object+ "setCdr" (lisp-object-arg-types 1) nil) - (when target + (when target-register + (aload target-register) (fix-boxing representation nil) (emit-move-from-stack target representation)))) (define-inlined-function p2-set-car/cdr (form target representation) ((check-arg-count form 2)) - (let ((op (%car form)) - (args (%cdr form))) - (compile-form (%car args) 'stack nil) - (compile-form (%cadr args) 'stack nil) - (when target - (emit-dup nil :past nil)) + (let* ((op (%car form)) + (args (%cdr form)) + (*register* *register*) + (target-register (when target (allocate-register nil)))) + (with-operand-accumulation + ((compile-operand (%car args) nil) + (accumulate-operand (nil + :unsafe-p (some-nested-block + #'node-opstack-unsafe-p + (find-enclosed-blocks (cadr args)))) + (compile-form (%cadr args) 'stack nil) + (when target-register + (emit 'dup) + (astore target-register))) + (maybe-emit-clear-values (car args) (cadr args)))) (emit-invokevirtual +lisp-object+ (if (eq op 'sys:set-car) "setCar" "setCdr") (lisp-object-arg-types 1) nil) - (when target + (when target-register + (aload target-register) (fix-boxing representation nil) (emit-move-from-stack target representation)))) @@ -3898,7 +4205,7 @@ (let ((variable (local-function-variable local-function))) (aver (null (variable-register variable))) (unless (variable-closure-index variable) - (setf (variable-register variable) (allocate-register))))) + (setf (variable-register variable) (allocate-register nil))))) (dolist (local-function local-functions) (p2-labels-process-compiland local-function)) (dolist (special (labels-free-specials block)) @@ -4130,12 +4437,24 @@ (compile-forms-and-maybe-emit-clear-values arg1 nil nil arg2 target representation)) ((eql (fixnum-constant-value type2) -1) - (compile-forms-and-maybe-emit-clear-values arg1 target representation - arg2 nil nil)) + (let ((target-register + (if (or (not (eq target 'stack)) + (not (some-nested-block #'node-opstack-unsafe-p + (find-enclosed-blocks arg2)))) + target + (allocate-register representation)))) + (compile-form arg1 target-register representation) + (compile-form arg2 nil nil) + (when (and (eq target 'stack) + (not (eq target-register 'stack))) + (emit-push-register target-register)) + (maybe-emit-clear-values arg1 arg2))) ((and (fixnum-type-p type1) (fixnum-type-p type2)) ;; Both arguments are fixnums. - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack :int) + (with-operand-accumulation + ((compile-operand arg1 :int) + (compile-operand arg2 :int) + (maybe-emit-clear-values arg1 arg2))) (emit 'iand) (convert-representation :int representation) (emit-move-from-stack target representation)) @@ -4144,15 +4463,19 @@ (and (fixnum-type-p type2) (compiler-subtypep type2 'unsigned-byte))) ;; One of the arguments is a positive fixnum. - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack :int) + (with-operand-accumulation + ((compile-operand arg1 :int) + (compile-operand arg2 :int) + (maybe-emit-clear-values arg1 arg2))) (emit 'iand) (convert-representation :int representation) (emit-move-from-stack target representation)) ((and (java-long-type-p type1) (java-long-type-p type2)) ;; Both arguments are longs. - (compile-forms-and-maybe-emit-clear-values arg1 'stack :long - arg2 'stack :long) + (with-operand-accumulation + ((compile-operand arg1 :long) + (compile-operand arg2 :long) + (maybe-emit-clear-values arg1 arg2))) (emit 'land) (convert-representation :long representation) (emit-move-from-stack target representation)) @@ -4161,29 +4484,37 @@ (and (java-long-type-p type2) (compiler-subtypep type2 'unsigned-byte))) ;; One of the arguments is a positive long. - (compile-forms-and-maybe-emit-clear-values arg1 'stack :long - arg2 'stack :long) + (with-operand-accumulation + ((compile-operand arg1 :long) + (compile-operand arg2 :long) + (maybe-emit-clear-values arg1 arg2))) (emit 'land) (convert-representation :long representation) (emit-move-from-stack target representation)) ((fixnum-type-p type2) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 :int) + (maybe-emit-clear-values arg1 arg2))) (emit-invokevirtual +lisp-object+ "LOGAND" '(:int) +lisp-object+) (fix-boxing representation result-type) (emit-move-from-stack target representation)) ((fixnum-type-p type1) ;; arg1 is a fixnum, but arg2 is not - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 :int) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) ;; swap args (emit 'swap) (emit-invokevirtual +lisp-object+ "LOGAND" '(:int) +lisp-object+) (fix-boxing representation result-type) (emit-move-from-stack target representation)) (t - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (emit-invokevirtual +lisp-object+ "LOGAND" (lisp-object-arg-types 1) +lisp-object+) (fix-boxing representation result-type) @@ -4214,14 +4545,14 @@ type2 (derive-compiler-type arg2) result-type (derive-compiler-type form)) (cond ((and (fixnum-constant-value type1) (fixnum-constant-value type2)) - (compile-forms-and-maybe-emit-clear-values arg1 nil nil - arg2 nil nil) (compile-constant (logior (fixnum-constant-value type1) (fixnum-constant-value type2)) target representation)) ((and (fixnum-type-p type1) (fixnum-type-p type2)) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack :int) + (with-operand-accumulation + ((compile-operand arg1 :int) + (compile-operand arg2 :int) + (maybe-emit-clear-values arg1 arg2))) (emit 'ior) (convert-representation :int representation) (emit-move-from-stack target representation)) @@ -4229,16 +4560,32 @@ (compile-forms-and-maybe-emit-clear-values arg1 nil nil arg2 target representation)) ((and (eql (fixnum-constant-value type2) 0) (< *safety* 3)) - (compile-forms-and-maybe-emit-clear-values arg1 target representation - arg2 nil nil)) + (let ((target-register + (if (or (not (eq target 'stack)) + (not (some-nested-block #'node-opstack-unsafe-p + (find-enclosed-blocks arg2)))) + target + (allocate-register representation)))) + (compile-form arg1 target-register representation) + (compile-form arg2 nil nil) + (when (and (eq target 'stack) + (not (eq target-register 'stack))) + (emit-push-register target-register)) + (maybe-emit-clear-values arg1 arg2))) ((or (eq representation :long) (and (java-long-type-p type1) (java-long-type-p type2))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :long - arg2 'stack :long) + (with-operand-accumulation + ((compile-operand arg1 :long) + (compile-operand arg2 :long) + (maybe-emit-clear-values arg1 arg2))) (emit 'lor) (convert-representation :long representation) (emit-move-from-stack target representation)) ((fixnum-type-p type2) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 :int) + (maybe-emit-clear-values arg1 arg2))) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :int) (emit-invokevirtual +lisp-object+ "LOGIOR" '(:int) +lisp-object+) @@ -4246,16 +4593,20 @@ (emit-move-from-stack target representation)) ((fixnum-type-p type1) ;; arg1 is of fixnum type, but arg2 is not - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 :int) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) ;; swap args (emit 'swap) (emit-invokevirtual +lisp-object+ "LOGIOR" '(:int) +lisp-object+) (fix-boxing representation result-type) (emit-move-from-stack target representation)) (t - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (emit-invokevirtual +lisp-object+ "LOGIOR" (lisp-object-arg-types 1) +lisp-object+) (fix-boxing representation result-type) @@ -4288,28 +4639,33 @@ (setf type1 (derive-compiler-type arg1) type2 (derive-compiler-type arg2) result-type (derive-compiler-type form)) - (cond ((eq representation :int) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack :int) - (emit 'ixor)) - ((and (fixnum-type-p type1) (fixnum-type-p type2)) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack :int) + (cond ((or (eq representation :int) + (and (fixnum-type-p type1) (fixnum-type-p type2))) + (with-operand-accumulation + ((compile-operand arg1 :int) + (compile-operand arg2 :int) + (maybe-emit-clear-values arg1 arg2))) (emit 'ixor) (convert-representation :int representation)) ((and (java-long-type-p type1) (java-long-type-p type2)) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :long - arg2 'stack :long) + (with-operand-accumulation + ((compile-operand arg1 :long) + (compile-operand arg2 :long) + (maybe-emit-clear-values arg1 arg2))) (emit 'lxor) (convert-representation :long representation)) ((fixnum-type-p type2) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 :int) + (maybe-emit-clear-values arg1 arg2))) (emit-invokevirtual +lisp-object+ "LOGXOR" '(:int) +lisp-object+) (fix-boxing representation result-type)) (t - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (emit-invokevirtual +lisp-object+ "LOGXOR" (lisp-object-arg-types 1) +lisp-object+) (fix-boxing representation result-type))) @@ -4394,9 +4750,11 @@ (emit-move-from-stack target representation)))) ((and (fixnum-type-p size-type) (fixnum-type-p position-type)) - (compile-forms-and-maybe-emit-clear-values size-arg 'stack :int - position-arg 'stack :int - arg3 'stack nil) + (with-operand-accumulation + ((compile-operand size-arg :int) + (compile-operand position-arg :int) + (compile-operand arg3 nil) + (maybe-emit-clear-values size-arg position-arg arg3))) (emit 'dup_x2) ;; use not supported by emit-dup: 3 values involved (emit 'pop) (emit-invokevirtual +lisp-object+ "LDB" '(:int :int) +lisp-object+) @@ -4416,19 +4774,25 @@ (cond ((and (eq representation :int) (fixnum-type-p type1) (fixnum-type-p type2)) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack :int) + (with-operand-accumulation + ((compile-operand arg1 :int) + (compile-operand arg2 :int) + (maybe-emit-clear-values arg1 arg2))) (emit-invokestatic +lisp+ "mod" '(:int :int) :int) (emit-move-from-stack target representation)) ((fixnum-type-p type2) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 :int) + (maybe-emit-clear-values arg1 arg2))) (emit-invokevirtual +lisp-object+ "MOD" '(:int) +lisp-object+) (fix-boxing representation nil) ; FIXME use derived result type (emit-move-from-stack target representation)) (t - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (emit-invokevirtual +lisp-object+ "MOD" (lisp-object-arg-types 1) +lisp-object+) (fix-boxing representation nil) ; FIXME use derived result type @@ -4503,8 +4867,10 @@ (emit-move-from-stack target representation)) (2 (let ((arg2 (second args))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :boolean) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 :boolean) + (maybe-emit-clear-values arg1 arg2))) (emit-invokestatic +lisp-class+ "findClass" (list +lisp-object+ :boolean) +lisp-object+) (fix-boxing representation nil) @@ -4520,8 +4886,10 @@ (arg2 (second args))) (case arg-count (2 - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil))) + (maybe-emit-clear-values arg1 arg2) (emit 'swap) (cond (target (emit-invokevirtual +lisp-object+ "VECTOR_PUSH_EXTEND" @@ -4540,8 +4908,10 @@ (let* ((args (cdr form)) (arg1 (first args)) (arg2 (second args))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil))) + (maybe-emit-clear-values arg1 arg2) (emit-invokevirtual +lisp-object+ "SLOT_VALUE" (lisp-object-arg-types 1) +lisp-object+) (fix-boxing representation nil) @@ -4556,13 +4926,15 @@ (arg2 (second args)) (arg3 (third args)) (*register* *register*) - (value-register (when target (allocate-register)))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil - arg3 'stack nil) + (value-register (when target (allocate-register nil)))) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (compile-operand arg3 nil))) (when value-register (emit 'dup) (astore value-register)) + (maybe-emit-clear-values arg1 arg2 arg3) (emit-invokevirtual +lisp-object+ "setSlotValue" (lisp-object-arg-types 2) nil) (when value-register @@ -4593,9 +4965,9 @@ (type2 (derive-compiler-type arg2))) (cond ((and (compiler-subtypep type1 '(UNSIGNED-BYTE 8)) (eq type2 'STREAM)) - (compile-form arg1 'stack :int) - (compile-form arg2 'stack nil) - (emit-checkcast +lisp-stream+) + (with-operand-accumulation + ((compile-operand arg1 :int) + (compile-operand arg2 nil +lisp-stream+))) (maybe-emit-clear-values arg1 arg2) (emit 'swap) (emit-invokevirtual +lisp-stream+ "_writeByte" '(:int) nil) @@ -4603,8 +4975,9 @@ (emit-push-nil) (emit-move-from-stack target))) ((fixnum-type-p type1) - (compile-form arg1 'stack :int) - (compile-form arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 :int) + (compile-operand arg2 nil))) (maybe-emit-clear-values arg1 arg2) (emit-invokestatic +lisp+ "writeByte" (list :int +lisp-object+) nil) @@ -5184,9 +5557,9 @@ (type2 (derive-type arg2)) (test (if (memq type1 '(SYMBOL NULL)) 'eq 'eql))) (cond ((subtypep type2 'VECTOR) - (compile-form arg1 'stack nil) - (compile-form arg2 'stack nil) - (emit-checkcast +lisp-abstract-vector+) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil +lisp-abstract-vector+))) (maybe-emit-clear-values arg1 arg2) (emit 'swap) (emit-invokevirtual +lisp-abstract-vector+ @@ -5226,7 +5599,9 @@ (cons-heads (if list-star-p (butlast args 1) args))) - (cond ((>= 4 length 1) + (cond ((and (not (some-nested-block #'node-opstack-unsafe-p + (find-enclosed-blocks args))) + (>= 4 length 1)) (dolist (cons-head cons-heads) (emit-new +lisp-cons+) (emit 'dup) @@ -5262,10 +5637,12 @@ ((check-arg-count form 2)) (let ((index-form (second form)) (list-form (third form))) - (compile-forms-and-maybe-emit-clear-values index-form 'stack :int - list-form 'stack nil) - (emit 'swap) - (emit-invokevirtual +lisp-object+ "NTH" '(:int) +lisp-object+) + (with-operand-accumulation + ((compile-operand index-form :int) + (compile-operand list-form nil) + (maybe-emit-clear-values index-form list-form)) + (emit 'swap) + (emit-invokevirtual +lisp-object+ "NTH" '(:int) +lisp-object+)) (fix-boxing representation nil) ; FIXME use derived result type (emit-move-from-stack target representation))) @@ -5289,16 +5666,17 @@ (dformat t "p2-times case 1a~%") (compile-constant value target representation)) (result-rep - (compile-forms-and-maybe-emit-clear-values - arg1 'stack result-rep - arg2 'stack result-rep) - (emit (case result-rep - (:int 'imul) - (:long 'lmul) - (:float 'fmul) - (:double 'dmul) - (t - (sys::format t "p2-times: unsupported rep case")))) + (with-operand-accumulation + ((compile-operand arg1 result-rep) + (compile-operand arg2 result-rep) + (maybe-emit-clear-values arg1 arg2)) + (emit (case result-rep + (:int 'imul) + (:long 'lmul) + (:float 'fmul) + (:double 'dmul) + (t + (sys::format t "p2-times: unsupported rep case"))))) (convert-representation result-rep representation) (emit-move-from-stack target representation)) ((fixnump arg2) @@ -5323,8 +5701,10 @@ (3 (let* ((op (%car form)) (args (%cdr form)) (arg1 (%car args)) - (arg2 (%cadr args))) + (arg2 (%cadr args)) + (*register* *register*)) (when (null target) + ;; compile for effect (compile-forms-and-maybe-emit-clear-values arg1 nil nil arg2 nil nil) (return-from p2-min/max)) @@ -5334,38 +5714,51 @@ (let ((type1 (derive-compiler-type arg1)) (type2 (derive-compiler-type arg2))) (cond ((and (java-long-type-p type1) (java-long-type-p type2)) - (let ((common-rep (if (and (fixnum-type-p type1) - (fixnum-type-p type2)) - :int :long)) - (LABEL1 (gensym))) - (compile-form arg1 'stack common-rep) - (emit-dup common-rep) + (let* ((common-rep (if (and (fixnum-type-p type1) + (fixnum-type-p type2)) + :int :long)) + (LABEL1 (gensym)) + (LABEL2 (gensym)) + (arg1-register (allocate-register common-rep)) + (arg2-register (allocate-register common-rep))) + (compile-form arg1 arg1-register common-rep) (compile-form arg2 'stack common-rep) - (emit-dup common-rep :past common-rep) + (emit-dup common-rep) + (emit-move-from-stack arg2-register common-rep) + (emit-push-register arg1-register common-rep) + ;; note: we've now reversed the arguments on the stack! (emit-numeric-comparison (if (eq op 'max) '<= '>=) common-rep LABEL1) - (emit-swap common-rep common-rep) + (emit-push-register arg1-register common-rep) + (emit 'goto LABEL2) (label LABEL1) - (emit-move-from-stack nil common-rep) + (emit-push-register arg2-register common-rep) + (label LABEL2) (convert-representation common-rep representation) (emit-move-from-stack target representation))) (t - (compile-form arg1 'stack nil) - (emit-dup nil) - (compile-form arg2 'stack nil) - (emit-dup nil :past nil) - (emit-invokevirtual +lisp-object+ - (if (eq op 'max) - "isLessThanOrEqualTo" + (let* ((arg1-register (allocate-register nil)) + (arg2-register (allocate-register nil))) + (compile-form arg1 arg1-register nil) + (compile-form arg2 'stack nil) + (emit-dup nil) + (astore arg2-register) + (emit-push-register arg1-register nil) + (emit-invokevirtual +lisp-object+ + (if (eq op 'max) + "isLessThanOrEqualTo" "isGreaterThanOrEqualTo") - (lisp-object-arg-types 1) :boolean) - (let ((LABEL1 (gensym))) - (emit 'ifeq LABEL1) - (emit 'swap) - (label LABEL1) - (emit 'pop)) - (fix-boxing representation nil) - (emit-move-from-stack target representation)))))) + (lisp-object-arg-types 1) :boolean) + (let ((LABEL1 (gensym)) + (LABEL2 (gensym))) + (emit 'ifeq LABEL1) + (emit-push-register arg1-register nil) + (emit 'goto LABEL2) + (label LABEL1) + (emit-push-register arg2-register nil) + (label LABEL2)) + (fix-boxing representation nil) + (emit-move-from-stack target representation))))))) (t (p2-min/max `(,(car form) (,(car form) ,(second form) ,(third form)) ,@(nthcdr 3 form)) target representation)))) @@ -5395,19 +5788,20 @@ arg2 nil nil) (emit-move-from-stack target representation)) (result-rep - (compile-forms-and-maybe-emit-clear-values - arg1 'stack result-rep - arg2 'stack result-rep) - (emit (case result-rep - (:int 'iadd) - (:long 'ladd) - (:float 'fadd) - (:double 'dadd) - (t - (sys::format - t "p2-plus: Unexpected result-rep ~S for form ~S." - result-rep form) - (assert nil)))) + (with-operand-accumulation + ((compile-operand arg1 result-rep) + (compile-operand arg2 result-rep) + (maybe-emit-clear-values arg1 arg2)) + (emit (case result-rep + (:int 'iadd) + (:long 'ladd) + (:float 'fadd) + (:double 'dadd) + (t + (sys::format + t "p2-plus: Unexpected result-rep ~S for form ~S." + result-rep form) + (assert nil))))) (convert-representation result-rep representation) (emit-move-from-stack target representation)) ((eql arg2 1) @@ -5417,13 +5811,15 @@ (compile-forms-and-maybe-emit-clear-values arg2 'stack nil) (emit-invoke-method "incr" target representation)) ((or (fixnum-type-p type1) (fixnum-type-p type2)) - (compile-forms-and-maybe-emit-clear-values - arg1 'stack (when (fixnum-type-p type1) :int) - arg2 'stack (when (null (fixnum-type-p type1)) :int)) - (when (fixnum-type-p type1) - (emit 'swap)) - (emit-invokevirtual +lisp-object+ "add" - '(:int) +lisp-object+) + (with-operand-accumulation + ((compile-operand arg1 (when (fixnum-type-p type1) :int)) + (compile-operand arg2 (when (null (fixnum-type-p type1)) + :int)) + (maybe-emit-clear-values arg1 arg2)) + (when (fixnum-type-p type1) + (emit 'swap)) + (emit-invokevirtual +lisp-object+ "add" + '(:int) +lisp-object+)) (fix-boxing representation result-type) (emit-move-from-stack target representation)) (t @@ -5475,27 +5871,29 @@ (cond ((and (numberp arg1) (numberp arg2)) (compile-constant (- arg1 arg2) target representation)) (result-rep - (compile-forms-and-maybe-emit-clear-values - arg1 'stack result-rep - arg2 'stack result-rep) - (emit (case result-rep - (:int 'isub) - (:long 'lsub) - (:float 'fsub) - (:double 'dsub) - (t - (sys::%format t "p2-minus sub-instruction (rep: ~S); form: ~S~%" - result-rep form) - (assert nil)))) + (with-operand-accumulation + ((compile-operand arg1 result-rep) + (compile-operand arg2 result-rep) + (maybe-emit-clear-values arg1 arg2)) + (emit (case result-rep + (:int 'isub) + (:long 'lsub) + (:float 'fsub) + (:double 'dsub) + (t + (sys::%format t "p2-minus sub-instruction (rep: ~S); form: ~S~%" + result-rep form) + (assert nil))))) (convert-representation result-rep representation) (emit-move-from-stack target representation)) ((fixnum-type-p type2) - (compile-forms-and-maybe-emit-clear-values - arg1 'stack nil - arg2 'stack :int) - (emit-invokevirtual +lisp-object+ - "subtract" - '(:int) +lisp-object+) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 :int) + (maybe-emit-clear-values arg1 arg2)) + (emit-invokevirtual +lisp-object+ + "subtract" + '(:int) +lisp-object+)) (fix-boxing representation result-type) (emit-move-from-stack target representation)) (t @@ -5514,29 +5912,24 @@ (arg2 (%cadr args)) (type1 (derive-compiler-type arg1)) (type2 (derive-compiler-type arg2))) - (cond ((and (eq representation :char) - (zerop *safety*)) - (compile-form arg1 'stack nil) - (emit-checkcast +lisp-abstract-string+) - (compile-form arg2 'stack :int) - (maybe-emit-clear-values arg1 arg2) - (emit-invokevirtual +lisp-abstract-string+ "charAt" - '(:int) :char) - (emit-move-from-stack target representation)) - ((and (eq representation :char) + (cond ((or (and (eq representation :char) + (zerop *safety*)) + (and (eq representation :char) (or (eq op 'CHAR) (< *safety* 3)) (compiler-subtypep type1 'STRING) - (fixnum-type-p type2)) - (compile-form arg1 'stack nil) - (emit-checkcast +lisp-abstract-string+) - (compile-form arg2 'stack :int) + (fixnum-type-p type2))) + (with-operand-accumulation + ((compile-operand arg1 nil +lisp-abstract-string+) + (compile-operand arg2 :int))) (maybe-emit-clear-values arg1 arg2) (emit-invokevirtual +lisp-abstract-string+ "charAt" '(:int) :char) (emit-move-from-stack target representation)) ((fixnum-type-p type2) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 :int) + (maybe-emit-clear-values arg1 arg2))) (emit-invokevirtual +lisp-object+ (symbol-name op) ;; "CHAR" or "SCHAR" '(:int) +lisp-object+) @@ -5564,17 +5957,21 @@ (fixnum-type-p type2) (compiler-subtypep type3 'CHARACTER)) (let* ((*register* *register*) - (value-register (when target (allocate-register))) + (value-register (when target (allocate-register nil))) (class (if (eq op 'SCHAR) +lisp-simple-string+ +lisp-abstract-string+))) - (compile-form arg1 'stack nil) - (emit-checkcast class) - (compile-form arg2 'stack :int) - (compile-form arg3 'stack :char) - (when target - (emit 'dup) - (emit-move-from-stack value-register :char)) + (with-operand-accumulation + ((compile-operand arg1 nil class) + (compile-operand arg2 :int) + (accumulate-operand (:char + :unsafe-p (some-nested-block + #'node-opstack-unsafe-p + (find-enclosed-blocks arg3))) + (compile-form arg3 'stack :char) + (when target + (emit 'dup) + (emit-move-from-stack value-register :char))))) (maybe-emit-clear-values arg1 arg2 arg3) (emit-invokevirtual class "setCharAt" '(:int :char) nil) (when target @@ -5590,8 +5987,10 @@ (neq representation :char)) ; FIXME (let ((arg1 (%cadr form)) (arg2 (%caddr form))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 :int))) + (maybe-emit-clear-values arg1 arg2) (emit-invokevirtual +lisp-object+ "SVREF" '(:int) +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation))) @@ -5604,10 +6003,12 @@ (arg2 (%caddr form)) (arg3 (fourth form)) (*register* *register*) - (value-register (when target (allocate-register)))) - (compile-form arg1 'stack nil) ;; vector - (compile-form arg2 'stack :int) ;; index - (compile-form arg3 'stack nil) ;; new value + (value-register (when target (allocate-register nil)))) + (with-operand-accumulation + ((compile-operand arg1 nil) ;; vector + (compile-operand arg2 :int) ;; intex + (compile-operand arg3 nil) ;; new value + )) (when value-register (emit 'dup) (emit-move-from-stack value-register nil)) @@ -5635,9 +6036,12 @@ 'truncate (length args)) (compile-function-call form target representation) (return-from p2-truncate))) - (compile-form arg1 'stack nil) - (compile-form arg2 'stack nil) - (emit-invokevirtual +lisp-object+ "truncate" (lisp-object-arg-types 1) +lisp-object+) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil))) + (maybe-emit-clear-values arg1 arg2) + (emit-invokevirtual +lisp-object+ "truncate" + (lisp-object-arg-types 1) +lisp-object+) (fix-boxing representation nil) ; FIXME use derived result type (emit-move-from-stack target representation))) @@ -5645,8 +6049,10 @@ (cond ((and (check-arg-count form 2) (fixnum-type-p (derive-compiler-type (third form))) (neq representation :char)) ; FIXME - (compile-form (second form) 'stack nil) - (compile-form (third form) 'stack :int) + (with-operand-accumulation + ((compile-operand (second form) nil) + (compile-operand (third form) :int) + (maybe-emit-clear-values (second form) (third form)))) (emit-invokevirtual +lisp-object+ "elt" '(:int) +lisp-object+) (fix-boxing representation nil) ; FIXME use derived result type (emit-move-from-stack target representation)) @@ -5660,35 +6066,30 @@ (let* ((arg1 (%cadr form)) (arg2 (%caddr form)) (type1 (derive-compiler-type arg1))) - (ecase representation - (:int - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) - (emit-invokevirtual +lisp-object+ "aref" '(:int) :int)) - (:long - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) - (emit-invokevirtual +lisp-object+ "aref_long" '(:int) :long)) - (:char - (cond ((compiler-subtypep type1 'string) - (compile-form arg1 'stack nil) ; array - (emit-checkcast +lisp-abstract-string+) - (compile-form arg2 'stack :int) ; index - (maybe-emit-clear-values arg1 arg2) - (emit-invokevirtual +lisp-abstract-string+ - "charAt" '(:int) :char)) - (t - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) - (emit-invokevirtual +lisp-object+ "AREF" '(:int) +lisp-object+) - (emit-unbox-character)))) - ((nil :float :double :boolean) - ;;###FIXME for float and double, we probably want - ;; separate java methods to retrieve the values. - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) - (emit-invokevirtual +lisp-object+ "AREF" '(:int) +lisp-object+) - (convert-representation nil representation))) + (with-operand-accumulation + ((compile-operand arg1 nil + (when (compiler-subtypep type1 'string) + +lisp-abstract-string+)) + (compile-operand arg2 :int) + (maybe-emit-clear-values arg1 arg2)) + (ecase representation + (:int + (emit-invokevirtual +lisp-object+ "aref" '(:int) :int)) + (:long + (emit-invokevirtual +lisp-object+ "aref_long" '(:int) :long)) + (:char + (cond ((compiler-subtypep type1 'string) + (emit-invokevirtual +lisp-abstract-string+ + "charAt" '(:int) :char)) + (t + (emit-invokevirtual +lisp-object+ + "AREF" '(:int) +lisp-object+) + (emit-unbox-character)))) + ((nil :float :double :boolean) + ;;###FIXME for float and double, we probably want + ;; separate java methods to retrieve the values. + (emit-invokevirtual +lisp-object+ "AREF" '(:int) +lisp-object+) + (convert-representation nil representation)))) (emit-move-from-stack target representation))) (t (compile-function-call form target representation)))) @@ -5702,27 +6103,35 @@ (arg3 (third args)) (type3 (derive-compiler-type arg3)) (*register* *register*) - (value-register (unless (null target) (allocate-register)))) + (value-register (unless (null target) (allocate-register nil)))) + (with-operand-accumulation + ( ;; array - (compile-form arg1 'stack nil) + (compile-operand arg1 nil) ;; index - (compile-form arg2 'stack :int) + (compile-operand arg2 :int) ;; value - (cond ((fixnum-type-p type3) - (compile-form arg3 'stack :int) - (when value-register - (emit 'dup) - (emit-move-from-stack value-register :int))) - (t - (compile-form arg3 'stack nil) - (when value-register - (emit 'dup) - (emit-move-from-stack value-register nil)))) + (accumulate-operand + ((when (fixnum-type-p type3) :int) + :unsafe-p (some-nested-block + #'node-opstack-unsafe-p + (find-enclosed-blocks arg3))) + (cond ((fixnum-type-p type3) + (compile-form arg3 'stack :int) + (when value-register + (emit 'dup) + (emit-move-from-stack value-register :int))) + (t + (compile-form arg3 'stack nil) + (when value-register + (emit 'dup) + (emit-move-from-stack value-register nil))))))) (maybe-emit-clear-values arg1 arg2 arg3) (cond ((fixnum-type-p type3) (emit-invokevirtual +lisp-object+ "aset" '(:int :int) nil)) (t - (emit-invokevirtual +lisp-object+ "aset" (list :int +lisp-object+) nil))) + (emit-invokevirtual +lisp-object+ "aset" + (list :int +lisp-object+) nil))) (when value-register (cond ((fixnum-type-p type3) (emit 'iload value-register) @@ -5790,12 +6199,14 @@ (cond ((and (fixnump arg2) (<= 0 arg2 3)) (let* ((*register* *register*) - (value-register (when target (allocate-register)))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg3 'stack nil) + (value-register (when target (allocate-register nil)))) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg3 nil))) (when value-register (emit 'dup) (astore value-register)) + (maybe-emit-clear-values arg1 arg3) (emit-invokevirtual +lisp-object+ (format nil "setSlotValue_~D" arg2) (lisp-object-arg-types 1) nil) @@ -5805,14 +6216,17 @@ (emit-move-from-stack target representation)))) ((fixnump arg2) (let* ((*register* *register*) - (value-register (when target (allocate-register)))) - (compile-form arg1 'stack nil) - (emit-push-constant-int arg2) - (compile-form arg3 'stack nil) + (value-register (when target (allocate-register nil)))) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg3 nil))) (maybe-emit-clear-values arg1 arg3) (when value-register (emit 'dup) (astore value-register)) + (emit-push-constant-int arg2) + (emit 'swap) ;; prevent the integer + ;; from being pushed, saved and restored (emit-invokevirtual +lisp-object+ "setSlotValue" (list :int +lisp-object+) nil) (when value-register @@ -5876,8 +6290,10 @@ (arg1 (%car args)) (arg2 (%cadr args))) (cond ((fixnum-type-p (derive-compiler-type arg1)) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 :int) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (emit 'swap) (emit-invokevirtual +lisp-object+ "nthcdr" '(:int) +lisp-object+) (fix-boxing representation nil) @@ -5961,20 +6377,24 @@ (let ((arg (%car args))) (compile-forms-and-maybe-emit-clear-values arg target representation))) (2 - (emit-push-current-thread) (let ((arg1 (%car args)) (arg2 (%cadr args))) (cond ((and (eq arg1 t) (eq arg2 t)) + (emit-push-current-thread) (emit-push-t) (emit 'dup)) ((and (eq arg1 nil) (eq arg2 nil)) + (emit-push-current-thread) (emit-push-nil) (emit 'dup)) (t - (compile-form arg1 'stack nil) - (compile-form arg2 'stack nil)))) + (with-operand-accumulation + ((emit-thread-operand) + (compile-operand arg1 nil) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2)))))) (emit-invokevirtual +lisp-thread+ "setValues" (lisp-object-arg-types len) @@ -5982,9 +6402,12 @@ (fix-boxing representation nil) (emit-move-from-stack target)) ((3 4) - (emit-push-current-thread) - (dolist (arg args) - (compile-form arg 'stack nil)) + (with-operand-accumulation + ((emit-thread-operand) + (dolist (arg args) + (compile-operand arg nil)))) + (when (notevery #'single-valued-p args) + (emit-clear-values)) (emit-invokevirtual +lisp-thread+ "setValues" (lisp-object-arg-types len) @@ -6052,10 +6475,10 @@ (defun p2-set (form target representation) (cond ((and (check-arg-count form 2) (eq (derive-type (%cadr form)) 'SYMBOL)) - (emit-push-current-thread) - (compile-form (%cadr form) 'stack nil) - (emit-checkcast +lisp-symbol+) - (compile-form (%caddr form) 'stack nil) + (with-operand-accumulation + ((emit-thread-operand) + (compile-operand (%cadr form) nil +lisp-symbol+) + (compile-operand (%caddr form) nil))) (maybe-emit-clear-values (%cadr form) (%caddr form)) (emit-invokevirtual +lisp-thread+ "setSpecialVariable" (list +lisp-symbol+ +lisp-object+) +lisp-object+) @@ -6064,14 +6487,6 @@ (t (compile-function-call form target representation)))) -(declaim (ftype (function (t) t) rewrite-setq)) -(defun rewrite-setq (form) - (let ((expr (%caddr form))) - (if (unsafe-p expr) - (let ((sym (gensym))) - (list 'LET (list (list sym expr)) (list 'SETQ (%cadr form) sym))) - form))) - (defknown p2-setq (t t t) t) (defun p2-setq (form target representation) (unless (= (length form) 3) @@ -6081,36 +6496,43 @@ (value-form (%caddr form))) (when (or (null variable) (variable-special-p variable)) - (let ((new-form (rewrite-setq form))) - (when (neq new-form form) - (return-from p2-setq (compile-form (p1 new-form) target representation)))) ;; We're setting a special variable. (cond ((and variable (variable-binding-register variable) (eq (variable-compiland variable) *current-compiland*) (not (enclosed-by-runtime-bindings-creating-block-p (variable-block variable)))) - (aload (variable-binding-register variable)) + ;; choose this compilation order to prevent + ;; with-operand-accumulation (compile-forms-and-maybe-emit-clear-values value-form 'stack nil) - (emit 'dup_x1) ;; copy past th + (emit 'dup) + (aload (variable-binding-register variable)) + (emit 'swap) (emit-putfield +lisp-special-binding+ "value" +lisp-object+)) ((and (consp value-form) (eq (first value-form) 'CONS) (= (length value-form) 3) (var-ref-p (third value-form)) - (eq (variable-name (var-ref-variable (third value-form))) name)) - (emit-push-current-thread) - (emit-load-externalized-object name) - (compile-forms-and-maybe-emit-clear-values (second value-form) 'stack nil) - (emit-invokevirtual +lisp-thread+ "pushSpecial" - (list +lisp-symbol+ +lisp-object+) +lisp-object+)) + (eq (variable-name (var-ref-variable (third value-form))) + name)) + (with-operand-accumulation + ((emit-thread-operand) + (emit-load-externalized-object-operand name) + (compile-operand (second value-form) nil) + (maybe-emit-clear-values (second value-form))) + (emit-invokevirtual +lisp-thread+ "pushSpecial" + (list +lisp-symbol+ +lisp-object+) + +lisp-object+))) (t - (emit-push-current-thread) - (emit-load-externalized-object name) - (compile-forms-and-maybe-emit-clear-values value-form 'stack nil) - (emit-invokevirtual +lisp-thread+ "setSpecialVariable" - (list +lisp-symbol+ +lisp-object+) +lisp-object+))) + (with-operand-accumulation + ((emit-thread-operand) + (emit-load-externalized-object-operand name) + (compile-operand value-form nil) + (maybe-emit-clear-values value-form)) + (emit-invokevirtual +lisp-thread+ "setSpecialVariable" + (list +lisp-symbol+ +lisp-object+) + +lisp-object+)))) (fix-boxing representation nil) (emit-move-from-stack target representation) (return-from p2-setq)) @@ -6382,14 +6804,17 @@ (emit-move-from-stack target representation) (return-from p2-char=)) (cond ((characterp arg1) - (emit-push-constant-int (char-code arg1)) - (compile-forms-and-maybe-emit-clear-values arg2 'stack :char)) + ;; prevent need for with-operand-accumulation: reverse args + (compile-forms-and-maybe-emit-clear-values arg2 'stack :char) + (emit-push-constant-int (char-code arg1))) ((characterp arg2) (compile-forms-and-maybe-emit-clear-values arg1 'stack :char) (emit-push-constant-int (char-code arg2))) (t - (compile-forms-and-maybe-emit-clear-values arg1 'stack :char - arg2 'stack :char))) + (with-operand-accumulation + ((compile-operand arg1 :char) + (compile-operand arg2 :char) + (maybe-emit-clear-values arg1 arg2))))) (let ((LABEL1 (gensym)) (LABEL2 (gensym))) (emit 'if_icmpeq LABEL1) @@ -6404,10 +6829,10 @@ (defun p2-threads-synchronized-on (block target) (let* ((form (synchronized-form block)) (*register* *register*) - (object-register (allocate-register)) - (BEGIN-PROTECTED-RANGE (gensym)) - (END-PROTECTED-RANGE (gensym)) - (EXIT (gensym))) + (object-register (allocate-register nil)) + (BEGIN-PROTECTED-RANGE (gensym "F")) + (END-PROTECTED-RANGE (gensym "U")) + (EXIT (gensym "E"))) (compile-form (cadr form) 'stack nil) (emit-invokevirtual +lisp-object+ "lockableInstance" nil +java-object+) ; value to synchronize @@ -6440,14 +6865,14 @@ (emit-move-from-stack target)) (return-from p2-catch-node)) (let* ((*register* *register*) - (tag-register (allocate-register)) - (BEGIN-PROTECTED-RANGE (gensym)) - (END-PROTECTED-RANGE (gensym)) - (THROW-HANDLER (gensym)) + (tag-register (allocate-register nil)) + (BEGIN-PROTECTED-RANGE (gensym "F")) + (END-PROTECTED-RANGE (gensym "U")) + (THROW-HANDLER (gensym "H")) (RETHROW (gensym)) (DEFAULT-HANDLER (gensym)) - (EXIT (gensym)) - (specials-register (allocate-register))) + (EXIT (gensym "E")) + (specials-register (allocate-register nil))) (compile-form (second form) tag-register nil) ; Tag. (emit-push-current-thread) (aload tag-register) @@ -6499,12 +6924,13 @@ (defun p2-throw (form target representation) ;; FIXME What if we're called with a non-NIL representation? (declare (ignore representation)) - (emit-push-current-thread) - (compile-form (second form) 'stack nil) ; Tag. - (emit-clear-values) ; Do this unconditionally! (MISC.503) - (compile-form (third form) 'stack nil) ; Result. - (emit-invokevirtual +lisp-thread+ "throwToTag" - (lisp-object-arg-types 2) nil) + (with-operand-accumulation + ((emit-thread-operand) + (compile-operand (second form) nil) ; Tag. + (emit-clear-values) ; Do this unconditionally! (MISC.503) + (compile-operand (third form) nil)) ; Result. + (emit-invokevirtual +lisp-thread+ "throwToTag" + (lisp-object-arg-types 2) nil)) ;; Following code will not be reached. (when target (emit-push-nil) @@ -6531,14 +6957,14 @@ (unwinding-form (caddr form)) (cleanup-forms (cdddr form)) (*register* *register*) - (exception-register (allocate-register)) - (result-register (allocate-register)) - (values-register (allocate-register)) - (specials-register (allocate-register)) - (BEGIN-PROTECTED-RANGE (gensym)) - (END-PROTECTED-RANGE (gensym)) - (HANDLER (gensym)) - (EXIT (gensym))) + (exception-register (allocate-register nil)) + (result-register (allocate-register nil)) + (values-register (allocate-register nil)) + (specials-register (allocate-register nil)) + (BEGIN-PROTECTED-RANGE (gensym "F")) + (END-PROTECTED-RANGE (gensym "U")) + (HANDLER (gensym "H")) + (EXIT (gensym "E"))) ;; Make sure there are no leftover multiple return values from previous calls. (emit-clear-values) @@ -6627,6 +7053,15 @@ (compile-var-ref form target representation)) ((node-p form) (cond + ((jump-node-p form) + (let ((op (car (node-form form)))) + (cond + ((eq op 'go) + (p2-go form target representation)) + ((eq op 'return-from) + (p2-return-from form target representation)) + (t + (assert (not "jump-node: can't happen")))))) ((block-node-p form) (p2-block-node form target representation)) ((let/let*-node-p form) @@ -6761,7 +7196,7 @@ (*thread* nil) (*initialize-thread-var* nil) - (label-START (gensym))) + (label-START (gensym "F"))) (class-add-method class-file method) @@ -6795,7 +7230,7 @@ (push var *visible-variables*)) (when *using-arg-array* - (setf (compiland-argument-register compiland) (allocate-register))) + (setf (compiland-argument-register compiland) (allocate-register nil))) ;; Assign indices or registers, depending on where the args are ;; located: the arg-array or the call-stack @@ -6805,14 +7240,14 @@ (aver (null (variable-index variable))) (if *using-arg-array* (setf (variable-index variable) index) - (setf (variable-register variable) (allocate-register))) + (setf (variable-register variable) (allocate-register nil))) (incf index))) ;; Reserve the next available slot for the thread register. - (setf *thread* (allocate-register)) + (setf *thread* (allocate-register nil)) (when *closure-variables* - (setf (compiland-closure-register compiland) (allocate-register)) + (setf (compiland-closure-register compiland) (allocate-register nil)) (dformat t "p2-compiland 2 closure register = ~S~%" (compiland-closure-register compiland))) @@ -6883,7 +7318,7 @@ (null (variable-index variable)) ;; not in the array anymore (< (+ (variable-reads variable) (variable-writes variable)) 2)) - (let ((register (allocate-register))) + (let ((register (allocate-register nil))) (aload (compiland-argument-register compiland)) (emit-push-constant-int (variable-index variable)) (emit 'aaload) @@ -6902,12 +7337,12 @@ (when (some #'variable-special-p (compiland-arg-vars compiland)) ;; Save the dynamic environment (setf (compiland-environment-register compiland) - (allocate-register)) + (allocate-register nil)) (save-dynamic-environment (compiland-environment-register compiland)) (label label-START) (dolist (variable (compiland-arg-vars compiland)) (when (variable-special-p variable) - (setf (variable-binding-register variable) (allocate-register)) + (setf (variable-binding-register variable) (allocate-register nil)) (emit-push-current-thread) (emit-push-variable-name variable) (cond ((variable-register variable) Modified: trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Tue Feb 15 17:29:22 2011 @@ -1020,7 +1020,6 @@ (defun finalize-code-attribute (code parent class) "Prepares the `code' attribute for serialization, within method `parent'." - (declare (ignore parent)) (let* ((handlers (code-exception-handlers code)) (c (finalize-code (code-code code) @@ -1028,6 +1027,8 @@ (mapcar #'exception-end-pc handlers) (mapcar #'exception-handler-pc handlers)) t))) + (invoke-callbacks :code-finalized class parent + (coerce c 'list) handlers) (unless (code-max-stack code) (setf (code-max-stack code) (analyze-stack c (mapcar #'exception-handler-pc handlers)))) Modified: trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp Tue Feb 15 17:29:22 2011 @@ -721,6 +721,12 @@ (let ((opcode (instruction-opcode instruction))) (setf depth (+ depth instruction-stack)) (setf (instruction-depth instruction) depth) + (unless (<= 0 depth) + (internal-compiler-error "Stack inconsistency detected ~ + in ~A at index ~D: ~ + negative depth ~S." + (compiland-name *current-compiland*) + i depth)) (when (branch-p opcode) (let ((label (car (instruction-args instruction)))) (declare (type symbol label)) Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp Tue Feb 15 17:29:22 2011 @@ -53,6 +53,14 @@ (defvar *closure-variables* nil) (defvar *enable-dformat* nil) +(defvar *callbacks* nil + "A list of functions to be called by the compiler and code generator +in order to generate 'compilation events'.") + +(declaim (inline invoke-callbacks)) +(defun invoke-callbacks (&rest args) + (dolist (cb *callbacks*) + (apply cb args))) #+nil (defun dformat (destination control-string &rest args) @@ -337,25 +345,20 @@ (when (eq name (variable-name variable)) (return variable)))) -(defknown allocate-register () (integer 0 65535)) -(defun allocate-register () - (let* ((register *register*) - (next-register (1+ register))) - (declare (type (unsigned-byte 16) register next-register)) - (setf *register* next-register) - (when (< *registers-allocated* next-register) - (setf *registers-allocated* next-register)) +(defknown representation-size (t) (integer 0 65535)) +(defun representation-size (representation) + (ecase representation + ((NIL :int :boolean :float :char) 1) + ((:long :double) 2))) + +(defknown allocate-register (t) (integer 0 65535)) +(defun allocate-register (representation) + (let ((register *register*)) + (incf *register* (representation-size representation)) + (setf *registers-allocated* + (max *registers-allocated* *register*)) register)) -(defknown allocate-register-pair () (integer 0 65535)) -(defun allocate-register-pair () - (let* ((register *register*) - (next-register (+ register 2))) - (declare (type (unsigned-byte 16) register next-register)) - (setf *register* next-register) - (when (< *registers-allocated* next-register) - (setf *registers-allocated* next-register)) - register)) (defstruct local-function name @@ -464,7 +467,10 @@ non-local-return-p ;; Contains a variable whose value uniquely identifies the ;; lexical scope from this block, to be used by RETURN-FROM - id-variable) + id-variable + ;; A list of all RETURN-FROM value forms associated with this block + return-value-forms) + (defknown make-block-node (t) t) (defun make-block-node (name) (let ((block (%make-block-node name))) @@ -472,6 +478,21 @@ (add-node-child *block* block) block)) +(defstruct (jump-node (:conc-name jump-) + (:include node) + (:constructor + %make-jump-node (non-local-p target-block target-tag))) + non-local-p + target-block + target-tag) +(defun make-jump-node (form non-local-p target-block &optional target-tag) + (let ((node (%make-jump-node non-local-p target-block target-tag))) + ;; Don't push into compiland blocks, as this as a node rather than a block + (setf (node-form node) form) + (add-node-child *block* node) + node)) + + ;; binding blocks: LET, LET*, FLET, LABELS, M-V-B, PROGV, LOCALLY ;; ;; Binding blocks can carry references to local (optionally special) variable bindings, @@ -608,11 +629,14 @@ (when *blocks* ;; when the innermost enclosing block doesn't have node-children, ;; there's really nothing to search for. - (when (null (node-children (car *blocks*))) - (return-from find-enclosed-blocks))) + (let ((first-enclosing-block (car *blocks*))) + (when (and (eq *current-compiland* + (node-compiland first-enclosing-block)) + (null (node-children first-enclosing-block))) + (return-from find-enclosed-blocks)))) (%find-enclosed-blocks form)) - + (defun some-nested-block (predicate blocks) "Applies `predicate` recursively to the `blocks` and its children, @@ -650,10 +674,14 @@ (catch-node-p object) (synchronized-node-p object))) -(defun block-opstack-unsafe-p (block) - (or (when (tagbody-node-p block) (tagbody-non-local-go-p block)) - (when (block-node-p block) (block-non-local-return-p block)) - (catch-node-p block))) +(defun node-opstack-unsafe-p (node) + (or (when (jump-node-p node) + (let ((target-block (jump-target-block node))) + (and (null (jump-non-local-p node)) + (member target-block *blocks*)))) + (when (tagbody-node-p node) (tagbody-non-local-go-p node)) + (when (block-node-p node) (block-non-local-return-p node)) + (catch-node-p node))) (defknown block-creates-runtime-bindings-p (t) boolean) (defun block-creates-runtime-bindings-p (block) From ehuelsmann at common-lisp.net Tue Feb 15 22:30:48 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 15 Feb 2011 17:30:48 -0500 Subject: [armedbear-cvs] r13223 - branches/unsafe-p-removal Message-ID: Author: ehuelsmann Date: Tue Feb 15 17:30:47 2011 New Revision: 13223 Log: Remove branche now integrated in trunk. Removed: branches/unsafe-p-removal/ From astalla at common-lisp.net Tue Feb 15 23:06:47 2011 From: astalla at common-lisp.net (Alessio Stalla) Date: Tue, 15 Feb 2011 18:06:47 -0500 Subject: [armedbear-cvs] r13224 - trunk/abcl Message-ID: Author: astalla Date: Tue Feb 15 18:06:46 2011 New Revision: 13224 Log: Updared POM to reflect version 0.25.0-dev and added instructions for releasing with Maven. Added: trunk/abcl/maven-release.txt Modified: trunk/abcl/pom.xml Added: trunk/abcl/maven-release.txt ============================================================================== --- (empty file) +++ trunk/abcl/maven-release.txt Tue Feb 15 18:06:46 2011 @@ -0,0 +1,34 @@ +# Releasing ABCL on Sonatype's OSS Maven repository - instructions +# +# This assumes your settings.xml (/etc/maven2/settings.xml for Ubuntu-packaged Maven) contains something like this in its section: +# +# +# sonatype-nexus-snapshots +# sonatype-jira-username +# sonatype-jira-password +# +# +# sonatype-nexus-staging +# sonatype-jira-username +# sonatype-jira-password +# + +# First, remember to build it! +ant abcl.jar +ant abcl.source.jar +ant abcl.javadoc.jar +# And maybe test it as well +ant abcl.test + +# For snapshots - development versions - the version in the POM should be like x.y.z-SNAPSHOT +mvn gpg:sign-and-deploy-file -Dfile=dist/abcl.jar -DpomFile=pom.xml -Durl=https://oss.sonatype.org/content/repositories/snapshots/ -DrepositoryId=sonatype-nexus-snapshots +mvn gpg:sign-and-deploy-file -Dfile=dist/abcl-${abcl.version}-sources.jar -DpomFile=pom.xml -Durl=https://oss.sonatype.org/content/repositories/snapshots/ -DrepositoryId=sonatype-nexus-snapshots -Dclassifier=sources +mvn gpg:sign-and-deploy-file -Dfile=dist/abcl-${abcl.version}-javadoc.jar -DpomFile=pom.xml -Durl=https://oss.sonatype.org/content/repositories/snapshots/ -DrepositoryId=sonatype-nexus-snapshots -Dclassifier=javadoc + +# For releases - the version in the POM should be x.y.z +mvn gpg:sign-and-deploy-file -Dfile=dist/abcl.jar -DpomFile=pom.xml -Durl=https://oss.sonatype.org/service/local/staging/deploy/maven2/ -DrepositoryId=sonatype-nexus-staging +mvn gpg:sign-and-deploy-file -Dfile=dist/abcl-${abcl.version}-sources.jar -DpomFile=pom.xml -Durl=https://oss.sonatype.org/service/local/staging/deploy/maven2/ -DrepositoryId=sonatype-nexus-staging -Dclassifier=sources +mvn gpg:sign-and-deploy-file -Dfile=dist/abcl-${abcl.version}-javadoc.jar -DpomFile=pom.xml -Durl=https://oss.sonatype.org/service/local/staging/deploy/maven2/ -DrepositoryId=sonatype-nexus-staging -Dclassifier=javadoc + + + Modified: trunk/abcl/pom.xml ============================================================================== --- trunk/abcl/pom.xml (original) +++ trunk/abcl/pom.xml Tue Feb 15 18:06:46 2011 @@ -13,7 +13,7 @@ org.armedbear.lisp abcl - 0.24.0 + 0.25.0-SNAPSHOT jar ABCL - Armed Bear Common Lisp Common Lisp implementation running on the JVM @@ -34,22 +34,22 @@ ehu Erik Huelsmann - ehuels at gmail.com + ehuels (at) gmail (dot) com easyE Mark Evenson - evenson at panix.com + evenson (at) panix (dot) com V-ille Ville Voutilainen - ville.voutilainen at gmail.com + ville.voutilainen (at) gmail (dot) com astalla Alessio Stalla - alessiostalla at gmail.com + alessiostalla (at) gmail (dot) com From ehuelsmann at common-lisp.net Thu Feb 17 22:47:56 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 17 Feb 2011 17:47:56 -0500 Subject: [armedbear-cvs] r13225 - trunk/abcl/test/lisp/abcl Message-ID: Author: ehuelsmann Date: Thu Feb 17 17:47:54 2011 New Revision: 13225 Log: Port DEFINE-METHOD-COMBINATION test from SBCL (clos.impure.lisp, to be exact). Modified: trunk/abcl/test/lisp/abcl/mop-tests.lisp Modified: trunk/abcl/test/lisp/abcl/mop-tests.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/mop-tests.lisp (original) +++ trunk/abcl/test/lisp/abcl/mop-tests.lisp Thu Feb 17 17:47:54 2011 @@ -1,6 +1,7 @@ ;;; mop-tests.lisp ;;; ;;; Copyright (C) 2010 Matthias H?lzl +;;; Copyright (C) 2010 Erik Huelsmann ;;; ;;; This program is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU General Public License @@ -300,3 +301,62 @@ t) + +;; tests for D-M-C, long form, taken from SBCL + +;; D-M-C should return the name of the new method combination, nothing else. + +(deftest dmc-return.1 + (define-method-combination dmc-test-return-foo) + 'dmc-test-return-foo) + +(deftest dmc-return.2 + (define-method-combination dmc-test-return-bar :operator and) + 'dmc-test-return-bar) + +(deftest dmc-return.3 + (define-method-combination dmc-test-return + (&optional (order :most-specific-first)) + ((around (:around)) + (primary (dmc-test-return) :order order :required t)) + (let ((form (if (rest primary) + `(and ,@(mapcar #'(lambda (method) + `(call-method ,method)) + primary)) + `(call-method ,(first primary))))) + (if around + `(call-method ,(first around) + (,@(rest around) + (make-method ,form))) + form))) + 'dmc-test-return) + +;; A method combination which originally failed; +;; for different reasons in SBCL than in ABCL (hence leaving out +;; the original comment) + +(define-method-combination dmc-test-mc.1 + (&optional (order :most-specific-first)) + ((around (:around)) + (primary (dmc-test-mc) :order order :required t)) + (let ((form (if (rest primary) + `(and ,@(mapcar #'(lambda (method) + `(call-method ,method)) + primary)) + `(call-method ,(first primary))))) + (if around + `(call-method ,(first around) + (,@(rest around) + (make-method ,form))) + form))) + +(defgeneric dmc-test-mc.1 (&key k) (:method-combination dmc-test-mc.1)) + +(defmethod dmc-test-mc.1 dmc-test-mc (&key k) + k) + +(deftest dmc-test-mc.1 + (dmc-test-mc.1 :k 1) + 1) + + From vvoutilainen at common-lisp.net Sun Feb 20 20:02:10 2011 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 20 Feb 2011 15:02:10 -0500 Subject: [armedbear-cvs] r13226 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sun Feb 20 15:02:08 2011 New Revision: 13226 Log: Fix ticket #128. This patch enables the use of -- as a parameter, and using such a parameter will stop abcl from further processing the parameters given. Example used for testing: (loop for item in *command-line-argument-list* do (format t "got arg ~a~%" item)) With that snippet saved into cmdlinetest.lisp, we can do ./abcl --batch --eval '(load "cmdlinetest.lisp")' -- hops hups jee jee --eval '(format t "hah~%")' -- -- -- and have it print Armed Bear Common Lisp 0.25.0-dev-svn-13225M Java 1.6.0_22 Sun Microsystems Inc. Java HotSpot(TM) Server VM Low-level initialization completed in 0.626 seconds. Startup completed in 1.778 seconds. got arg hops got arg hups got arg jee got arg jee got arg --eval got arg (format t "hah~%") got arg -- got arg -- got arg -- Modified: trunk/abcl/src/org/armedbear/lisp/Interpreter.java Modified: trunk/abcl/src/org/armedbear/lisp/Interpreter.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Interpreter.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Interpreter.java Sun Feb 20 15:02:08 2011 @@ -55,6 +55,7 @@ private static boolean nosystem = false; private static boolean noinform = false; private static boolean help = false; + private static boolean doubledash = false; public static synchronized Interpreter getInstance() { @@ -104,6 +105,7 @@ initializeSystem(); if (!noinit) processInitializationFile(); + doubledash = false; if (args != null) postprocessCommandLineArguments(args); @@ -238,7 +240,11 @@ if (args != null) { for (int i = 0; i < args.length; ++i) { String arg = args[i]; - if (arg.equals("--noinit")) { + if (doubledash) { + arglist = new Cons(args[i], arglist); + } else if (arg.equals("--")) { + doubledash = true; + } else if (arg.equals("--noinit")) { noinit = true; } else if (arg.equals("--nosystem")) { nosystem = true; @@ -280,7 +286,11 @@ if (args != null) { for (int i = 0; i < args.length; ++i) { String arg = args[i]; - if (arg.equals("--eval")) { + if (doubledash) { + continue; + } else if (arg.equals("--")) { + doubledash = true; + } else if (arg.equals("--eval")) { if (i + 1 < args.length) { try { evaluate(args[i + 1]); From vvoutilainen at common-lisp.net Sun Feb 20 20:25:47 2011 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 20 Feb 2011 15:25:47 -0500 Subject: [armedbear-cvs] r13227 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sun Feb 20 15:25:46 2011 New Revision: 13227 Log: Add --help documentation for --. Modified: trunk/abcl/src/org/armedbear/lisp/Interpreter.java Modified: trunk/abcl/src/org/armedbear/lisp/Interpreter.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Interpreter.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Interpreter.java Sun Feb 20 15:25:46 2011 @@ -662,6 +662,8 @@ sb.append(sep); sb.append("--nosystem suppresses loading the system startup file"); sb.append(sep); + sb.append("-- alone prevents further argument handling"); + sb.append(sep); return sb.toString(); } From astalla at common-lisp.net Fri Feb 25 22:43:10 2011 From: astalla at common-lisp.net (Alessio Stalla) Date: Fri, 25 Feb 2011 17:43:10 -0500 Subject: [armedbear-cvs] r13228 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Fri Feb 25 17:43:08 2011 New Revision: 13228 Log: Fix incorrect elimination of named local functions declared inline when they're actually reified in the flet/labels body. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Fri Feb 25 17:43:08 2011 @@ -932,14 +932,15 @@ (process-declarations-for-vars body nil block)) (dolist (special (flet-free-specials block)) (push special *visible-variables*)) - (setf (flet-form block) - (list* (car form) - (remove-if (lambda (fn) - (and (inline-p (local-function-name fn)) - (not (local-function-references-needed-p fn)))) - local-functions) - (p1-body (cddr form)))) - block))))) + (let ((body (p1-body (cddr form)))) + (setf (flet-form block) + (list* (car form) + (remove-if (lambda (fn) + (and (inline-p (local-function-name fn)) + (not (local-function-references-needed-p fn)))) + local-functions) + body))) + block))))) (defun p1-labels (form) @@ -1033,9 +1034,9 @@ (p1-compiland compiland))) (list 'FUNCTION compiland))) ((setf local-function (find-local-function (cadr form))) - (dformat t "p1-function local function ~S~%" (cadr form)) - ;;we found out that the function needs a reference - (setf (local-function-references-needed-p local-function) t) + (dformat "p1-function local function ~S~%" (cadr form)) + ;;we found out that the function needs a reference + (setf (local-function-references-needed-p local-function) t) (let ((variable (local-function-variable local-function))) (when variable (dformat t "p1-function ~S used non-locally~%"