Changeset 12136


Ignore:
Timestamp:
09/06/09 14:54:42 (12 years ago)
Author:
ehuelsmann
Message:

Clean up BLOCK-NODE handling and p2-block-node; remove

RETURN-P and CATCH-TAG slots.

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

Legend:

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

    r12123 r12136  
    362362                      name name))
    363363    (dformat t "p1-return-from block = ~S~%" (block-name block))
    364     (setf (block-return-p block) t)
    365364    (cond ((eq (block-compiland block) *current-compiland*)
    366365           ;; Local case. If the RETURN is nested inside an UNWIND-PROTECT
  • trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

    r12135 r12136  
    46434643    (aver (block-node-p block)))
    46444644  (let* ((*blocks* (cons block *blocks*))
    4645          (*register* *register*))
    4646     (if (null (block-return-p block))
    4647         ;; No explicit returns
    4648         (compile-progn-body (cddr (block-form block)) target representation)
    4649         (progn
    4650           (setf (block-target block) target)
    4651           (dformat t "p2-block-node lastSpecialBinding~%")
    4652           (dformat t "*all-variables* = ~S~%"
    4653                    (mapcar #'variable-name *all-variables*))
    4654           (setf (block-catch-tag block) (gensym))
    4655           (let* ((*register* *register*)
    4656                  (BEGIN-BLOCK (gensym))
    4657                  (END-BLOCK (gensym))
    4658                  (BLOCK-EXIT (block-exit block)))
    4659             (label BEGIN-BLOCK) ; Start of protected range.
    4660             ;; Implicit PROGN.
    4661             (compile-progn-body (cddr (block-form block)) target)
    4662             (label END-BLOCK) ; End of protected range.
    4663             (emit 'goto BLOCK-EXIT) ; Jump over handler (if any).
    4664             (when (block-non-local-return-p block)
    4665               ;; We need a handler to catch non-local RETURNs.
    4666               (let ((HANDLER (gensym))
    4667                     (RETHROW (gensym)))
    4668                 (label HANDLER)
    4669                 ;; The Return object is on the runtime stack. Stack depth is 1.
    4670                 (emit 'dup) ; Stack depth is 2.
    4671                 (emit 'getfield +lisp-return-class+ "tag" +lisp-object+) ; Still 2.
    4672                 (compile-form `',(block-catch-tag block) 'stack nil) ; Tag. Stack depth is 3.
    4673                 ;; If it's not the tag we're looking for...
    4674                 (emit 'if_acmpne RETHROW) ; Stack depth is 1.
    4675                 (emit 'getfield +lisp-return-class+ "result" +lisp-object+)
    4676                 (emit-move-from-stack target) ; Stack depth is 0.
    4677                 (emit 'goto BLOCK-EXIT)
    4678                 (label RETHROW)
    4679                 ;; Not the tag we're looking for.
    4680                 (emit 'athrow)
    4681                 ;; Finally...
    4682                 (push (make-handler :from BEGIN-BLOCK
    4683                                     :to END-BLOCK
    4684                                     :code HANDLER
    4685                                     :catch-type (pool-class +lisp-return-class+))
    4686                       *handlers*)))
    4687             (label BLOCK-EXIT))
    4688           (fix-boxing representation nil)))))
     4645         (BEGIN-BLOCK (gensym))
     4646         (END-BLOCK (gensym))
     4647         (BLOCK-EXIT (block-exit block)))
     4648    (setf (block-target block) target)
     4649    (dformat t "*all-variables* = ~S~%"
     4650             (mapcar #'variable-name *all-variables*))
     4651    (label BEGIN-BLOCK) ; Start of protected range, for non-local returns
     4652    ;; Implicit PROGN.
     4653    (compile-progn-body (cddr (block-form block)) target)
     4654    (label END-BLOCK) ; End of protected range, for non-local returns
     4655    (when (block-non-local-return-p block)
     4656      ;; We need a handler to catch non-local RETURNs.
     4657      (emit 'goto BLOCK-EXIT) ; Jump over handler, when inserting one
     4658      (let ((HANDLER (gensym))
     4659            (RETHROW (gensym)))
     4660        (label HANDLER)
     4661        ;; The Return object is on the runtime stack. Stack depth is 1.
     4662        (emit 'dup) ; Stack depth is 2.
     4663        (emit 'getfield +lisp-return-class+ "tag" +lisp-object+) ; Still 2.
     4664        (compile-form `',(block-exit block) 'stack nil) ; Tag. Stack depth is 3.
     4665        ;; If it's not the tag we're looking for...
     4666        (emit 'if_acmpne RETHROW) ; Stack depth is 1.
     4667        (emit 'getfield +lisp-return-class+ "result" +lisp-object+)
     4668        (emit-move-from-stack target) ; Stack depth is 0.
     4669        (emit 'goto BLOCK-EXIT)
     4670        (label RETHROW)
     4671        ;; Not the tag we're looking for.
     4672        (emit 'athrow)
     4673        ;; Finally...
     4674        (push (make-handler :from BEGIN-BLOCK
     4675                            :to END-BLOCK
     4676                            :code HANDLER
     4677                            :catch-type (pool-class +lisp-return-class+))
     4678              *handlers*)))
     4679    (label BLOCK-EXIT)
     4680    (fix-boxing representation nil)))
    46894681
    46904682(defknown p2-return-from (t t t) t)
     
    47174709           (emit 'new +lisp-return-class+)
    47184710           (emit 'dup)
    4719            (compile-form `',(block-catch-tag block) 'stack nil) ; Tag.
     4711           (compile-form `',(block-exit block) 'stack nil) ; Tag.
    47204712           (emit-clear-values)
    47214713           (compile-form result-form 'stack nil)) ; Result.
     
    47274719             (emit 'new +lisp-return-class+)
    47284720             (emit 'dup)
    4729              (compile-form `',(block-catch-tag block) 'stack nil) ; Tag.
     4721             (compile-form `',(block-exit block) 'stack nil) ; Tag.
    47304722             (aload temp-register))))
    47314723    (emit-invokespecial-init +lisp-return-class+ (lisp-object-arg-types 2))
     
    64146406        ((node-p form)
    64156407         (let ((result t))
     6408;;; ### FIXME
     6409#|
     6410the statements below used to work, maybe ...
     6411We need more thought here.
    64166412           (cond ((and (block-node-p form)
    64176413                       (equal (block-name form) '(LET)))
     
    64376433;;                         (format t "derived-type = ~S~%" derived-type)
    64386434;;                         )
    6439                       (setf result derived-type)))))
     6435                      (setf result derived-type))))) |#
    64406436           result))
    64416437        (t
  • trunk/abcl/src/org/armedbear/lisp/jvm.lisp

    r12134 r12136  
    431431                       (:include control-transferring-node)
    432432                       (:constructor %make-block-node (name)))
    433   ;; Block name or (TAGBODY) or (LET) or (MULTIPLE-VALUE-BIND).
    434   name
     433  name  ;; Block name
    435434  (exit (gensym))
    436435  target
    437   catch-tag
    438   ;; True if there is any RETURN from this block.
    439   return-p
    440436  ;; True if there is a non-local RETURN from this block.
    441437  non-local-return-p)
Note: See TracChangeset for help on using the changeset viewer.