(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)
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)
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. */
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. */
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,
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);
(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."
projects / emacs.git / commitdiff