Ticket #90: ticket-90.patch

compiler-pass2.lisp

@@ -44 +44 @@
   (require "JVM-INSTRUCTIONS")
   (require "JAVA"))
 
+(defvar *outer-block-restores-environment* nil)
 
 (declaim (inline pool-name pool-string pool-name-and-type
                  pool-class pool-field pool-method pool-int
@@ -3083 +3084 @@
            (emit-move-from-stack target)))
         (t
          (let ((clear-values nil)
-               (tail body))
+               (tail body)
+               (outer-block-restores
+                *outer-block-restores-environment*)
+               (*outer-block-restores-environment* nil))
            (loop
              (let ((form (car tail)))
                (cond ((null (cdr tail))
                       ;; Last form.
                       (when clear-values
                         (emit-clear-values))
-                      (compile-form form target representation)
+                      (let ((*outer-block-restores-environment*
+                             outer-block-restores))
+                        (compile-form form target representation))
                       (return))
                      (t
                       ;; Not the last form.
@@ -3206 +3212 @@
     (dolist (variable (m-v-b-free-specials block))
       (push variable *visible-variables*))
     ;; Body.
-    (let ((*blocks* (cons block *blocks*)))
+    (let ((*blocks* (cons block *blocks*))
+          (*outer-block-restores-environment*
+           (or *outer-block-restores-environment* bind-special-p)))
       (compile-progn-body (cdddr form) target))
     (when bind-special-p
-      (restore-dynamic-environment (m-v-b-environment-register block)))))
+      (unless *outer-block-restores-environment*
+        (restore-dynamic-environment (m-v-b-environment-register block))))))
 
 (defun propagate-vars (block)
   (let ((removed '()))
@@ -3564 +3573 @@
     ;; Body of LET/LET*.
     (with-saved-compiler-policy
       (process-optimization-declarations (cddr form))
-      (let ((*blocks* (cons block *blocks*)))
+      (let ((*blocks* (cons block *blocks*))
+            (*outer-block-restores-environment*
+             (or *outer-block-restores-environment* specialp)))
         (compile-progn-body (cddr form) target representation)))
     (when specialp
-      (restore-dynamic-environment (let-environment-register block)))))
+      (unless *outer-block-restores-environment*
+        (restore-dynamic-environment (let-environment-register block))))))
 
 (defknown p2-locally-node (t t t) t)
 (defun p2-locally-node (block target representation)
@@ -3967 +3979 @@
       (emit-invokestatic +lisp+ "progvBindVars"
        (list +lisp-object+ +lisp-object+ +lisp-thread+) nil))
       ;; Implicit PROGN.
-    (let ((*blocks* (cons block *blocks*)))
+    (let ((*blocks* (cons block *blocks*))
+          (*outer-block-restores-environment* t))
       (compile-progn-body (cdddr form) target representation))
-    (restore-dynamic-environment environment-register)))
+    (unless *outer-block-restores-environment*
+      (restore-dynamic-environment environment-register))))
 
 (defun p2-quote (form target representation)
   (aver (or (null representation) (eq representation :boolean)))
@@ -6954 +6968 @@
 
 (defknown compile-form (t t t) t)
 (defun compile-form (form target representation)
-  (cond ((consp form)
-         (let* ((op (%car form))
-                (handler (and (symbolp op) (get op 'p2-handler))))
-           (cond (handler
-                  (funcall handler form target representation))
-                 ((symbolp op)
-                  (cond ((macro-function op *compile-file-environment*)
-                         (compile-form (macroexpand form *compile-file-environment*)
-                                       target representation))
-                        ((special-operator-p op)
-                         (dformat t "form = ~S~%" form)
-                         (compiler-unsupported
-                          "COMPILE-FORM: unsupported special operator ~S" op))
-                        (t
-                         (compile-function-call form target representation))))
-                 ((and (consp op) (eq (%car op) 'LAMBDA))
-                  (aver (progn 'unexpected-lambda nil))
-                  (let ((new-form (list* 'FUNCALL form)))
-                    (compile-form new-form target representation)))
+  (let ((outer-block-restores *outer-block-restores-environment*)
+        (*outer-block-restores-environment* nil))
+    (cond ((consp form)
+           (let* ((op (%car form))
+                  (handler (and (symbolp op) (get op 'p2-handler))))
+             (cond (handler
+                    (funcall handler form target representation))
+                   ((symbolp op)
+                    (cond ((macro-function op *compile-file-environment*)
+                           (compile-form (macroexpand form *compile-file-environment*)
+                                         target representation))
+                          ((special-operator-p op)
+                           (dformat t "form = ~S~%" form)
+                           (compiler-unsupported
+                            "COMPILE-FORM: unsupported special operator ~S" op))
+                          (t
+                           (compile-function-call form target representation))))
+                   ((and (consp op) (eq (%car op) 'LAMBDA))
+                    (aver (progn 'unexpected-lambda nil))
+                    (let ((new-form (list* 'FUNCALL form)))
+                      (compile-form new-form target representation)))
+                   (t
+                    (compiler-unsupported "COMPILE-FORM unhandled case ~S" form)))))
+          ((symbolp form)
+           (cond ((null form)
+                  (emit-push-false representation)
+                  (emit-move-from-stack target representation))
+                 ((eq form t)
+                  (emit-push-true representation)
+                  (emit-move-from-stack target representation))
+                 ((keywordp form)
+                  (ecase representation
+                    (:boolean
+                     (emit 'iconst_1))
+                    ((nil)
+                     (emit-load-externalized-object form)))
+                  (emit-move-from-stack target representation))
                  (t
-                  (compiler-unsupported "COMPILE-FORM unhandled case ~S" form)))))
-        ((symbolp form)
-         (cond ((null form)
-                (emit-push-false representation)
-                (emit-move-from-stack target representation))
-               ((eq form t)
-                (emit-push-true representation)
-                (emit-move-from-stack target representation))
-               ((keywordp form)
-                (ecase representation
-                  (:boolean
-                   (emit 'iconst_1))
-                  ((nil)
-                   (emit-load-externalized-object form)))
-                (emit-move-from-stack target representation))
-               (t
-                ;; Shouldn't happen.
-                (aver nil))))
-        ((var-ref-p form)
-         (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)
-            (p2-let/let*-node form target representation))
-           ((tagbody-node-p form)
-            (p2-tagbody-node form target)
-            (fix-boxing representation nil))
-           ((unwind-protect-node-p form)
-            (p2-unwind-protect-node form target)
-            (fix-boxing representation nil))
-           ((m-v-b-node-p form)
-            (p2-m-v-b-node form target)
-            (fix-boxing representation nil))
-           ((flet-node-p form)
-            (p2-flet-node form target representation))
-           ((labels-node-p form)
-            (p2-labels-node form target representation))
-           ((locally-node-p form)
-            (p2-locally-node form target representation))
-           ((catch-node-p form)
-            (p2-catch-node form target)
-            (fix-boxing representation nil))
-           ((progv-node-p form)
-            (p2-progv-node form target representation))
-           ((synchronized-node-p form)
-            (p2-threads-synchronized-on form target)
-            (fix-boxing representation nil))
-           (t
-            (aver (not "Can't happen")))
-))
-        ((constantp form)
-         (compile-constant form target representation))
-        (t
-         (compiler-unsupported "COMPILE-FORM unhandled case ~S" form)))
+                  ;; Shouldn't happen.
+                  (aver nil))))
+          ((var-ref-p form)
+           (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)
+              (setq *outer-block-restores-environment* outer-block-restores)
+              (p2-let/let*-node form target representation))
+             ((tagbody-node-p form)
+              (p2-tagbody-node form target)
+              (fix-boxing representation nil))
+             ((unwind-protect-node-p form)
+              (p2-unwind-protect-node form target)
+              (fix-boxing representation nil))
+             ((m-v-b-node-p form)
+              (setq *outer-block-restores-environment* outer-block-restores)
+              (p2-m-v-b-node form target)
+              (fix-boxing representation nil))
+             ((flet-node-p form)
+              (p2-flet-node form target representation))
+             ((labels-node-p form)
+              (p2-labels-node form target representation))
+             ((locally-node-p form)
+              (p2-locally-node form target representation))
+             ((catch-node-p form)
+              (p2-catch-node form target)
+              (fix-boxing representation nil))
+             ((progv-node-p form)
+              (setq *outer-block-restores-environment* outer-block-restores)
+              (p2-progv-node form target representation))
+             ((synchronized-node-p form)
+              (p2-threads-synchronized-on form target)
+              (fix-boxing representation nil))
+             (t
+              (aver (not "Can't happen")))
+             ))
+          ((constantp form)
+           (compile-constant form target representation))
+          (t
+           (compiler-unsupported "COMPILE-FORM unhandled case ~S" form))))
   t)
 
 
@@ -7301 +7320 @@
                                 +lisp-special-binding+)
             (astore (variable-binding-register variable)))))
 
-      (compile-progn-body body 'stack)
+      (let ((*outer-block-restores-environment*
+             (compiland-environment-register compiland)))
+        (compile-progn-body body 'stack))
 
       (when (compiland-environment-register compiland)
         (restore-dynamic-environment (compiland-environment-register compiland)))