Changeset 11851


Ignore:
Timestamp:
05/09/09 20:05:25 (12 years ago)
Author:
ehuelsmann
Message:

Local transfer of control with environment restoration
efficiency: don't save the environment on each block/tagbody start.

Only restore the environment when restoration is required,
using the value in the outermost block which saved an environment.

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

Legend:

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

    r11847 r11851  
    44124412         (END-BLOCK (gensym))
    44134413         (EXIT (gensym))
    4414          (must-clear-values nil)
    4415          environment-register)
    4416     (when (block-needs-environment-restoration block)
    4417       (setf environment-register (allocate-register)
    4418             (block-environment-register block) environment-register))
     4414         (must-clear-values nil))
    44194415    ;; Scan for tags.
    44204416    (dolist (tag (block-tags block))
    44214417      (push tag *visible-tags*))
    44224418
    4423     (when environment-register
    4424       ;; Note: we store the environment register,
    4425       ;; but since we don't manipulate the environment,
    4426       ;; we don't need to restore.
    4427       ;;
    4428       ;; It's here so local transfers of control can restore
    4429       ;; what we started with.
    4430       ;;
    4431       ;; Non-local transfers of control restore the environment
    4432       ;; themselves (in the finally of LET/LET*, etc.
    4433       (save-dynamic-environment environment-register))
    44344419    (label BEGIN-BLOCK)
    44354420    (do* ((rest body (cdr rest))
     
    45104495      ;; Local case with local transfer of control
    45114496      ;;   Note: Local case with non-local transfer of control handled below
    4512       (when (block-environment-register tag-block)
     4497      (when (and (block-needs-environment-restoration tag-block)
     4498                 (enclosed-by-environment-setting-block-p tag-block))
    45134499        ;; If there's a dynamic environment to restore, do it.
    4514   (restore-dynamic-environment (block-environment-register tag-block)))
     4500  (restore-dynamic-environment (environment-register-to-restore tag-block)))
    45154501      (maybe-generate-interrupt-check)
    45164502      (emit 'goto (tag-label tag))
     
    46204606          (dformat t "*all-variables* = ~S~%"
    46214607                   (mapcar #'variable-name *all-variables*))
    4622           (when (block-needs-environment-restoration block)
    4623             ;; Save the current dynamic environment.
    4624             (setf (block-environment-register block) (allocate-register))
    4625             (save-dynamic-environment (block-environment-register block)))
    46264608          (setf (block-catch-tag block) (gensym))
    46274609          (let* ((*register* *register*)
     
    46584640                      *handlers*)))
    46594641            (label BLOCK-EXIT))
    4660           (when (block-environment-register block)
    4661             ;; We saved the dynamic environment above. Restore it now.
    4662             (restore-dynamic-environment (block-environment-register block)))
    46634642          (fix-boxing representation nil)))))
    46644643
     
    46824661            (emit-clear-values))
    46834662          (compile-form result-form (block-target block) nil)
     4663          (when (and (block-needs-environment-restoration block)
     4664                     (enclosed-by-environment-setting-block-p block))
     4665            (restore-dynamic-environment (environment-register-to-restore block)))
    46844666          (emit 'goto (block-exit block))
    46854667          (return-from p2-return-from))))
  • trunk/abcl/src/org/armedbear/lisp/jvm.lisp

    r11829 r11851  
    428428      (return t))))
    429429
     430(defknown environment-register-to-restore (&optional t) t)
     431(defun environment-register-to-restore (&optional outermost-block)
     432  "Returns the environment register which contains the
     433saved environment from the outermost enclosing block:
     434
     435That's the one which contains the environment used in the outermost block."
     436  (flet ((outermost-register (last-register block)
     437           (when (eq block outermost-block)
     438             (return-from environment-register-to-restore last-register))
     439           (or (block-environment-register block)
     440               last-register)))
     441    (reduce #'outermost-register *blocks*
     442            :initial-value nil)))
     443
    430444(defstruct tag
    431445  ;; The symbol (or integer) naming the tag
Note: See TracChangeset for help on using the changeset viewer.