Changeset 11829

Timestamp:

05/04/09 19:43:30 (14 years ago)

Author:

ehuelsmann

Message:

Simplify p1-compiland and p2-compiland.
Create a new 'free-specials' field in the compiland
structure to share work done in p1 with p2.

Location:

trunk/abcl/src/org/armedbear/lisp

Files:

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

trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp

@@ -1021 +1021 @@
 
     (let* ((lambda-list (cadr form))
-           (body (cddr form)))
-
-      (let* ((closure (make-closure `(lambda ,lambda-list nil) nil))
-             (syms (sys::varlist closure))
-             (vars nil))
-        (dolist (sym syms)
-          (let ((var (make-variable :name sym
-                                    :special-p (special-variable-p sym))))
-            (push var vars)
-            (push var *all-variables*)))
-        (setf (compiland-arg-vars compiland) (nreverse vars))
-        (let ((*visible-variables* *visible-variables*))
-          (dolist (var (compiland-arg-vars compiland))
-            (push var *visible-variables*))
-          (let ((free-specials (process-declarations-for-vars body *visible-variables*)))
-            (dolist (var free-specials)
-              (push var *visible-variables*)))
-          (setf (compiland-p1-result compiland)
-                (list* 'LAMBDA lambda-list (p1-body body))))))))
+           (body (cddr form))
+           (*visible-variables* *visible-variables*)
+           (closure (make-closure `(lambda ,lambda-list nil) nil))
+           (syms (sys::varlist closure))
+           (vars nil))
+      (dolist (sym syms)
+        (let ((var (make-variable :name sym
+                                  :special-p (special-variable-p sym))))
+          (push var vars)
+          (push var *all-variables*)
+          (push var *visible-variables*)))
+      (setf (compiland-arg-vars compiland) (nreverse vars))
+      (let ((free-specials (process-declarations-for-vars body vars)))
+        (setf (compiland-free-specials compiland) free-specials)
+        (dolist (var free-specials)
+          (push var *visible-variables*)))
+      (setf (compiland-p1-result compiland)
+            (list* 'LAMBDA lambda-list (p1-body body))))))
 
 (provide "COMPILER-PASS1")

trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

@@ -8161 +8161 @@
          (*visible-variables* *visible-variables*)
 
-         (parameters ())
-
          (*thread* nil)
          (*initialize-thread-var* nil)
@@ -8172 +8170 @@
     (dolist (var (compiland-arg-vars compiland))
       (push var *visible-variables*))
+    (dolist (var (compiland-free-specials compiland))
+      (push var *visible-variables*))
 
     (setf (method-name-index execute-method)
@@ -8178 +8178 @@
           (pool-name (method-descriptor execute-method)))
     (cond (*hairy-arglist-p*
-           (let* ((closure (make-closure p1-result nil))
-                  (parameter-names (sys::varlist closure))
-                  (index 0))
-             (dolist (name parameter-names)
-               (let ((variable (find-visible-variable name)))
-                 (unless variable
-                   (format t "1: unable to find variable ~S~%" name)
-                   (aver nil))
-                 (aver (null (variable-register variable)))
-                 (aver (null (variable-index variable)))
-                 (setf (variable-index variable) index)
-                 (push variable parameters)
-                 (incf index)))))
+           (let ((index 0))
+             (dolist (variable (compiland-arg-vars compiland))
+               (aver (null (variable-register variable)))
+               (aver (null (variable-index variable)))
+               (setf (variable-index variable) index)
+               (incf index))))
           (t
            (let ((register (if (and *closure-variables* *child-p*)
@@ -8196 +8189 @@
                                1))
                  (index 0))
-             (dolist (arg args)
-               (let ((variable (find-visible-variable arg)))
-                 (when (null variable)
-                   (format t "2: unable to find variable ~S~%" arg)
-                   (aver nil))
-                 (aver (null (variable-register variable)))
-                 (setf (variable-register variable) (if *using-arg-array* nil register))
-                 (aver (null (variable-index variable)))
-                 (if *using-arg-array*
-                     (setf (variable-index variable) index))
-                 (push variable parameters)
-                 (incf register)
-                 (incf index))))))
-
-    (let ((specials (process-special-declarations body)))
-      (dolist (name specials)
-        (dformat t "recognizing ~S as special~%" name)
-        (let ((variable (find-visible-variable name)))
-          (cond ((null variable)
-                 (setf variable (make-variable :name name
-                                               :special-p t))
-                 (push variable *visible-variables*))
-                (t
-                 (setf (variable-special-p variable) t))))))
+             (dolist (variable (compiland-arg-vars compiland))
+               (aver (null (variable-register variable)))
+               (setf (variable-register variable)
+                     (if *using-arg-array* nil register))
+               (aver (null (variable-index variable)))
+               (if *using-arg-array*
+                   (setf (variable-index variable) index))
+               (incf register)
+               (incf index)))))
 
     (p2-compiland-process-type-declarations body)
@@ -8233 +8211 @@
            (unless (or *closure-variables* *child-p*)
              ;; Reserve a register for each parameter.
-             (dolist (variable (reverse parameters))
+             (dolist (variable (compiland-arg-vars compiland))
                (aver (null (variable-register variable)))
                (aver (null (variable-reserved-register variable)))
@@ -8240 +8218 @@
           (t
            ;; Otherwise, one register for each argument.
-           (dolist (arg args)
-             (declare (ignore arg))
+           (dolist (variable (compiland-arg-vars compiland))
+             (declare (ignore variable))
              (allocate-register))))
     (when (and *closure-variables* (not *child-p*))
@@ -8256 +8234 @@
       (cond (*child-p*
              (aver (eql (compiland-closure-register compiland) 1))
-             (when (some #'variable-closure-index parameters)
+             (when (some #'variable-closure-index
+                         (compiland-arg-vars compiland))
                (aload (compiland-closure-register compiland))))
             (t
@@ -8262 +8241 @@
              (dformat t "p2-compiland ~S anewarray 1~%" (compiland-name compiland))
              (emit 'anewarray "org/armedbear/lisp/LispObject")))
-      (dolist (variable parameters)
+      (dolist (variable (compiland-arg-vars compiland))
         (dformat t "considering ~S ...~%" (variable-name variable))
         (when (variable-closure-index variable)
@@ -8288 +8267 @@
       (aver (not (null (compiland-closure-register compiland))))
       (cond (*child-p*
-             (when (some #'variable-closure-index parameters)
+             (when (some #'variable-closure-index
+                         (compiland-arg-vars compiland))
                (emit 'pop)))
             (t
@@ -8298 +8278 @@
     (when *using-arg-array*
       (unless (or *closure-variables* *child-p*)
-        (dolist (variable (reverse parameters))
+        (dolist (variable (compiland-arg-vars compiland))
           (when (variable-reserved-register variable)
             (aver (not (variable-special-p variable)))
@@ -8308 +8288 @@
             (setf (variable-index variable) nil)))))
 
-    (generate-type-checks-for-variables (reverse parameters))
+    (generate-type-checks-for-variables (compiland-arg-vars compiland))
 
     ;; Unbox variables.
-    (dolist (variable (reverse parameters))
+    (dolist (variable (compiland-arg-vars compiland))
       (p2-compiland-unbox-variable variable))
 
     ;; Establish dynamic bindings for any variables declared special.
-    (when (some #'variable-special-p parameters)
+    (when (some #'variable-special-p (compiland-arg-vars compiland))
       ;; Save the dynamic environment
       (setf (compiland-environment-register compiland)
@@ -8323 +8303 @@
             +lisp-special-binding+)
       (astore (compiland-environment-register compiland))
-      (label label-START))
-    (dolist (variable parameters)
-      (when (variable-special-p variable)
-        (cond ((variable-register variable)
-               (emit-push-current-thread)
-               (emit-push-variable-name variable)
-               (aload (variable-register variable))
-               (emit-invokevirtual +lisp-thread-class+ "bindSpecial"
-                                   (list +lisp-symbol+ +lisp-object+) nil)
-               (setf (variable-register variable) nil))
-              ((variable-index variable)
-               (emit-push-current-thread)
-               (emit-push-variable-name variable)
-               (aload (compiland-argument-register compiland))
-               (emit-push-constant-int (variable-index variable))
-               (emit 'aaload)
-               (emit-invokevirtual +lisp-thread-class+ "bindSpecial"
-                                   (list +lisp-symbol+ +lisp-object+) nil)
-               (setf (variable-index variable) nil)))))
+      (label label-START)
+      (dolist (variable (compiland-arg-vars compiland))
+        (when (variable-special-p variable)
+          (cond ((variable-register variable)
+                 (emit-push-current-thread)
+                 (emit-push-variable-name variable)
+                 (aload (variable-register variable))
+                 (emit-invokevirtual +lisp-thread-class+ "bindSpecial"
+                                     (list +lisp-symbol+ +lisp-object+) nil)
+                 (setf (variable-register variable) nil))
+                ((variable-index variable)
+                 (emit-push-current-thread)
+                 (emit-push-variable-name variable)
+                 (aload (compiland-argument-register compiland))
+                 (emit-push-constant-int (variable-index variable))
+                 (emit 'aaload)
+                 (emit-invokevirtual +lisp-thread-class+ "bindSpecial"
+                                     (list +lisp-symbol+ +lisp-object+) nil)
+                 (setf (variable-index variable) nil))))))
 
     (compile-progn-body body 'stack)

trunk/abcl/src/org/armedbear/lisp/jvm.lisp

@@ -157 +157 @@
   lambda-expression
   arg-vars
+  free-specials
   arity ; NIL if the number of args can vary.
   p1-result