From 8b22849a5cef3e81e8b81cf7f32c186471607e06 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 21 Jul 2019 22:02:17 +0200 Subject: [PATCH] pushconditioncase working --- lisp/emacs-lisp/comp.el | 22 ++++---- src/comp.c | 121 +++++++++++++++++++++++++++++++++++----- test/src/comp-tests.el | 102 ++++++++++++++++----------------- 3 files changed, 171 insertions(+), 74 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 558bed3187f..35a59dbe607 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -488,21 +488,21 @@ the annotation emission." (comp-emit '(pop-handler))) (byte-pushconditioncase (let ((blocks (comp-func-blocks comp-func)) - (fall-bb (comp-new-block-sym))) ;; Fall through block - (puthash fall-bb + (guarded-bb (comp-new-block-sym))) + (puthash guarded-bb (make-comp-block :sp (comp-sp)) blocks) - (let ((target (comp-lap-to-limple-bb (cl-third inst))) + (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 - target - fall-bb)) - (puthash target - (make-comp-block :sp (comp-sp)) + handler-bb + guarded-bb)) + (puthash handler-bb + (make-comp-block :sp (1+ (comp-sp))) blocks) - (comp-mark-block-closed)) - (comp-emit-block fall-bb))) + (comp-mark-block-closed) + (comp-emit-block guarded-bb)))) (byte-pushcatch) (byte-nth auto) (byte-symbolp auto) @@ -668,9 +668,9 @@ the annotation emission." do (progn (cl-incf (comp-sp)) (comp-emit `(setpar ,(comp-slot) ,i)))) - (comp-emit-jump 'body) + (comp-emit-jump 'bb_1) ;; Body - (comp-emit-block 'body) + (comp-emit-block 'bb_1) (mapc #'comp-limplify-lap-inst (comp-func-lap func)) ;; Reverse insns into all basic blocks. (cl-loop for bb being the hash-value in (comp-func-blocks func) diff --git a/src/comp.c b/src/comp.c index ef72edd4990..93d0f81dbc8 100644 --- a/src/comp.c +++ b/src/comp.c @@ -948,18 +948,6 @@ emit_PURE_P (gcc_jit_rvalue *ptr) PURESIZE)); } -/* static gcc_jit_rvalue * */ -/* emit_call_n_ref (const char *f_name, unsigned nargs, */ -/* gcc_jit_lvalue *base_arg) */ -/* { */ -/* gcc_jit_rvalue *args[] = */ -/* { gcc_jit_context_new_rvalue_from_int(comp.ctxt, */ -/* comp.ptrdiff_type, */ -/* nargs), */ -/* gcc_jit_lvalue_get_address (base_arg, NULL) }; */ -/* return emit_call (f_name, comp.lisp_obj_type, 2, args); */ -/* } */ - /* Emit an r-value from an mvar meta variable. In case this is a constant that was propagated return it otherwise load it from frame. */ @@ -1051,14 +1039,86 @@ emit_limple_call_ref (Lisp_Object arg1) return emit_call (calle, comp.lisp_obj_type, 2, gcc_args); } +/* Register an handler for a non local exit. */ + +static void +emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type, + gcc_jit_block *handler_bb, gcc_jit_block *guarded_bb, + EMACS_UINT clobber_slot) +{ + /* Ex: (push-handler #s(comp-mvar 6 0 t (arith-error) nil) 1 bb_3 bb_2). */ + + static unsigned pushhandler_n; /* FIXME move at ctxt or func level. */ + gcc_jit_rvalue *args[2]; + + /* struct handler *c = push_handler (POP, type); */ + gcc_jit_lvalue *c = + gcc_jit_function_new_local (comp.func, + NULL, + comp.handler_ptr_type, + format_string ("c_%u", + pushhandler_n)); + args[0] = handler; + args[1] = handler_type; + gcc_jit_block_add_assignment ( + comp.block, + NULL, + c, + emit_call ("push_handler", comp.handler_ptr_type, 2, args)); + + args[0] = + gcc_jit_lvalue_get_address ( + gcc_jit_rvalue_dereference_field ( + gcc_jit_lvalue_as_rvalue (c), + NULL, + comp.handler_jmp_field), + NULL); + + gcc_jit_rvalue *res; +#ifdef HAVE__SETJMP + res = emit_call ("_setjmp", comp.int_type, 1, args); +#else + res = emit_call ("setjmp", comp.int_type, 1, args); +#endif + emit_cond_jump (res, handler_bb, guarded_bb); + + /* This emit the handler part. */ + + comp.block = handler_bb; + gcc_jit_lvalue *m_handlerlist = + gcc_jit_rvalue_dereference_field (comp.current_thread, + NULL, + comp.m_handlerlist); + gcc_jit_block_add_assignment ( + comp.block, + NULL, + m_handlerlist, + gcc_jit_lvalue_as_rvalue( + gcc_jit_rvalue_dereference_field (gcc_jit_lvalue_as_rvalue (c), + NULL, + comp.handler_next_field))); + gcc_jit_block_add_assignment ( + comp.block, + NULL, + comp.frame[clobber_slot], + gcc_jit_lvalue_as_rvalue( + gcc_jit_rvalue_dereference_field (gcc_jit_lvalue_as_rvalue (c), + NULL, + comp.handler_val_field))); + ++pushhandler_n; +} + static void emit_limple_insn (Lisp_Object insn) { Lisp_Object op = XCAR (insn); Lisp_Object args = XCDR (insn); - Lisp_Object arg0 = XCAR (args); + Lisp_Object arg0; gcc_jit_rvalue *res; + if (CONSP (args)) + arg0 = XCAR (args); + if (EQ (op, Qjump)) { /* Unconditional branch. */ @@ -1074,6 +1134,39 @@ emit_limple_insn (Lisp_Object insn) emit_cond_jump (emit_NILP (test), target2, target1); } + else if (EQ (op, Qpush_handler)) + { + EMACS_UINT clobber_slot = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); + gcc_jit_rvalue *handler = emit_mvar_val (arg0); + gcc_jit_rvalue *handler_type = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + XFIXNUM (SECOND (args))); + 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, + clobber_slot); + } + else if (EQ (op, Qpop_handler)) + { + /* current_thread->m_handlerlist = + current_thread->m_handlerlist->next; */ + gcc_jit_lvalue *m_handlerlist = + gcc_jit_rvalue_dereference_field (comp.current_thread, + NULL, + comp.m_handlerlist); + + gcc_jit_block_add_assignment( + comp.block, + NULL, + m_handlerlist, + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference_field ( + gcc_jit_lvalue_as_rvalue (m_handlerlist), + NULL, + comp.handler_next_field))); + + } else if (EQ (op, Qcall)) { gcc_jit_block_add_eval (comp.block, @@ -2129,6 +2222,8 @@ syms_of_comp (void) DEFSYM (Qreturn, "return"); DEFSYM (Qcomp_mvar, "comp-mvar"); DEFSYM (Qcond_jump, "cond-jump"); + DEFSYM (Qpush_handler, "push-handler"); + DEFSYM (Qpop_handler, "pop-handler"); defsubr (&Scomp_init_ctxt); defsubr (&Scomp_release_ctxt); diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 4462f35246a..871dede23a6 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -416,56 +416,58 @@ (buffer-string)) "abcd"))) -;; (ert-deftest comp-tests-non-locals () -;; "Test non locals." -;; (defun comp-tests-err-arith-f () -;; (/ 1 0)) -;; (defun comp-tests-err-foo-f () -;; (error "foo")) - -;; (defun comp-tests-condition-case-0-f () -;; ;; Bpushhandler Bpophandler -;; (condition-case -;; err -;; (comp-tests-err-arith-f) -;; (arith-error (concat "arith-error " -;; (error-message-string err) -;; " catched")) -;; (error (concat "error " -;; (error-message-string err) -;; " catched")))) - -;; (defun comp-tests-condition-case-1-f () -;; ;; Bpushhandler Bpophandler -;; (condition-case -;; err -;; (comp-tests-err-foo-f) -;; (arith-error (concat "arith-error " -;; (error-message-string err) -;; " catched")) -;; (error (concat "error " -;; (error-message-string err) -;; " catched")))) - -;; (defun comp-tests-catch-f (f) -;; (catch 'foo -;; (funcall f))) - -;; (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) - -;; (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))))) +(ert-deftest comp-tests-non-locals () + "Test non locals." + (let ((gc-cons-threshold most-positive-fixnum)) ;; FIXME!! + (defun comp-tests-err-arith-f () + (/ 1 0)) + (defun comp-tests-err-foo-f () + (error "foo")) + + (defun comp-tests-condition-case-0-f () + ;; Bpushhandler Bpophandler + (condition-case + err + (comp-tests-err-arith-f) + (arith-error (concat "arith-error " + (error-message-string err) + " catched")) + (error (concat "error " + (error-message-string err) + " catched")))) + + (defun comp-tests-condition-case-1-f () + ;; Bpushhandler Bpophandler + (condition-case + err + (comp-tests-err-foo-f) + (arith-error (concat "arith-error " + (error-message-string err) + " catched")) + (error (concat "error " + (error-message-string err) + " catched")))) + + ;; (defun comp-tests-catch-f (f) + ;; (catch 'foo + ;; (funcall f))) + + ;; (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) + + (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)))) + ) (ert-deftest comp-tests-gc () "Try to do some longer computation to let the gc kick in." -- 2.39.5