From 079e081ab3f1a1bef175d8185c80108d16452c74 Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Wed, 10 Apr 2019 00:36:05 -0700 Subject: exceptions: allow description field in catch frames. * eval.c (op_catch): Extra argument in sys:catch syntax specifies an expression that evaluates to a description field. (expand_catch): Expand the desc expression in sys:catch syntax. * parser.c (read_file_common): Increase acceptance of compiled files from versions 1-4 to 1-5, since we are now marking compiled files with version 5.0 rather than 4.0. * share/txr/stdlib/asm.tl (op-catch catch): Support new argument in the opcode syntax. Turns out we have a spare field in the instruction format which was previously set to zero We can use that for the description. Thus, the instruction set and VM remain backward compatible: old code works. * share/txr/stdlib/compiler.tl (compiler comp-catch): Handle the desc argument introduced into the sys:catch form. We must compile it as an expression, then inject the code into the instruction template, and reference the output register of that code block in the catch instruction. (%tlo-ver%): Bump up the compiled file version to 5.0. * share/txr/stdlib/except.tl (usr:catch, catch*): Add desc argument to generated sys:catch form, specifying it as nil. * unwind.c (desc_s): New symbol variable. (uw_find_frames_impl): Set the desc member of the extracted catch structure from the corresponding field in the catch frame. (uw_late_init): Initialize desc_s with interned symbol. Add desc slot to catch-frame type. * unwind.h (struct uw_catch): New member, desc. (uw_catch_begin_w_desc): New macro. * vm.c (vm_catch): Extract the desc field from the catch instruction, and use uw_catch_begin_w_desc to propagate that to the catch frame. --- eval.c | 18 ++++++++++++------ parser.c | 2 +- share/txr/stdlib/asm.tl | 12 +++++++----- share/txr/stdlib/compiler.tl | 9 ++++++--- share/txr/stdlib/except.tl | 4 ++-- unwind.c | 12 ++++++++---- unwind.h | 11 +++++++++++ vm.c | 3 ++- 8 files changed, 49 insertions(+), 22 deletions(-) diff --git a/eval.c b/eval.c index b9db0d8e..f57b084f 100644 --- a/eval.c +++ b/eval.c @@ -2595,17 +2595,19 @@ static val op_dwim(val form, val env) static val op_catch(val form, val env) { - val catch_syms = second(form); - val try_form = third(form); + val args = cdr(form); + val catch_syms = pop(&args); + val try_form = pop(&args); + val desc = pop(&args); + val catches = args; val result = nil; - uw_catch_begin (catch_syms, exsym, exvals); + uw_catch_begin_w_desc (catch_syms, exsym, exvals, desc); result = eval(try_form, env, try_form); uw_catch(exsym, exvals) { args_decl(args, ARGS_MIN); - val catches = rest(rest(rest(form))); val iter; args_add(args, exsym); @@ -4437,19 +4439,23 @@ static val expand_catch(val form, val menv) val sym = pop(&args); val catch_syms = pop(&args); val try_form = pop(&args); + val desc = pop(&args); val catch_clauses = args; val try_form_ex = expand(try_form, menv); + val desc_ex = expand(desc, menv); val catch_clauses_ex = rlcp(mapcar(curry_12_1(func_n2(expand_catch_clause), menv), catch_clauses), catch_clauses); - if (try_form_ex == try_form && catch_clauses_ex == catch_clauses) + if (try_form_ex == try_form && desc_ex == desc && + catch_clauses_ex == catch_clauses) return form; return rlcp(cons(sym, cons(catch_syms, - cons(try_form_ex, catch_clauses_ex))), form); + cons(try_form_ex, + cons(desc_ex, catch_clauses_ex)))), form); } static val expand_list_of_form_lists(val lofl, val menv, val ss_hash) diff --git a/parser.c b/parser.c index b7713f64..4ac341b7 100644 --- a/parser.c +++ b/parser.c @@ -645,7 +645,7 @@ static val read_file_common(val self, val stream, val error_stream, val compiled if (compiled && first) { val major = car(form); - if (lt(major, one) || gt(major, four)) + if (lt(major, one) || gt(major, num_fast(5))) uw_throwf(error_s, lit("cannot load ~s: version number mismatch"), stream, nao); diff --git a/share/txr/stdlib/asm.tl b/share/txr/stdlib/asm.tl index 75d84471..b270c4bf 100644 --- a/share/txr/stdlib/asm.tl +++ b/share/txr/stdlib/asm.tl @@ -653,11 +653,12 @@ (defopcode op-catch catch auto (:method asm (me asm syntax) - me.(chk-arg-count 4 syntax) - (tree-bind (sym args catch-syms dst) asm.(parse-args me syntax '(d d r l)) + me.(chk-arg-count 5 syntax) + (tree-bind (sym args catch-syms desc dst) + asm.(parse-args me syntax '(d d r r l)) asm.(put-insn me.code (ash dst -16) (logtrunc dst 16)) asm.(put-pair sym args) - asm.(put-pair 0 catch-syms))) + asm.(put-pair desc catch-syms))) (:method backpatch (me asm at dst) asm.(put-insn me.code (ash dst -16) (logtrunc dst 16))) @@ -665,9 +666,10 @@ (:method dis (me asm high16 low16) (let ((dst (logior (ash high16 16) low16))) (tree-bind (sym args) asm.(get-pair) - (let ((catch-syms (cadr asm.(get-pair)))) + (tree-bind (desc catch-syms) asm.(get-pair) ^(,me.symbol ,(operand-to-sym sym) ,(operand-to-sym args) - ,(operand-to-sym catch-syms) ,dst)))))) + ,(operand-to-sym catch-syms) + ,(operand-to-sym desc) ,dst)))))) (defopcode op-handle handle auto (:method asm (me asm syntax) diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl index 3d906866..eea91b62 100644 --- a/share/txr/stdlib/compiler.tl +++ b/share/txr/stdlib/compiler.tl @@ -658,12 +658,13 @@ (uni ffrag.ffuns bfrag.ffuns)))))) (defmeth compiler comp-catch (me oreg env form) - (mac-param-bind form (op symbols try-expr . clauses) form + (mac-param-bind form (op symbols try-expr desc-expr . clauses) form (with-gensyms (ex-sym-var ex-args-var) (let* ((nenv (new env up env co me)) (esvb (cdar nenv.(extend-var ex-sym-var))) (eavb (cdar nenv.(extend-var ex-args-var))) (tfrag me.(compile oreg env try-expr)) + (dfrag me.(compile oreg env desc-expr)) (lhand (gensym "l")) (lhend (gensym "l")) (treg me.(alloc-treg)) @@ -691,7 +692,9 @@ me.(free-treg treg) (new (frag tfrag.oreg ^((frame ,nenv.lev ,nenv.v-cntr) - (catch ,esvb.loc ,eavb.loc ,me.(get-dreg symbols) ,lhand) + ,*dfrag.code + (catch ,esvb.loc ,eavb.loc + ,me.(get-dreg symbols) ,dfrag.oreg ,lhand) ,*tfrag.code (jmp ,lhend) ,lhand @@ -1580,7 +1583,7 @@ (defvarl %big-endian% (equal (ffi-put 1 (ffi uint32)) #b'00000001')) -(defvarl %tlo-ver% ^(4 0 ,%big-endian%)) +(defvarl %tlo-ver% ^(5 0 ,%big-endian%)) (defvarl %package-manip% '(make-package delete-package use-package unuse-package diff --git a/share/txr/stdlib/except.tl b/share/txr/stdlib/except.tl index 83506232..a2cc684c 100644 --- a/share/txr/stdlib/except.tl +++ b/share/txr/stdlib/except.tl @@ -35,11 +35,11 @@ e nil form) ^(,type (,(gensym) ,*args-ex) ,*body-ex))) catch-clauses))) - ^(sys:catch ,catch-syms ,try-form ,*sys-catch-clauses))) + ^(sys:catch ,catch-syms ,try-form nil ,*sys-catch-clauses))) (defmacro catch* (try-form . catch-clauses) (let ((catch-syms [mapcar car catch-clauses])) - ^(sys:catch ,catch-syms ,try-form ,*catch-clauses))) + ^(sys:catch ,catch-syms ,try-form nil ,*catch-clauses))) (defun sys:expand-handle (form try-form handle-clauses) (let* ((oper (car form)) diff --git a/unwind.c b/unwind.c index f8887c80..f3a4df24 100644 --- a/unwind.c +++ b/unwind.c @@ -57,7 +57,8 @@ static uw_frame_t *uw_exit_point; static uw_frame_t toplevel_env; static uw_frame_t unhandled_ex; -static val unhandled_hook_s, types_s, jump_s, sys_cont_s, sys_cont_poison_s; +static val unhandled_hook_s, types_s, jump_s, desc_s; +static val sys_cont_s, sys_cont_poison_s; static val sys_cont_free_s, sys_capture_cont_s; static val frame_type, catch_frame_type, handle_frame_type; @@ -363,10 +364,12 @@ static val uw_find_frames_impl(val extype, val frtype, val just_one) args_decl(args, ARGS_MIN); val fr = make_struct(frtype, nil, args); slotset(fr, types_s, ex->ca.matches); - if (et == UW_CATCH) + if (et == UW_CATCH) { + slotset(fr, desc_s, ex->ca.desc); slotset(fr, jump_s, cptr(coerce(mem_t *, ex))); - else + } else { slotset(fr, fun_s, ex->ha.fun); + } if (just_one) return fr; ptail = list_collect(ptail, fr); @@ -1054,6 +1057,7 @@ void uw_late_init(void) &deferred_warnings, &tentative_defs, convert(val *, 0)); types_s = intern(lit("types"), user_package); jump_s = intern(lit("jump"), user_package); + desc_s = intern(lit("desc"), user_package); sys_cont_s = intern(lit("cont"), system_package); sys_cont_poison_s = intern(lit("cont-poison"), system_package); sys_cont_free_s = intern(lit("cont-free"), system_package); @@ -1062,7 +1066,7 @@ void uw_late_init(void) catch_frame_type = make_struct_type(intern(lit("catch-frame"), user_package), frame_type, nil, - list(types_s, jump_s, nao), + list(types_s, desc_s, jump_s, nao), nil, nil, nil, nil); handle_frame_type = make_struct_type(intern(lit("handle-frame"), user_package), diff --git a/unwind.h b/unwind.h index 074b79fe..0dfeea17 100644 --- a/unwind.h +++ b/unwind.h @@ -61,6 +61,7 @@ struct uw_catch { int visible; val sym; val args; + val desc; uw_frame_t *cont; extended_jmp_buf jb; }; @@ -203,6 +204,16 @@ noreturn val type_mismatch(val, ...); switch (extended_setjmp(uw_catch.ca.jb)) { \ case 0: +#define uw_catch_begin_w_desc(MATCHES, SYMVAR, \ + EXCVAR, DESC) \ + do { \ + obj_t *SYMVAR = nil; \ + obj_t *EXCVAR = nil; \ + uw_frame_t uw_catch; \ + uw_push_catch(&uw_catch, MATCHES); \ + uw_catch.ca.desc = (DESC); \ + switch (extended_setjmp(uw_catch.ca.jb)) { \ + case 0: #define uw_catch(SYMVAR, EXCVAR) \ goto uw_unwind_label; \ break; \ diff --git a/vm.c b/vm.c index 26d52edd..90b99210 100644 --- a/vm.c +++ b/vm.c @@ -859,9 +859,10 @@ NOINLINE static void vm_catch(struct vm *vm, vm_word_t insn) unsigned sym_reg = vm_arg_operand_hi(arg1); unsigned args_reg = vm_arg_operand_lo(arg1); val catch_syms = vm_get(vm->dspl, vm_arg_operand_lo(arg2)); + val desc = vm_get(vm->dspl, vm_arg_operand_hi(arg2)); int saved_lev = vm->lev; - uw_catch_begin (catch_syms, exsym, exvals); + uw_catch_begin_w_desc (catch_syms, exsym, exvals, desc); vm_execute(vm); -- cgit v1.2.3