Changeset 12086

Timestamp:

08/08/09 15:20:28 (14 years ago)

Author:

ehuelsmann

Message:

Make every form which may contain free specials declarations a BLOCK-NODE.

LOCALLY, FLET and LABELS were not converted to blocks - yet.

While at it, change the block dispatch routine: we're not smart enough to
detect that the (block-name form) form will generate the same value every
time - so we don't cache the function result, but evaluate it each time.

Location:

trunk/abcl/src/org/armedbear/lisp

Files:

• compiler-pass1.lisp (modified) (3 diffs)
• compiler-pass2.lisp (modified) (7 diffs)

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

@@ -234 +234 @@
 
 (defun p1-locally (form)
-  (let ((*visible-variables* *visible-variables*)
-        (specials (process-special-declarations (cdr form))))
-    (dolist (name specials)
+  (let* ((*visible-variables* *visible-variables*)
+         (block (make-block-node '(LOCALLY)))
+         (free-specials (process-declarations-for-vars (cdr form) nil)))
+    (setf (block-free-specials block) free-specials)
+    (dolist (special free-specials)
 ;;       (format t "p1-locally ~S is special~%" name)
-      (push (make-variable :name name :special-p t) *visible-variables*))
-    (setf (cdr form) (p1-body (cdr form)))
-    form))
+      (push special *visible-variables*))
+    (let ((*blocks* (cons block *blocks*)))
+      (setf (block-form block)
+            (list* 'LOCALLY (p1-body (cdr form))))
+      block)))
 
 (defknown p1-m-v-b (t) t)
@@ -632 +636 @@
       ((with-saved-compiler-policy
      (process-optimization-declarations (cddr form))
-   (list* (car form) local-functions (p1-body (cddr form)))))))
+         (let* ((block (make-block-node '(FLET)))
+                (*blocks* (cons block *blocks*))
+                (body (cddr form))
+                (*visible-variables* *visible-variables*))
+           (setf (block-free-specials block)
+                 (process-declarations-for-vars body nil))
+           (dolist (special (block-free-specials block))
+             (push special *visible-variables*))
+           (setf (block-form block)
+                 (list* (car form) local-functions (p1-body (cddr form))))
+           block)))))
 
 
@@ -652 +666 @@
          (*current-compiland* (local-function-compiland local-function)))
      (p1-compiland (local-function-compiland local-function))))
-       (list* (car form) local-functions (p1-body (cddr form))))))
+       (let* ((block (make-block-node '(LABELS)))
+              (*blocks* (cons block *blocks*))
+              (body (cddr form))
+              (*visible-variables* *visible-variables*))
+         (setf (block-free-specials block)
+               (process-declarations-for-vars body nil))
+         (dolist (special (block-free-specials block))
+           (push special *visible-variables*))
+         (setf (block-form block)
+               (list* (car form) local-functions (p1-body (cddr form))))
+         block))))
 
 (defknown p1-funcall (t) t)

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

@@ -4437 +4437 @@
               label-START))))
 
-(defun p2-locally (form target representation)
+(defknown p2-locally-node (t t t) t)
+(defun p2-locally-node (block target representation)
   (with-saved-compiler-policy
-    (let* ((body (cdr form))
-           (*visible-variables* *visible-variables*)
-           (specials (process-special-declarations body)))
-      (dolist (name specials)
-        (push (make-variable :name name :special-p t) *visible-variables*))
+    (let* ((body (cdr (block-form block)))
+           (*visible-variables* (append (block-free-specials block)
+                                        *visible-variables*))
+           (*blocks* (cons block *blocks*)))
       (process-optimization-declarations body)
       (compile-progn-body body target representation))))
@@ -4953 +4953 @@
       local-function compiland g)))))))
 
-(defknown p2-flet (t t t) t)
-(defun p2-flet (form target representation)
-  (let ((*local-functions* *local-functions*)
-        (*visible-variables* *visible-variables*)
-        (local-functions (cadr form))
-        (body (cddr form)))
+(defknown p2-flet-node (t t t) t)
+(defun p2-flet-node (block target representation)
+  (let* ((form (block-form block))
+         (*local-functions* *local-functions*)
+         (*visible-variables* *visible-variables*)
+         (local-functions (cadr form))
+         (body (cddr form)))
     (dolist (local-function local-functions)
       (p2-flet-process-compiland local-function))
     (dolist (local-function local-functions)
       (push local-function *local-functions*))
-    (dolist (special (process-special-declarations body))
-      (push (make-variable :name special :special-p t) *visible-variables*))
+    (dolist (special (block-free-specials block))
+      (push special *visible-variables*))
     (compile-progn-body body target representation)))
 
-(defknown p2-labels (t t t) t)
-(defun p2-labels (form target representation)
-  (let ((*local-functions* *local-functions*)
-        (*visible-variables* *visible-variables*)
-        (local-functions (cadr form))
-        (body (cddr form)))
+(defknown p2-labels-node (t t t) t)
+(defun p2-labels-node (block target representation)
+  (let* ((form (block-form block))
+         (*local-functions* *local-functions*)
+         (*visible-variables* *visible-variables*)
+         (local-functions (cadr form))
+         (body (cddr form)))
     (dolist (local-function local-functions)
       (push local-function *local-functions*)
@@ -4983 +4985 @@
     (dolist (local-function local-functions)
       (p2-labels-process-compiland local-function))
-    (dolist (special (process-special-declarations body))
-      (push (make-variable :name special :special-p t) *visible-variables*))
+    (dolist (special (block-free-specials block))
+      (push special *visible-variables*))
     (compile-progn-body body target representation)))
 
@@ -7902 +7904 @@
          (compile-var-ref form target representation))
         ((block-node-p form)
-         (cond ((equal (block-name form) '(TAGBODY))
-                (p2-tagbody-node form target)
-                (fix-boxing representation nil))
-               ((equal (block-name form) '(LET))
-                (p2-let/let*-node form target representation))
-               ((equal (block-name form) '(MULTIPLE-VALUE-BIND))
-                (p2-m-v-b-node form target)
-                (fix-boxing representation nil))
-               ((equal (block-name form) '(UNWIND-PROTECT))
-                (p2-unwind-protect-node form target)
-                (fix-boxing representation nil))
-               ((equal (block-name form) '(CATCH))
-                (p2-catch-node form target)
-                (fix-boxing representation nil))
-               ((equal (block-name form) '(PROGV))
-                (p2-progv-node form target representation))
-               ((equal (block-name form) '(THREADS:SYNCHRONIZED-ON))
-                (p2-threads-synchronized-on form target)
-                (fix-boxing representation nil))
-               (t
-                (p2-block-node form target representation))))
+         (let ((name (block-name form)))
+           (if (not (consp name))
+               (p2-block-node form target representation)
+               (let ((name (car name)))
+                 (cond ((eq name 'TAGBODY)
+                        (p2-tagbody-node form target)
+                        (fix-boxing representation nil))
+                       ((eq name 'LET)
+                        (p2-let/let*-node form target representation))
+                       ((eq name 'FLET)
+                        (p2-flet-node form target representation))
+                       ((eq name 'LABELS)
+                        (p2-labels-node form target representation))
+                       ((eq name 'MULTIPLE-VALUE-BIND)
+                        (p2-m-v-b-node form target)
+                        (fix-boxing representation nil))
+                       ((eq name 'UNWIND-PROTECT)
+                        (p2-unwind-protect-node form target)
+                        (fix-boxing representation nil))
+                       ((eq name 'CATCH)
+                        (p2-catch-node form target)
+                        (fix-boxing representation nil))
+                       ((eq name 'PROGV)
+                        (p2-progv-node form target representation))
+                       ((eq name 'LOCALLY)
+                        (p2-locally-node form target representation))
+                       ((eq name 'THREADS:SYNCHRONIZED-ON)
+                        (p2-threads-synchronized-on form target)
+                        (fix-boxing representation nil)))))))
         ((constantp form)
          (compile-constant form target representation))
@@ -8597 +8607 @@
   (install-p2-handler 'find-class          'p2-find-class)
   (install-p2-handler 'fixnump             'p2-fixnump)
-  (install-p2-handler 'flet                'p2-flet)
   (install-p2-handler 'funcall             'p2-funcall)
   (install-p2-handler 'function            'p2-function)
@@ -8607 +8616 @@
   (install-p2-handler 'go                  'p2-go)
   (install-p2-handler 'if                  'p2-if)
-  (install-p2-handler 'labels              'p2-labels)
   (install-p2-handler 'length              'p2-length)
   (install-p2-handler 'list                'p2-list)
@@ -8614 +8622 @@
   (install-p2-handler 'sys::backq-list*    'p2-list*)
   (install-p2-handler 'load-time-value     'p2-load-time-value)
-  (install-p2-handler 'locally             'p2-locally)
   (install-p2-handler 'logand              'p2-logand)
   (install-p2-handler 'logior              'p2-logior)