Changeset 14098

Timestamp:

08/16/12 20:09:23 (8 years ago)

Author:

ehuelsmann

Message:

Reorganize binding *CURRENT-COMPILAND*, WITH-SAVED-COMPILER-POLICY.
Add missing WITH-SAVED-COMPILER-POLICY and PROCESS-OPTIMIZATION-DECLARATIONS.

File:

• trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (modified) (8 diffs)

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

@@ -3252 +3252 @@
       (push variable *visible-variables*))
     ;; Body.
-    (let ((*blocks* (cons block *blocks*)))
-      (compile-progn-body (cdddr form) target))
+    (with-saved-compiler-policy
+      (process-optimization-declarations (cdddr form))
+      (let ((*blocks* (cons block *blocks*)))
+        (compile-progn-body (cdddr form) target)))
     (when bind-special-p
       (restore-dynamic-environment (m-v-b-environment-register block)))))
@@ -4103 +4105 @@
                                    :if-exists :supersede)))
       (with-class-file class-file
-        (let ((*current-compiland* compiland))
-          (with-saved-compiler-policy
-              (compile-to-jvm-class compiland)
-            (finish-class (compiland-class-file compiland) f)))))
+        (compile-to-jvm-class compiland)
+        (finish-class (compiland-class-file compiland) f)))
     (when stream
       (let ((bytes (sys::%get-output-stream-bytes stream)))
@@ -4128 +4128 @@
     (dolist (special (flet-free-specials block))
       (push special *visible-variables*))
-    (let ((*blocks* (cons block *blocks*)))
-      (compile-progn-body body target representation))))
+    (with-saved-compiler-policy
+      (process-optimization-declarations body)
+      (let ((*blocks* (cons block *blocks*)))
+        (compile-progn-body body target representation)))))
 
 (defknown p2-labels-node (t t t) t)
@@ -4144 +4146 @@
     (dolist (special (labels-free-specials block))
       (push special *visible-variables*))
-    (let ((*blocks* (cons block *blocks*)))
-      (compile-progn-body body target representation))))
+    (with-saved-compiler-policy
+      (process-optimization-declarations body)
+      (let ((*blocks* (cons block *blocks*)))
+        (compile-progn-body body target representation)))))
 
 (defun p2-lambda (local-function target)
@@ -7056 +7060 @@
 
          (*thread* nil)
-         (*initialize-thread-var* nil))
+         (*initialize-thread-var* nil)
+         (*current-compiland* compiland))
 
     (with-code-to-method (class-file method)
@@ -7172 +7177 @@
               (setf (variable-index variable) nil)))))
 
-      (p2-compiland-process-type-declarations body)
-      (generate-type-checks-for-variables (compiland-arg-vars compiland))
+      (with-saved-compiler-policy
+        (process-optimization-declarations body)
+
+        (p2-compiland-process-type-declarations body)
+        (generate-type-checks-for-variables (compiland-arg-vars compiland))
 
       ;; Unbox variables.
-      (dolist (variable (compiland-arg-vars compiland))
-        (p2-compiland-unbox-variable variable))
+        (dolist (variable (compiland-arg-vars compiland))
+          (p2-compiland-unbox-variable variable))
 
       ;; Establish dynamic bindings for any variables declared special.
-      (when (some #'variable-special-p (compiland-arg-vars compiland))
-        ;; Save the dynamic environment
-        (setf (compiland-environment-register compiland)
-              (allocate-register nil))
-        (save-dynamic-environment (compiland-environment-register compiland))
-        (dolist (variable (compiland-arg-vars compiland))
-          (when (variable-special-p variable)
-            (setf (variable-binding-register variable) (allocate-register nil))
-            (emit-push-current-thread)
-            (emit-push-variable-name variable)
-            (cond ((variable-register variable)
-                   (aload (variable-register variable))
-                   (setf (variable-register variable) nil))
-                  ((variable-index variable)
-                   (aload (compiland-argument-register compiland))
-                   (emit-push-constant-int (variable-index variable))
-                   (emit 'aaload)
-                   (setf (variable-index variable) nil)))
-            (emit-invokevirtual +lisp-thread+ "bindSpecial"
-                                (list +lisp-symbol+ +lisp-object+)
-                                +lisp-special-binding+)
-            (astore (variable-binding-register variable)))))
-
-      (compile-progn-body body 'stack)
+        (when (some #'variable-special-p (compiland-arg-vars compiland))
+          ;; Save the dynamic environment
+          (setf (compiland-environment-register compiland)
+                (allocate-register nil))
+          (save-dynamic-environment (compiland-environment-register compiland))
+          (dolist (variable (compiland-arg-vars compiland))
+            (when (variable-special-p variable)
+              (setf (variable-binding-register variable) (allocate-register nil))
+              (emit-push-current-thread)
+              (emit-push-variable-name variable)
+              (cond ((variable-register variable)
+                     (aload (variable-register variable))
+                     (setf (variable-register variable) nil))
+                    ((variable-index variable)
+                     (aload (compiland-argument-register compiland))
+                     (emit-push-constant-int (variable-index variable))
+                     (emit 'aaload)
+                     (setf (variable-index variable) nil)))
+              (emit-invokevirtual +lisp-thread+ "bindSpecial"
+                                  (list +lisp-symbol+ +lisp-object+)
+                                  +lisp-special-binding+)
+              (astore (variable-binding-register variable)))))
+
+        (compile-progn-body body 'stack))
 
       (when (compiland-environment-register compiland)
@@ -7293 +7301 @@
         (*closure-variables* nil)
         (*undefined-variables* nil)
-        (*local-functions* *local-functions*)
-        (*current-compiland* compiland))
-    (with-saved-compiler-policy
-        ;; Pass 1.
-        (p1-compiland compiland))
-
+        (*local-functions* *local-functions*))
+
+    (p1-compiland compiland)
     ;; *all-variables* doesn't contain variables which
     ;; are in an enclosing lexical environment (variable-environment)
@@ -7324 +7329 @@
 
     (with-class-file (compiland-class-file compiland)
-      (with-saved-compiler-policy
-        (compile-to-jvm-class compiland)
-        ;;        (finalize-class-file (compiland-class-file compiland))
-        (finish-class (compiland-class-file compiland) stream)))))
+      (compile-to-jvm-class compiland)
+      (finish-class (compiland-class-file compiland) stream))))
 
 (defvar *compiler-error-bailout*)