Changeset 12170


Ignore:
Timestamp:
10/04/09 12:37:29 (12 years ago)
Author:
ehuelsmann
Message:

Don't throw Go and Return exceptions as means for non-local transfers
of control, if the extent of the defining lexical context has ended.
Throwing the exceptions anyway causes leaking of exceptions and possibly
unwanted thread termination.

Note: This commit breaks MISC.293A, MISC.293B and MISC.293C.

This however is not a problem with this change, but exposes the fact
that our compiler doesn't conform to the JVM specification of
exception handlers: you can't expect the built-up stack to stay in place
when the exception handler is invoked.

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

Legend:

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

    r12169 r12170  
    4848    final LispObject symbol;
    4949
    50     /** Used only for tags. Refers to the environment
    51      * relating to the tagbody in which the tag was created.
     50    /** Used only for tags and blocks. Refers to the
     51     * defining environment.
    5252     *
    5353     */
    54     LispObject tagbody = null;
     54    Environment env = null;
    5555
    5656    /** The value bound.
     
    8282    }
    8383
    84     Binding(LispObject symbol, LispObject tagbody,
     84    Binding(LispObject symbol, Environment env,
    8585            LispObject value, Binding next)
    8686    {
    8787        this(symbol, value, next);
    88         this.tagbody = tagbody;
     88        this.env = env;
    8989    }
    9090}
  • trunk/abcl/src/org/armedbear/lisp/Do.java

    r12165 r12170  
    199199      {
    200200        thread.lastSpecialBinding = lastSpecialBinding;
     201        ext.inactive = true;
    201202      }
    202203  }
  • trunk/abcl/src/org/armedbear/lisp/Environment.java

    r12168 r12170  
    4040  private Binding blocks;
    4141  private Binding tags;
     42  public boolean inactive; //default value: false == active
    4243
    4344  public Environment() {}
     
    166167  }
    167168
    168   public void addBlock(LispObject tag, LispObject block)
    169   {
    170     blocks = new Binding(tag, block, blocks);
     169  public void addBlock(LispObject symbol, LispObject block)
     170  {
     171    blocks = new Binding(symbol, this, block, blocks);
    171172  }
    172173
     
    183184  }
    184185
    185   public void addTagBinding(LispObject tag, LispObject tagbody, LispObject code)
    186   {
    187     tags = new Binding(tag, tagbody, code, tags);
     186  public Binding getBlockBinding(LispObject block)
     187  {
     188    Binding binding = blocks;
     189    while (binding != null)
     190      {
     191        if (binding.symbol == block)
     192          return binding;
     193        binding = binding.next;
     194      }
     195    return null;
     196  }
     197
     198  public void addTagBinding(LispObject tag, Environment env, LispObject code)
     199  {
     200    tags = new Binding(tag, env, code, tags);
    188201  }
    189202
  • trunk/abcl/src/org/armedbear/lisp/Lisp.java

    r12168 r12170  
    645645  }
    646646
     647  /** Throws a Go exception to cause a non-local transfer
     648   * of control event, after checking that the extent of
     649   * the catching tagbody hasn't ended yet.
     650   *
     651   * This version is used by the compiler.
     652   */
     653  public static final LispObject nonLocalGo(LispObject tagbody,
     654                                            LispObject tag)
     655    throws ConditionThrowable
     656  {
     657    if (tagbody == null)
     658      return error(new ControlError("Unmatched tag "
     659                                    + tag.writeToString() +
     660                                    " for GO outside lexical extent."));
     661
     662    throw new Go(tagbody, tag);
     663  }
     664
     665  /** Throws a Go exception to cause a non-local transfer
     666   * of control event, after checking that the extent of
     667   * the catching tagbody hasn't ended yet.
     668   *
     669   * This version is used by the interpreter.
     670   */
     671  public static final LispObject nonLocalGo(Binding binding,
     672                                            LispObject tag)
     673    throws ConditionThrowable
     674  {
     675    if (binding.env.inactive)
     676      return error(new ControlError("Unmatched tag "
     677                                    + binding.symbol.writeToString() +
     678                                    " for GO outside of lexical extent."));
     679
     680    throw new Go(binding.env, binding.symbol);
     681  }
     682
     683  /** Throws a Return exception to cause a non-local transfer
     684   * of control event, after checking that the extent of
     685   * the catching block hasn't ended yet.
     686   *
     687   * This version is used by the compiler.
     688   */
     689  public static final LispObject nonLocalReturn(LispObject blockId,
     690                                                LispObject blockName,
     691                                                LispObject result)
     692    throws ConditionThrowable
     693  {
     694    if (blockId == null)
     695      return error(new ControlError("Unmatched block "
     696                                    + blockName.writeToString() + " for " +
     697                                    "RETURN-FROM outside lexical extent."));
     698
     699    throw new Return(blockId, result);
     700  }
     701
     702  /** Throws a Return exception to cause a non-local transfer
     703   * of control event, after checking that the extent of
     704   * the catching block hasn't ended yet.
     705   *
     706   * This version is used by the interpreter.
     707   */
     708  public static final LispObject nonLocalReturn(Binding binding,
     709                                                Symbol block,
     710                                                LispObject result)
     711    throws ConditionThrowable
     712  {
     713    if (binding == null)
     714      {
     715        return error(new LispError("No block named " + block.getName() +
     716                                   " is currently visible."));
     717      }
     718
     719    if (binding.env.inactive)
     720      return error(new ControlError("Unmatched block "
     721                                    + binding.symbol.writeToString() +
     722                                    " for RETURN-FROM outside of" +
     723                                    " lexical extent."));
     724
     725    throw new Return(binding.symbol, binding.value, result);
     726  }
     727
    647728  public static final LispObject processTagBody(LispObject body,
    648729                                                LispObject localTags,
     
    677758                        }
    678759                    }
    679                   throw new Go(binding.tagbody, tag);
     760                  throw new Go(binding.env, tag);
    680761                }
    681762              eval(current, env, thread);
  • trunk/abcl/src/org/armedbear/lisp/Primitives.java

    r12168 r12170  
    34973497      {
    34983498        Environment ext = new Environment(env);
    3499         return processTagBody(args, preprocessTagBody(args, ext), ext);
     3499        try {
     3500          return processTagBody(args, preprocessTagBody(args, ext), ext);
     3501        }
     3502        finally {
     3503          ext.inactive = true;
     3504        }
    35003505      }
    35013506    };
     
    35163521                                         args.car().writeToString() +
    35173522                                         " is currently visible."));
    3518         throw new Go(binding.tagbody, args.car());
     3523
     3524        return nonLocalGo(binding, args.car());
    35193525      }
    35203526    };
     
    35503556            throw ret;
    35513557          }
     3558        finally
     3559          {
     3560              ext.inactive = true;
     3561          }
    35523562      }
    35533563    };
     
    35673577            symbol = checkSymbol(args.car());
    35683578
    3569         LispObject block = env.lookupBlock(symbol);
    3570         if (block == null)
    3571           {
    3572             FastStringBuffer sb = new FastStringBuffer("No block named ");
    3573             sb.append(symbol.getName());
    3574             sb.append(" is currently visible.");
    3575             error(new LispError(sb.toString()));
    3576           }
    3577         LispObject result;
    3578         if (length == 2)
    3579           result = eval(args.cadr(), env, LispThread.currentThread());
    3580         else
    3581           result = NIL;
    3582         throw new Return(symbol, block, result);
     3579        return nonLocalReturn(env.getBlockBinding(symbol), symbol,
     3580                              (length == 2) ? eval(args.cadr(), env,
     3581                                                   LispThread.currentThread())
     3582                                            : NIL);
    35833583      }
    35843584    };
  • trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

    r12168 r12170  
    45074507      ; We need a handler to catch non-local GOs.
    45084508      (let* ((HANDLER (gensym))
     4509             (EXTENT-EXIT-HANDLER (gensym))
    45094510             (*register* *register*)
    45104511             (go-register (allocate-register))
     
    45334534                  +lisp-object+)
    45344535            (emit 'if_acmpne NEXT) ;; Jump if not EQ.
    4535             ;; Restore dynamic environment.
    45364536            (emit 'goto (tag-label tag))
    45374537            (label NEXT)))
     
    45394539        (label RETHROW)
    45404540        (aload go-register)
     4541        (emit 'aconst_null) ;; load null value
     4542        (emit-move-to-variable (tagbody-id-variable block))
     4543        (emit 'athrow)
     4544        (label EXTENT-EXIT-HANDLER)
     4545        (emit 'aconst_null) ;; load null value
     4546        (emit-move-to-variable (tagbody-id-variable block))
    45414547        (emit 'athrow)
    45424548        ;; Finally...
     
    45454551                            :code HANDLER
    45464552                            :catch-type (pool-class +lisp-go-class+))
     4553              *handlers*)
     4554        (push (make-handler :from BEGIN-BLOCK
     4555                            :to END-BLOCK
     4556                            :code EXTENT-EXIT-HANDLER
     4557                            :catch-type 0)
    45474558              *handlers*)))
    45484559    (label EXIT)
     4560    (when (tagbody-non-local-go-p block)
     4561      (emit 'aconst_null) ;; load null value
     4562      (emit-move-to-variable (tagbody-id-variable block)))
    45494563    (when must-clear-values
    45504564      (emit-clear-values))
     
    45524566    (when target
    45534567      (emit-push-nil)
    4554       (emit-move-from-stack target))))
     4568      (emit-move-from-stack target)))
     4569  )
    45554570
    45564571(defknown p2-go (t t t) t)
    45574572(defun p2-go (form target representation)
    45584573  ;; FIXME What if we're called with a non-NIL representation?
    4559   (declare (ignore representation))
     4574  (declare (ignore target representation))
    45604575  (let* ((name (cadr form))
    45614576         (tag (find-tag name))
     
    45754590      (return-from p2-go))
    45764591    ;; Non-local GO.
    4577     (emit 'new +lisp-go-class+)
    4578     (emit 'dup)
    4579     (emit-push-variable (tagbody-id-variable (tag-block tag)))
    4580     (compile-form `',(tag-label tag) 'stack nil) ; Tag.
    4581     (emit-invokespecial-init +lisp-go-class+ (lisp-object-arg-types 2))
    4582     (emit 'athrow)
     4592    (emit-push-variable (tagbody-id-variable tag-block))
     4593    (emit 'getstatic *this-class*
     4594          (if *file-compilation*
     4595              (declare-object-as-string (tag-label tag))
     4596              (declare-object (tag-label tag)))
     4597          +lisp-object+) ; Tag.
     4598    (emit-invokestatic +lisp-class+ "nonLocalGo" (lisp-object-arg-types 2)
     4599                       +lisp-object+)
    45834600    ;; Following code will not be reached, but is needed for JVM stack
    45844601    ;; consistency.
    4585     (when target
    4586       (emit-push-nil)
    4587       (emit-move-from-stack target))))
     4602    (emit 'areturn)))
    45884603
    45894604(defknown p2-atom (t t t) t)
     
    46924707      (emit 'goto BLOCK-EXIT) ; Jump over handler, when inserting one
    46934708      (let ((HANDLER (gensym))
     4709            (EXTENT-EXIT-HANDLER (gensym))
    46944710            (THIS-BLOCK (gensym)))
    46954711        (label HANDLER)
     
    47004716        ;; If it's not the block we're looking for...
    47014717        (emit 'if_acmpeq THIS-BLOCK) ; Stack depth is 1.
     4718        (label EXTENT-EXIT-HANDLER)
    47024719        ;; Not the tag we're looking for.
     4720        (emit 'aconst_null) ;; load null value
     4721        (emit-move-to-variable (block-id-variable block))
    47034722        (emit 'athrow)
    47044723        (label THIS-BLOCK)
     
    47104729                            :code HANDLER
    47114730                            :catch-type (pool-class +lisp-return-class+))
     4731              *handlers*)
     4732        (push (make-handler :from BEGIN-BLOCK
     4733                            :to END-BLOCK
     4734                            :code EXTENT-EXIT-HANDLER
     4735                            :catch-type 0)
    47124736              *handlers*)))
    47134737    (label BLOCK-EXIT)
     4738    (when (block-id-variable block)
     4739      (emit 'aconst_null) ;; load null value
     4740      (emit-move-to-variable (block-id-variable block)))
    47144741    (fix-boxing representation nil)))
    47154742
     
    47174744(defun p2-return-from (form target representation)
    47184745  ;; FIXME What if we're called with a non-NIL representation?
    4719   (declare (ignore representation))
     4746  (declare (ignore target representation))
    47204747  (let* ((name (second form))
    47214748         (result-form (third form))
     
    47404767    ;; Non-local RETURN.
    47414768    (aver (block-non-local-return-p block))
    4742     (cond ((node-constant-p result-form)
    4743            (emit 'new +lisp-return-class+)
    4744            (emit 'dup)
    4745            (emit-push-variable (block-id-variable block))
    4746            (emit-clear-values)
    4747            (compile-form result-form 'stack nil)) ; Result.
    4748           (t
    4749            (let* ((*register* *register*)
    4750                   (temp-register (allocate-register)))
    4751              (emit-clear-values)
    4752              (compile-form result-form temp-register nil) ; Result.
    4753              (emit 'new +lisp-return-class+)
    4754              (emit 'dup)
    4755              (emit-push-variable (block-id-variable block))
    4756              (aload temp-register))))
    4757     (emit-invokespecial-init +lisp-return-class+ (lisp-object-arg-types 2))
    4758     (emit 'athrow)
     4769    (emit-push-variable (block-id-variable block))
     4770    (emit 'getstatic *this-class*
     4771          (if *file-compilation*
     4772              (declare-object-as-string (block-name block))
     4773              (declare-object (block-name block)))
     4774          +lisp-object+)
     4775    (emit-clear-values)
     4776    (compile-form result-form 'stack nil)
     4777    (emit-invokestatic +lisp-class+ "nonLocalReturn" (lisp-object-arg-types 3)
     4778                       +lisp-object+)
    47594779    ;; Following code will not be reached, but is needed for JVM stack
    47604780    ;; consistency.
    4761     (when target
    4762       (emit-push-nil)
    4763       (emit-move-from-stack target))))
     4781    (emit 'areturn)))
    47644782
    47654783(defun emit-car/cdr (arg target representation field)
  • trunk/abcl/src/org/armedbear/lisp/dolist.java

    r12166 r12170  
    5959
    6060    LispObject blockId = new LispObject();
     61    final Environment ext = new Environment(env);
    6162    try
    6263      {
    63         final Environment ext = new Environment(env);
    6464        // Implicit block.
    6565        ext.addBlock(NIL, blockId);
     
    123123      {
    124124        thread.lastSpecialBinding = lastSpecialBinding;
     125        ext.inactive = true;
    125126      }
    126127  }
  • trunk/abcl/src/org/armedbear/lisp/dotimes.java

    r12167 r12170  
    5858
    5959    LispObject blockId = new LispObject();
     60    final Environment ext = new Environment(env);
    6061    try
    6162      {
    62         Environment ext = new Environment(env);
    6363        ext.addBlock(NIL, blockId);
    6464
     
    149149      {
    150150        thread.lastSpecialBinding = lastSpecialBinding;
     151        ext.inactive = true;
    151152      }
    152153  }
Note: See TracChangeset for help on using the changeset viewer.