Changeset 12164


Ignore:
Timestamp:
09/28/09 19:55:08 (12 years ago)
Author:
ehuelsmann
Message:

Correctly identify lexical scoping in case of recursive BLOCKs in compiled code.

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

Legend:

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

    r12154 r12164  
    289289    (setf (cddr form) (p1-body (cddr form)))
    290290    (setf (block-form block) form)
     291    (when (block-non-local-return-p block)
     292      ;; Add a closure variable for RETURN-FROM to use
     293      (push (setf (block-id-variable block)
     294                  (make-variable :name (gensym)
     295                                 :block block
     296                                 :used-non-locally-p t))
     297            *all-variables*))
    291298    block))
    292299
  • trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

    r12163 r12164  
    39133913      (unused-variable variable))))
    39143914
     3915(declaim (ftype (function (t) t) emit-new-closure-binding))
     3916(defun emit-new-closure-binding (variable)
     3917  ""
     3918  (emit 'new +closure-binding-class+)            ;; value c-b
     3919  (emit 'dup_x1)                                 ;; c-b value c-b
     3920  (emit 'swap)                                   ;; c-b c-b value
     3921  (emit-invokespecial-init +closure-binding-class+
     3922                           (list +lisp-object+)) ;; c-b
     3923  (aload (compiland-closure-register *current-compiland*))
     3924                                                 ;; c-b array
     3925  (emit 'swap)                                   ;; array c-b
     3926  (emit-push-constant-int (variable-closure-index variable))
     3927                                                 ;; array c-b int
     3928  (emit 'swap) ; array index value
     3929  (emit 'aastore))
     3930
    39153931;; Generates code to bind variable to value at top of runtime stack.
    39163932(declaim (ftype (function (t) t) compile-binding))
     
    39263942                             (list +lisp-symbol+ +lisp-object+) nil))
    39273943        ((variable-closure-index variable)              ;; stack:
    3928          (emit 'new +closure-binding-class+)            ;; value c-b
    3929          (emit 'dup_x1)                                 ;; c-b value c-b
    3930          (emit 'swap)                                   ;; c-b c-b value
    3931          (emit-invokespecial-init +closure-binding-class+
    3932                                   (list +lisp-object+)) ;; c-b
    3933          (aload (compiland-closure-register *current-compiland*))
    3934                                                          ;; c-b array
    3935          (emit 'swap)                                    ;; array c-b
    3936          (emit-push-constant-int (variable-closure-index variable))
    3937                                                          ;; array c-b int
    3938          (emit 'swap) ; array index value
    3939          (emit 'aastore))
     3944         (emit-new-closure-binding variable))
    39403945        (t
    39413946         (sys::%format t "compile-binding~%")
     
    46524657    (aver (block-node-p block)))
    46534658  (let* ((*blocks* (cons block *blocks*))
     4659         (*register* *register*)
    46544660         (BEGIN-BLOCK (gensym))
    46554661         (END-BLOCK (gensym))
    46564662         (BLOCK-EXIT (block-exit block)))
    46574663    (setf (block-target block) target)
     4664    (when (block-id-variable block)
     4665      ;; we have a block variable; that should be a closure variable
     4666      (assert (not (null (variable-closure-index (block-id-variable block)))))
     4667      (emit 'new +lisp-object-class+)
     4668      (emit 'dup)
     4669      (emit-invokespecial-init +lisp-object-class+ '())
     4670      (emit-new-closure-binding (block-id-variable block)))
    46584671    (dformat t "*all-variables* = ~S~%"
    46594672             (mapcar #'variable-name *all-variables*))
     
    46664679      (emit 'goto BLOCK-EXIT) ; Jump over handler, when inserting one
    46674680      (let ((HANDLER (gensym))
    4668             (RETHROW (gensym)))
     4681            (THIS-BLOCK (gensym)))
    46694682        (label HANDLER)
    46704683        ;; The Return object is on the runtime stack. Stack depth is 1.
    46714684        (emit 'dup) ; Stack depth is 2.
    46724685        (emit 'getfield +lisp-return-class+ "tag" +lisp-object+) ; Still 2.
    4673         (compile-form `',(block-exit block) 'stack nil) ; Tag. Stack depth is 3.
    4674         ;; If it's not the tag we're looking for...
    4675         (emit 'if_acmpne RETHROW) ; Stack depth is 1.
     4686        (emit-push-variable (block-id-variable block))
     4687        ;; If it's not the block we're looking for...
     4688        (emit 'if_acmpeq THIS-BLOCK) ; Stack depth is 1.
     4689        ;; Not the tag we're looking for.
     4690        (emit 'athrow)
     4691        (label THIS-BLOCK)
    46764692        (emit 'getfield +lisp-return-class+ "result" +lisp-object+)
    46774693        (emit-move-from-stack target) ; Stack depth is 0.
    4678         (emit 'goto BLOCK-EXIT)
    4679         (label RETHROW)
    4680         ;; Not the tag we're looking for.
    4681         (emit 'athrow)
    46824694        ;; Finally...
    46834695        (push (make-handler :from BEGIN-BLOCK
     
    47184730           (emit 'new +lisp-return-class+)
    47194731           (emit 'dup)
    4720            (compile-form `',(block-exit block) 'stack nil) ; Tag.
     4732           (emit-push-variable (block-id-variable block))
    47214733           (emit-clear-values)
    47224734           (compile-form result-form 'stack nil)) ; Result.
     
    47284740             (emit 'new +lisp-return-class+)
    47294741             (emit 'dup)
    4730              (compile-form `',(block-exit block) 'stack nil) ; Tag.
     4742             (emit-push-variable (block-id-variable block))
    47314743             (aload temp-register))))
    47324744    (emit-invokespecial-init +lisp-return-class+ (lisp-object-arg-types 2))
  • trunk/abcl/src/org/armedbear/lisp/jvm.lisp

    r12154 r12164  
    410410  target
    411411  ;; True if there is a non-local RETURN from this block.
    412   non-local-return-p)
     412  non-local-return-p
     413  ;; Contains a variable whose value uniquely identifies the
     414  ;; lexical scope from this block, to be used by RETURN-FROM
     415  id-variable)
    413416(defknown make-block-node (t) t)
    414417(defun make-block-node (name)
Note: See TracChangeset for help on using the changeset viewer.