Changeset 12123

Timestamp:

08/28/09 09:04:44 (12 years ago)

Author:

ehuelsmann

Message:

Convert LET BLOCK-NODEs to LET/LET*-NODEs and
clean up the BLOCK-NODE structure to serve BLOCKs only.

Location:

trunk/abcl/src/org/armedbear/lisp

Files:

• compiler-pass1.lisp (modified) (2 diffs)
• compiler-pass2.lisp (modified) (12 diffs)
• jvm.lisp (modified) (4 diffs)

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

@@ -201 +201 @@
   (declare (type cons form))
   (let* ((*visible-variables* *visible-variables*)
-         (block (make-block-node '(LET)))
-         (*blocks* (cons block *blocks*))
+         (block (make-let/let*-node))
          (op (%car form))
          (varlist (cadr form))
@@ -223 +222 @@
         (when (special-variable-p (variable-name variable))
           (setf (variable-special-p variable) t
-                (block-environment-register block) t)))
+                (let-environment-register block) t)))
       ;; For processing declarations, we want to walk the variable list from
       ;; last to first, since declarations apply to the last-defined variable
       ;; with the specified name.
-      (setf (block-free-specials block)
+      (setf (let-free-specials block)
             (process-declarations-for-vars body (reverse vars) block))
-      (setf (block-vars block) vars)
+      (setf (let-vars block) vars)
       ;; Make free specials visible.
-      (dolist (variable (block-free-specials block))
+      (dolist (variable (let-free-specials block))
         (push variable *visible-variables*)))
-    (setf body (p1-body body))
-    (setf (block-form block) (list* op varlist body))
+    (let ((*blocks* (cons block *blocks*)))
+      (setf body (p1-body body)))
+    (setf (let-form block) (list* op varlist body))
     block))
 

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

@@ -4073 +4073 @@
 (defun propagate-vars (block)
   (let ((removed '()))
-    (dolist (variable (block-vars block))
+    (dolist (variable (let-vars block))
       (unless (or (variable-special-p variable)
                   (variable-closure-index variable))
@@ -4105 +4105 @@
                                   (let* ((symbol (get (variable-name variable)
                                                       'sys::dotimes-index-variable-name))
-                                         (index-variable (find-variable symbol (block-vars block))))
+                                         (index-variable (find-variable symbol (let-vars block))))
                                     (when index-variable
                                       (setf (get (variable-name index-variable)
@@ -4120 +4120 @@
     (when removed
       (dolist (variable removed)
-        (setf (block-vars block) (remove variable (block-vars block)))))))
+        (setf (let-vars block) (remove variable (let-vars block)))))))
 
 (defun derive-variable-representation (variable block
@@ -4157 +4157 @@
                   (limit-variable (and name
                                        (or (find-variable name
-                                                          (block-vars block))
+                                                          (let-vars block))
                                            (find-visible-variable name)))))
              (when limit-variable
@@ -4265 +4265 @@
 (defknown p2-let-bindings (t) t)
 (defun p2-let-bindings (block)
-  (dolist (variable (block-vars block))
+  (dolist (variable (let-vars block))
     (unless (or (variable-special-p variable)
                 (variable-closure-index variable)
@@ -4280 +4280 @@
     ;; because we'll lose JVM stack consistency if there is a non-local
     ;; transfer of control from one of the initforms.
-    (dolist (variable (block-vars block))
+    (dolist (variable (let-vars block))
       (let* ((initform (variable-initform variable))
              (unused-p (and (not (variable-special-p variable))
@@ -4321 +4321 @@
       (compile-binding (cdr temp))))
   ;; Now make the variables visible.
-  (dolist (variable (block-vars block))
+  (dolist (variable (let-vars block))
     (push variable *visible-variables*))
   t)
@@ -4330 +4330 @@
     (declare (type boolean must-clear-values))
     ;; Generate code to evaluate initforms and bind variables.
-    (dolist (variable (block-vars block))
+    (dolist (variable (let-vars block))
       (let* ((initform (variable-initform variable))
              (unused-p (and (not (variable-special-p variable))
@@ -4402 +4402 @@
 
 (defun p2-let/let*-node (block target representation)
-  (let* ((*blocks* (cons block *blocks*))
+  (let* (
          (*register* *register*)
-         (form (block-form block))
+         (form (let-form block))
          (*visible-variables* *visible-variables*)
          (specialp nil)
          (label-START (gensym)))
     ;; Walk the variable list looking for special bindings and unused lexicals.
-    (dolist (variable (block-vars block))
+    (dolist (variable (let-vars block))
       (cond ((variable-special-p variable)
              (setf specialp t))
@@ -4417 +4417 @@
     (when specialp
       ;; We need to save current dynamic environment.
-      (setf (block-environment-register block) (allocate-register))
-      (save-dynamic-environment (block-environment-register block))
+      (setf (let-environment-register block) (allocate-register))
+      (save-dynamic-environment (let-environment-register block))
       (label label-START))
     (propagate-vars block)
@@ -4427 +4427 @@
        (p2-let*-bindings block)))
     ;; Make declarations of free specials visible.
-    (dolist (variable (block-free-specials block))
+    (dolist (variable (let-free-specials block))
       (push variable *visible-variables*))
     ;; Body of LET/LET*.
     (with-saved-compiler-policy
       (process-optimization-declarations (cddr form))
-      (compile-progn-body (cddr form) target representation))
+      (let ((*blocks* (cons block *blocks*)))
+        (compile-progn-body (cddr form) target representation)))
     (when specialp
-      (restore-environment-and-make-handler (block-environment-register block)
+      (restore-environment-and-make-handler (let-environment-register block)
               label-START))))
 
@@ -7908 +7909 @@
         ((var-ref-p form)
          (compile-var-ref form target representation))
-        ((block-node-p form)
-         (let ((name (block-name form)))
-           (if (not (consp name))
-               (p2-block-node form target representation)
-               (let ((name (car name)))
-                 (cond
-                   ((eq name 'LET)
-                    (p2-let/let*-node form target representation))
-                   ((eq name 'SETF) ;; SETF functions create
-                    ;; consp block names, if we're unlucky
-                    (p2-block-node form target representation))
-                   (t
-                    (print name)
-                    (aver (not "Can't happen.")))
-                   )))))
         ((node-p form)
          (cond
+           ((block-node-p form)
+            (p2-block-node form target representation))
+           ((let/let*-node-p form)
+            (p2-let/let*-node form target representation))
            ((tagbody-node-p form)
             (p2-tagbody-node form target)

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

@@ -439 +439 @@
   return-p
   ;; True if there is a non-local RETURN from this block.
-  non-local-return-p
-  ;; If non-nil, register containing saved dynamic environment for this block.
-  environment-register
-  ;; Only used in LET/LET*/M-V-B nodes.
-  vars
-  free-specials
-  )
+  non-local-return-p)
 
 (defvar *blocks* ())
@@ -482 +476 @@
   (or (unwind-protect-node-p object)
       (catch-node-p object)
-      (synchronized-node-p object)
-      (and (block-node-p object)
-           (equal (block-name object) '(THREADS:SYNCHRONIZED-ON)))))
+      (synchronized-node-p object)))
 
 
@@ -504 +496 @@
     (when (eq enclosing-block outermost-block)
       (return nil))
-    (when (or (and (binding-node-p enclosing-block)
-                   (binding-node-environment-register enclosing-block))
-              (and (block-node-p enclosing-block)
-                   (block-environment-register enclosing-block)))
+    (when (and (binding-node-p enclosing-block)
+               (binding-node-environment-register enclosing-block))
       (return t))))
 
@@ -521 +511 @@
            (or (and (binding-node-p block)
                     (binding-node-environment-register block))
-               (and (block-node-p block)
-                    (block-environment-register block))
                last-register)))
     (reduce #'outermost-register *blocks*