Changeset 11820


Ignore:
Timestamp:
05/03/09 10:10:21 (13 years ago)
Author:
ehuelsmann
Message:

Make local GO restore the environment of the TAGBODY,
in case it jumps out of blocks setting the environment.

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

Legend:

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

    r11819 r11820  
    361361      (cond ((eq (tag-compiland tag) *current-compiland*)
    362362             ;; Does the GO leave an enclosing UNWIND-PROTECT?
    363              (when (enclosed-by-protected-block-p tag-block)
    364                (setf (block-non-local-go-p tag-block) t)))
     363             (if (enclosed-by-protected-block-p tag-block)
     364                 (setf (block-non-local-go-p tag-block) t)
     365                 ;; non-local GO's ensure environment restoration
     366                 ;; find out about this local GO
     367                 (when (null (block-needs-environment-restoration tag-block))
     368                   (setf (block-needs-environment-restoration tag-block)
     369                         (enclosed-by-environment-setting-block-p tag-block)))))
    365370            (t
    366371             (setf (block-non-local-go-p tag-block) t)))))
  • trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

    r11819 r11820  
    44504450         (END-BLOCK (gensym))
    44514451         (EXIT (gensym))
    4452          (must-clear-values nil))
     4452         (must-clear-values nil)
     4453         environment-register)
     4454    (when (block-needs-environment-restoration block)
     4455      (setf environment-register (allocate-register)
     4456            (block-environment-register block) environment-register))
    44534457    ;; Scan for tags.
    44544458    (dolist (subform body)
     
    44574461          (push tag local-tags)
    44584462          (push tag *visible-tags*))))
     4463
     4464    (when environment-register
     4465      ;; Note: we store the environment register,
     4466      ;; but since we don't manipulate the environment,
     4467      ;; we don't need to restore.
     4468      ;;
     4469      ;; It's here so local transfers of control can restore
     4470      ;; what we started with.
     4471      ;;
     4472      ;; Non-local transfers of control restore the environment
     4473      ;; themselves (in the finally of LET/LET*, etc.
     4474      (emit-push-current-thread)
     4475      (emit 'getfield +lisp-thread-class+ "lastSpecialBinding"
     4476            +lisp-special-binding+)
     4477      (astore environment-register))
    44594478    (label BEGIN-BLOCK)
    44604479    (do* ((rest body (cdr rest))
     
    45234542  (declare (ignore representation))
    45244543  (let* ((name (cadr form))
    4525          (tag (find-tag name)))
     4544         (tag (find-tag name))
     4545         (tag-block (when tag (tag-block tag))))
    45264546    (unless tag
    45274547      (error "p2-go: tag not found: ~S" name))
    4528     (when (eq (tag-compiland tag) *current-compiland*)
    4529       ;; Local case.
    4530       (let* ((tag-block (tag-block tag))
    4531              (register nil))
    4532         (unless (enclosed-by-protected-block-p tag-block)
    4533           (dolist (block *blocks*)
    4534             (if (eq block tag-block)
    4535                 (return)
    4536                 (setf register (or (block-environment-register block) register))))
    4537           (when register
    4538             ;; Restore dynamic environment.
    4539             (aload *thread*)
    4540             (aload register)
    4541             (emit 'putfield +lisp-thread-class+ "lastSpecialBinding"
    4542                   +lisp-special-binding+))
    4543           (maybe-generate-interrupt-check)
    4544           (emit 'goto (tag-label tag))
    4545           (return-from p2-go))))
     4548    (when (and (eq (tag-compiland tag) *current-compiland*)
     4549               (not (enclosed-by-protected-block-p tag-block)))
     4550      ;; Local case with local transfer of control
     4551      ;;   Note: Local case with non-local transfer of control handled below
     4552      (when (block-environment-register tag-block)
     4553        ;; If there's a dynamic environment to restore, do it.
     4554        (aload *thread*)
     4555        (aload (block-environment-register tag-block))
     4556        (emit 'putfield +lisp-thread-class+ "lastSpecialBinding"
     4557              +lisp-special-binding+))
     4558      (maybe-generate-interrupt-check)
     4559      (emit 'goto (tag-label tag))
     4560      (return-from p2-go))
    45464561    ;; Non-local GO.
    45474562    (emit 'new +lisp-go-class+)
  • trunk/abcl/src/org/armedbear/lisp/jvm.lisp

    r11819 r11820  
    362362  ;; True if a tag in this tagbody is the target of a non-local GO.
    363363  non-local-go-p
     364  ;; If non-nil, the TAGBODY contains local blocks which "contaminate" the
     365  ;; environment, with GO forms in them which target tags in this TAGBODY
     366  needs-environment-restoration
    364367  ;; If non-nil, register containing saved dynamic environment for this block.
    365368  environment-register
     
    410413      (return-from enclosed-by-protected-block-p t))))
    411414
     415(defknown enclosed-by-environment-setting-block-p (&optional outermost-block)
     416  boolean)
     417(defun enclosed-by-environment-setting-block-p (&optional outermost-block)
     418  (dolist (enclosing-block *blocks*)
     419    (when (eq enclosing-block outermost-block)
     420      (return nil))
     421    (when (block-environment-register enclosing-block)
     422      (return t))))
    412423
    413424(defstruct tag
Note: See TracChangeset for help on using the changeset viewer.