Changeset 11819


Ignore:
Timestamp:
05/03/09 08:46:39 (13 years ago)
Author:
ehuelsmann
Message:

Small refactoring: introduce a centralized definition of
"enclosed by a block which associates extensive cleanup
with a transfer of control exception".

Also some reordering of functions in jvm.lisp.

Location:
trunk/abcl/src/org/armedbear/lisp
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp

    r11818 r11819  
    313313           ;; its cleanup forms.
    314314           (dformat t "*blocks* = ~S~%" (mapcar #'block-name *blocks*))
    315            (let ((protected
    316                   (dolist (enclosing-block *blocks*)
    317                     (when (eq enclosing-block block)
    318                       (return nil))
    319                     (when (block-requires-non-local-exit-p enclosing-block)
    320                       (return t)))))
     315           (let ((protected (enclosed-by-protected-block-p block)))
    321316             (dformat t "p1-return-from protected = ~S~%" protected)
    322317             (when protected
     
    366361      (cond ((eq (tag-compiland tag) *current-compiland*)
    367362             ;; Does the GO leave an enclosing UNWIND-PROTECT?
    368              (let ((protected
    369                     (dolist (enclosing-block *blocks*)
    370                       (when (eq enclosing-block tag-block)
    371                         (return nil))
    372                       (when (block-requires-non-local-exit-p enclosing-block)
    373                         (return t)))))
    374                (when protected
    375                  (setf (block-non-local-go-p tag-block) t))))
     363             (when (enclosed-by-protected-block-p tag-block)
     364               (setf (block-non-local-go-p tag-block) t)))
    376365            (t
    377366             (setf (block-non-local-go-p tag-block) t)))))
  • trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

    r11818 r11819  
    44394439      (compile-progn-body body target representation))))
    44404440
    4441 (defknown find-tag (t) t)
    4442 (defun find-tag (name)
    4443   (dolist (tag *visible-tags*)
    4444     (when (eql name (tag-name tag))
    4445       (return tag))))
    4446 
    44474441(defknown p2-tagbody-node (t t) t)
    44484442(defun p2-tagbody-node (block target)
     
    45354529      ;; Local case.
    45364530      (let* ((tag-block (tag-block tag))
    4537              (register nil)
    4538              (protected
    4539               ;; Does the GO leave an enclosing CATCH or UNWIND-PROTECT?
    4540               (dolist (enclosing-block *blocks*)
    4541                 (when (eq enclosing-block tag-block)
    4542                   (return nil))
    4543                 (when (block-requires-non-local-exit-p enclosing-block)
    4544                   (return t)))))
    4545         (unless protected
     4531             (register nil))
     4532        (unless (enclosed-by-protected-block-p tag-block)
    45464533          (dolist (block *blocks*)
    45474534            (if (eq block tag-block)
     
    47234710        ;; Local case. Is the RETURN nested inside an UNWIND-PROTECT which is
    47244711        ;; inside the block we're returning from?
    4725         (let ((protected
    4726                (dolist (enclosing-block *blocks*)
    4727                  (when (eq enclosing-block block)
    4728                    (return nil))
    4729                  (when (block-requires-non-local-exit-p enclosing-block)
    4730                    (return t)))))
    4731           (unless protected
    4732             (unless (compiland-single-valued-p *current-compiland*)
     4712        (unless (enclosed-by-protected-block-p block)
     4713          (unless (compiland-single-valued-p *current-compiland*)
    47334714;;               (format t "compiland not single-valued: ~S~%"
    47344715;;                       (compiland-name *current-compiland*))
    4735               (emit-clear-values))
    4736             (compile-form result-form (block-target block) nil)
    4737             (emit 'goto (block-exit block))
    4738             (return-from p2-return-from)))))
     4716            (emit-clear-values))
     4717          (compile-form result-form (block-target block) nil)
     4718          (emit 'goto (block-exit block))
     4719          (return-from p2-return-from))))
    47394720    ;; Non-local RETURN.
    47404721    (aver (block-non-local-return-p block))
  • trunk/abcl/src/org/armedbear/lisp/jvm.lisp

    r11818 r11819  
    369369  )
    370370
     371(defvar *blocks* ())
     372
     373(defun find-block (name)
     374  (dolist (block *blocks*)
     375    (when (eq name (block-name block))
     376      (return block))))
     377
    371378(defknown node-constant-p (t) boolean)
    372379(defun node-constant-p (object)
     
    390397  (memq (block-name object) '(CATCH UNWIND-PROTECT)))
    391398
    392 (defvar *blocks* ())
    393 
    394 (defun find-block (name)
    395   (dolist (block *blocks*)
    396     (when (eq name (block-name block))
    397       (return block))))
     399
     400(defknown enclosed-by-protected-block-p (&optional outermost-block) boolean)
     401(defun enclosed-by-protected-block-p (&optional outermost-block)
     402  "Indicates whether the code being compiled/analyzed is enclosed in
     403a block which requires a non-local transfer of control exception to
     404be generated.
     405"
     406  (dolist (enclosing-block *blocks*)
     407    (when (eq enclosing-block outermost-block)
     408      (return-from enclosed-by-protected-block-p nil))
     409    (when (block-requires-non-local-exit-p enclosing-block)
     410      (return-from enclosed-by-protected-block-p t))))
     411
    398412
    399413(defstruct tag
     
    402416  block
    403417  (compiland *current-compiland*))
     418
     419(defknown find-tag (t) t)
     420(defun find-tag (name)
     421  (dolist (tag *visible-tags*)
     422    (when (eql name (tag-name tag))
     423      (return tag))))
    404424
    405425(defun process-ignore/ignorable (declaration names variables)
Note: See TracChangeset for help on using the changeset viewer.