Changeset 13120


Ignore:
Timestamp:
01/03/11 12:09:37 (11 years ago)
Author:
ehuelsmann
Message:

Improve parent/child block relationship tracking;
Improve block-finding;
Untabify (sorry to mix that!).

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/jvm.lisp

    r13115 r13120  
    372372  (references-allowed-p t) ;;whether a reference to the function CAN be captured
    373373  (references-needed-p nil) ;;whether a reference to the function NEEDS to be
    374           ;;captured, because the function name is used in a
     374                            ;;captured, because the function name is used in a
    375375                            ;;(function ...) form. Obviously implies
    376376                            ;;references-allowed-p.
     
    387387(defvar *using-arg-array* nil)
    388388(defvar *hairy-arglist-p* nil)
     389
     390
     391(defvar *block* nil
     392  "The innermost block applicable to the current lexical environment.")
     393(defvar *blocks* ()
     394  "The list of blocks in effect in the current lexical environment.
     395
     396The top node does not need to be equal to the value of `*block*`. E.g.
     397when processing the bindings of a LET form, `*block*` is bound to the node
     398of that LET, while the block is not considered 'in effect': that only happens
     399until the body is being processed.")
    389400
    390401(defstruct node
     
    416427(defstruct (tagbody-node (:conc-name tagbody-)
    417428                         (:include control-transferring-node)
    418       (:constructor %make-tagbody-node ()))
     429                        (:constructor %make-tagbody-node ()))
    419430  ;; True if a tag in this tagbody is the target of a non-local GO.
    420431  non-local-go-p
     
    428439  (let ((block (%make-tagbody-node)))
    429440    (push block (compiland-blocks *current-compiland*))
    430     (add-node-child (car *blocks*) block)
     441    (add-node-child *block* block)
    431442    block))
    432443
    433444(defstruct (catch-node (:conc-name catch-)
    434445                       (:include control-transferring-node)
    435            (:constructor %make-catch-node ()))
     446                       (:constructor %make-catch-node ()))
    436447  ;; The catch tag-form is evaluated, meaning we
    437448  ;; have no predefined value to store here
     
    441452  (let ((block (%make-catch-node)))
    442453    (push block (compiland-blocks *current-compiland*))
    443     (add-node-child (car *blocks*) block)
     454    (add-node-child *block* block)
    444455    block))
    445456
     
    459470  (let ((block (%make-block-node name)))
    460471    (push block (compiland-blocks *current-compiland*))
    461     (add-node-child (car *blocks*) block)
     472    (add-node-child *block* block)
    462473    block))
    463474
     
    478489(defstruct (let/let*-node (:conc-name let-)
    479490                          (:include binding-node)
    480         (:constructor %make-let/let*-node ())))
     491                          (:constructor %make-let/let*-node ())))
    481492(defknown make-let/let*-node () t)
    482493(defun make-let/let*-node ()
    483494  (let ((block (%make-let/let*-node)))
    484495    (push block (compiland-blocks *current-compiland*))
    485     (add-node-child (car *blocks*) block)
     496    (add-node-child *block* block)
    486497    block))
    487498
    488499(defstruct (flet-node (:conc-name flet-)
    489500                      (:include binding-node)
    490           (:constructor %make-flet-node ())))
     501                      (:constructor %make-flet-node ())))
    491502(defknown make-flet-node () t)
    492503(defun make-flet-node ()
    493504  (let ((block (%make-flet-node)))
    494505    (push block (compiland-blocks *current-compiland*))
    495     (add-node-child (car *blocks*) block)
     506    (add-node-child *block* block)
    496507    block))
    497508
    498509(defstruct (labels-node (:conc-name labels-)
    499510                        (:include binding-node)
    500       (:constructor %make-labels-node ())))
     511                        (:constructor %make-labels-node ())))
    501512(defknown make-labels-node () t)
    502513(defun make-labels-node ()
    503514  (let ((block (%make-labels-node)))
    504515    (push block (compiland-blocks *current-compiland*))
    505     (add-node-child (car *blocks*) block)
     516    (add-node-child *block* block)
    506517    block))
    507518
    508519(defstruct (m-v-b-node (:conc-name m-v-b-)
    509520                       (:include binding-node)
    510            (:constructor %make-m-v-b-node ())))
     521                       (:constructor %make-m-v-b-node ())))
    511522(defknown make-m-v-b-node () t)
    512523(defun make-m-v-b-node ()
    513524  (let ((block (%make-m-v-b-node)))
    514525    (push block (compiland-blocks *current-compiland*))
    515     (add-node-child (car *blocks*) block)
     526    (add-node-child *block* block)
    516527    block))
    517528
    518529(defstruct (progv-node (:conc-name progv-)
    519530                       (:include binding-node)
    520            (:constructor %make-progv-node ())))
     531                       (:constructor %make-progv-node ())))
    521532(defknown make-progv-node () t)
    522533(defun make-progv-node ()
     
    527538(defstruct (locally-node (:conc-name locally-)
    528539                         (:include binding-node)
    529       (:constructor %make-locally-node ())))
     540                        (:constructor %make-locally-node ())))
    530541(defknown make-locally-node () t)
    531542(defun make-locally-node ()
    532543  (let ((block (%make-locally-node)))
    533544    (push block (compiland-blocks *current-compiland*))
    534     (add-node-child (car *blocks*) block)
     545    (add-node-child *block* block)
    535546    block))
    536547
     
    538549
    539550(defstruct (protected-node (:include node)
    540          (:constructor %make-protected-node ())))
     551                           (:constructor %make-protected-node ())))
    541552(defknown make-protected-node () t)
    542553(defun make-protected-node ()
    543554  (let ((block (%make-protected-node)))
    544555    (push block (compiland-blocks *current-compiland*))
    545     (add-node-child (car *blocks*) block)
     556    (add-node-child *block* block)
    546557    block))
    547558
    548559(defstruct (unwind-protect-node (:conc-name unwind-protect-)
    549560                                (:include protected-node)
    550         (:constructor %make-unwind-protect-node ())))
     561                                (:constructor %make-unwind-protect-node ())))
    551562(defknown make-unwind-protect-node () t)
    552563(defun make-unwind-protect-node ()
    553564  (let ((block (%make-unwind-protect-node)))
    554565    (push block (compiland-blocks *current-compiland*))
    555     (add-node-child (car *blocks*) block)
     566    (add-node-child *block* block)
    556567    block))
    557568
    558569(defstruct (synchronized-node (:conc-name synchronized-)
    559570                              (:include protected-node)
    560             (:constructor %make-synchronized-node ())))
     571                              (:constructor %make-synchronized-node ())))
    561572(defknown make-synchronized-node () t)
    562573(defun make-synchronized-node ()
    563574  (let ((block (%make-synchronized-node)))
    564575    (push block (compiland-blocks *current-compiland*))
    565     (add-node-child (car *blocks*) block)
    566     block))
    567 
    568 
    569 (defvar *blocks* ())
     576    (add-node-child *block* block)
     577    block))
    570578
    571579(defun find-block (name)
     
    575583      (return block))))
    576584
    577 (defun some-nested-block (block predicate)
    578   "Applies `predicate` recursively to the children of `block`,
    579 until predicate returns non-NIL, returning that value."
    580   (some #'(lambda (b)
    581       (or (funcall predicate b)
    582     (some-nested-block b predicate)))
    583   (node-children block)))
     585(defun %find-enclosed-blocks (form)
     586  "Helper function for `find-enclosed-blocks`, implementing the actual
     587algorithm specified there."
     588  (cond
     589   ((node-p form) (list form))
     590   ((atom form) nil)
     591   (t
     592    ;; We can't use MAPCAN or DOLIST here: they'll choke on dotted lists
     593    (do* ((tail form (cdr tail))
     594          blocks)
     595         ((null tail) blocks)
     596      (setf blocks
     597            (nconc (%find-enclosed-blocks (if (consp tail)
     598                                              (car tail) tail))
     599                   blocks))
     600      (when (not (listp tail))
     601        (return blocks))))))
     602
     603(defun find-enclosed-blocks (form)
     604  "Returns the immediate enclosed blocks by searching the form's subforms.
     605
     606More deeply nested blocks can be reached through the `node-children`
     607field of the immediate enclosed blocks."
     608  (when *blocks*
     609    ;; when the innermost enclosing block doesn't have node-children,
     610    ;;  there's really nothing to search for.
     611    (when (null (node-children (car *blocks*)))
     612      (return-from find-enclosed-blocks)))
     613
     614  (%find-enclosed-blocks form))
     615   
     616
     617(defun some-nested-block (predicate blocks)
     618  "Applies `predicate` recursively to the `blocks` and its children,
     619until predicate returns non-NIL, returning that value.
     620
     621`blocks` may be a single block or a list of blocks."
     622  (when blocks
     623    (some #'(lambda (b)
     624              (or (funcall predicate b)
     625                  (some-nested-block predicate (node-children b))))
     626          (if (listp blocks)
     627              blocks
     628            (list blocks)))))
    584629
    585630(defknown node-constant-p (t) boolean)
     
    605650      (catch-node-p object)
    606651      (synchronized-node-p object)))
     652
     653(defun block-opstack-unsafe-p (block)
     654  (or (when (tagbody-node-p block) (tagbody-non-local-go-p block))
     655      (when (block-node-p block) (block-non-local-return-p block))
     656      (catch-node-p block)))
    607657
    608658(defknown block-creates-runtime-bindings-p (t) boolean)
Note: See TracChangeset for help on using the changeset viewer.