From 1b72dad74f2e193e8da8de58ef8c46341897269a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 22 Jul 2019 11:08:53 +0200 Subject: [PATCH] catch works --- lisp/emacs-lisp/comp.el | 60 ++++++++++++++++++++++------------------- src/comp.c | 11 +++++++- test/src/comp-tests.el | 23 ++++++++-------- 3 files changed, 53 insertions(+), 41 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 35a59dbe607..005a7d0eb08 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -407,6 +407,24 @@ If NEGATED non nil negate the test condition." (puthash n name hash) name)))) +(defun comp-emit-handler (guarded-label handler-type) + "Emit a non local exit handler for GUARDED-LABEL of type HANDLER-TYPE." + (let ((blocks (comp-func-blocks comp-func)) + (guarded-bb (comp-new-block-sym))) + (puthash guarded-bb + (make-comp-block :sp (comp-sp)) + blocks) + (let ((handler-bb (comp-lap-to-limple-bb guarded-label))) + (comp-emit (list 'push-handler (comp-slot-next) + handler-type + handler-bb + guarded-bb)) + (puthash handler-bb + (make-comp-block :sp (1+ (comp-sp))) + blocks) + (comp-mark-block-closed) + (comp-emit-block guarded-bb)))) + (defmacro comp-op-case (&rest cases) "Expand CASES into the corresponding pcase. This is responsible for generating the proper stack adjustment when known and @@ -450,12 +468,12 @@ the annotation emission." op-name)))) (_ (error "Unexpected LAP op %s" (symbol-name op)))))) -(defun comp-limplify-lap-inst (inst) - "Limplify LAP instruction INST pushng it in the proper basic block." - (let ((op (car inst)) - (arg (if (consp (cdr inst)) - (cadr inst) - (cdr inst)))) +(defun comp-limplify-lap-inst (insn) + "Limplify LAP instruction INSN pushng it in the proper basic block." + (let ((op (car insn)) + (arg (if (consp (cdr insn)) + (cadr insn) + (cdr insn)))) (comp-op-case (TAG (comp-emit-block (comp-lap-to-limple-bb arg))) @@ -487,23 +505,9 @@ the annotation emission." (byte-pophandler (comp-emit '(pop-handler))) (byte-pushconditioncase - (let ((blocks (comp-func-blocks comp-func)) - (guarded-bb (comp-new-block-sym))) - (puthash guarded-bb - (make-comp-block :sp (comp-sp)) - blocks) - (let ((handler-bb (comp-lap-to-limple-bb (cl-third inst))) - (handler-type (cdr (last inst)))) - (comp-emit (list 'push-handler (comp-slot-next) - handler-type - handler-bb - guarded-bb)) - (puthash handler-bb - (make-comp-block :sp (1+ (comp-sp))) - blocks) - (comp-mark-block-closed) - (comp-emit-block guarded-bb)))) - (byte-pushcatch) + (comp-emit-handler (cl-third insn) 'condition-case)) + (byte-pushcatch + (comp-emit-handler (cl-third insn) 'catcher)) (byte-nth auto) (byte-symbolp auto) (byte-consp auto) @@ -584,15 +588,15 @@ the annotation emission." (byte-end-of-line auto) (byte-constant2) (byte-goto - (comp-emit-jump (comp-lap-to-limple-bb (cl-third inst)))) + (comp-emit-jump (comp-lap-to-limple-bb (cl-third insn)))) (byte-goto-if-nil - (comp-emit-cond-jump 0 (cl-third inst) nil)) + (comp-emit-cond-jump 0 (cl-third insn) nil)) (byte-goto-if-not-nil - (comp-emit-cond-jump 0 (cl-third inst) t)) + (comp-emit-cond-jump 0 (cl-third insn) t)) (byte-goto-if-nil-else-pop - (comp-emit-cond-jump 1 (cl-third inst) nil)) + (comp-emit-cond-jump 1 (cl-third insn) nil)) (byte-goto-if-not-nil-else-pop - (comp-emit-cond-jump 1 (cl-third inst) t)) + (comp-emit-cond-jump 1 (cl-third insn) t)) (byte-return (comp-emit (list 'return (comp-slot-next))) (comp-mark-block-closed)) diff --git a/src/comp.c b/src/comp.c index 93d0f81dbc8..6436a5db712 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1138,10 +1138,17 @@ emit_limple_insn (Lisp_Object insn) { EMACS_UINT clobber_slot = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); gcc_jit_rvalue *handler = emit_mvar_val (arg0); + int h_num; + if (EQ (SECOND (args), Qcatcher)) + h_num = CATCHER; + else if (EQ (SECOND (args), Qcondition_case)) + h_num = CONDITION_CASE; + else + eassert (false); gcc_jit_rvalue *handler_type = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, - XFIXNUM (SECOND (args))); + h_num); gcc_jit_block *handler_bb = retrive_block (THIRD (args)); gcc_jit_block *guarded_bb = retrive_block (FORTH (args)); emit_limple_push_handler (handler, handler_type, handler_bb, guarded_bb, @@ -2224,6 +2231,8 @@ syms_of_comp (void) DEFSYM (Qcond_jump, "cond-jump"); DEFSYM (Qpush_handler, "push-handler"); DEFSYM (Qpop_handler, "pop-handler"); + DEFSYM (Qcondition_case, "condition-case"); + DEFSYM (Qcatcher, "catcher"); defsubr (&Scomp_init_ctxt); defsubr (&Scomp_release_ctxt); diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 871dede23a6..ed3a9b2f9d0 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -448,26 +448,25 @@ (error-message-string err) " catched")))) - ;; (defun comp-tests-catch-f (f) - ;; (catch 'foo - ;; (funcall f))) + (defun comp-tests-catch-f (f) + (catch 'foo + (funcall f))) - ;; (defun comp-tests-throw-f (x) - ;; (throw 'foo x)) + (defun comp-tests-throw-f (x) + (throw 'foo x)) (native-compile #'comp-tests-condition-case-0-f) (native-compile #'comp-tests-condition-case-1-f) - ;; (native-compile #'comp-tests-catch-f) - ;; (native-compile #'comp-tests-throw-f) + (native-compile #'comp-tests-catch-f) + (native-compile #'comp-tests-throw-f) (should (string= (comp-tests-condition-case-0-f) "arith-error Arithmetic error catched")) (should (string= (comp-tests-condition-case-1-f) - "error foo catched"))) - ;; (should (= (comp-tests-catch-f (lambda () (throw 'foo 3))) 3)) - ;; (should (= (catch 'foo - ;; (comp-tests-throw-f 3)))) - ) + "error foo catched")) + (should (= (comp-tests-catch-f (lambda () (throw 'foo 3))) 3)) + (should (= (catch 'foo + (comp-tests-throw-f 3)))))) (ert-deftest comp-tests-gc () "Try to do some longer computation to let the gc kick in." -- 2.39.5