Changeset 11935

Timestamp:

05/23/09 17:15:36 (15 years ago)

Author:

vvoutilainen

Message:

Patches to make the branch build. It doesn't run yet, there's a Thread
that's attempted to coerce to a Function somewhere, but at least it
builds.

Location:

branches/fewer-executes/abcl/src/org/armedbear/lisp

Files:

• compiler-pass2.lisp (modified) (8 diffs)
• jvm.lisp (modified) (1 diff)

branches/fewer-executes/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

@@ -2784 +2784 @@
 in order to call the relevant `execute' form. The function call
 itself is *not* compiled by this function."
-  (when args
-    (let ((numargs (length args)))
-      (let ((must-clear-values nil))
-        (declare (type boolean must-clear-values))
-        (cond ((<= 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-class+)
-               (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)))))
-        (when must-clear-values
-          (emit-clear-values)))))
+  (let ((numargs (length args)))
+    (let ((must-clear-values nil))
+      (declare (type boolean must-clear-values))
+      (emit-push-constant-int numargs)
+      (emit 'anewarray +lisp-object-class+)
+      (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)))
+      (when must-clear-values
+  (emit-clear-values))))
   t)
 
@@ -2825 +2817 @@
 (declaim (ftype (function (t) t) emit-call-execute))
 (defun emit-call-execute (numargs)
-  (let ((arg-types (if (<= numargs call-registers-limit)
-                       (lisp-object-arg-types numargs)
-                       (list +lisp-object-array+)))
+  (declare (ignore numargs))
+  (let ((arg-types (list +lisp-object-array+))
         (return-type +lisp-object+))
     (emit-invokevirtual +lisp-object-class+ "execute" arg-types return-type)))
@@ -2833 +2824 @@
 (declaim (ftype (function (t) t) emit-call-thread-execute))
 (defun emit-call-thread-execute (numargs)
-  (let ((arg-types (if (<= numargs call-registers-limit)
-                       (lisp-object-arg-types (1+ numargs))
-                       (list +lisp-object+ +lisp-object-array+)))
+  (declare (ignore numargs))
+  (let ((arg-types (list +lisp-object+ +lisp-object-array+))
         (return-type +lisp-object+))
     (emit-invokevirtual +lisp-thread-class+ "execute" arg-types return-type)))
@@ -2893 +2883 @@
 is registered (or not)."
   (let ((numargs (length args)))
-    (cond ((> *speed* *debug*)
+    (cond ((and (> *speed* *debug*) (not *require-stack-frame*))
            (process-args args)
            (emit-call-execute numargs))
@@ -3840 +3830 @@
      (emit-invokestatic +lisp-class+ "coerceToFunction"
                         (lisp-object-arg-types 1) +lisp-object+)
-     (emit-invokevirtual +lisp-object-class+ "execute" nil +lisp-object+))
+     (emit-invokevirtual +lisp-object-class+ "execute" (list +lisp-object-array+) +lisp-object+))
     (3
      (let* ((*register* *register*)
@@ -7867 +7857 @@
           (get-descriptor (list +lisp-object-array+) +lisp-object+)))
       (return-from analyze-args
-        (cond ((<= arg-count call-registers-limit)
-               (get-descriptor (lisp-object-arg-types arg-count) +lisp-object+))
-              (t (setf *using-arg-array* t)
+        (cond (t (setf *using-arg-array* t)
                  (setf (compiland-arity compiland) arg-count)
                  (get-descriptor (list +lisp-object-array+) +lisp-object+)))))
@@ -7879 +7867 @@
       (return-from analyze-args
                    (get-descriptor (list +lisp-object-array+) +lisp-object+)))
-    (cond ((<= arg-count call-registers-limit)
-           (get-descriptor (lisp-object-arg-types (length args))
-                            +lisp-object+))
-          (t
-           (setf *using-arg-array* t)
-           (setf (compiland-arity compiland) arg-count)
-           (get-descriptor (list +lisp-object-array+) +lisp-object+)))))
+    (setf *using-arg-array* t)
+    (setf (compiland-arity compiland) arg-count)
+    (get-descriptor (list +lisp-object-array+) +lisp-object+)))
 
 (defun write-class-file (class-file)
@@ -7998 +7982 @@
           (find compiland *closure-variables* :key #'variable-compiland))
          (body (cddr p1-result))
-         (*using-arg-array* nil)
+         (*using-arg-array* t)
          (*hairy-arglist-p* nil)
          ;; *hairy-arglist-p* != NIL --> *using-arglist-array* != NIL

branches/fewer-executes/abcl/src/org/armedbear/lisp/jvm.lisp

@@ -342 +342 @@
         (return local-function))))
 
-(defvar *using-arg-array* nil)
+(defvar *using-arg-array* t)
 (defvar *hairy-arglist-p* nil)