mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2025-01-05 11:45:45 +00:00
Code Issues Releases Activity

add fetch-handler operator

Browse Source
This commit is contained in:
Andrea Corallo 2019-10-20 21:00:17 +02:00
parent 7ba9a4c895
commit 8d08a8a107
2 changed files with 89 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

50
lisp/emacs-lisp/comp.el
View File

@ -92,7 +92,7 @@ Can be used by code that wants to expand differently in this case.")
set-rest-args-to-local)
"Limple set operators.")
(defconst comp-limple-assignments `(push-handler
(defconst comp-limple-assignments `(fetch-handler
,@comp-limple-sets)
"Limple operators that clobbers the first mvar argument.")
@ -217,7 +217,9 @@ structure.")
(edge-cnt-gen (funcall #'comp-gen-counter) :type function
:documentation "Generates edges numbers.")
(ssa-cnt-gen (funcall #'comp-gen-counter) :type function
:documentation "Counter to create ssa limple vars."))
:documentation "Counter to create ssa limple vars.")
(handler-cnt 0 :type number
:documentation "Number of non local handler buffers."))
(defun comp-func-reset-generators (func)
"Reset unique id generators for FUNC."
@ -505,7 +507,8 @@ Restore the original value afterwards."
(error "Can't find label %d" label)))
(cl-defun comp-block-maybe-mark-pending (&rest args &key name sp &allow-other-keys)
"Create a basic block and mark it as pending."
"Create a basic block and mark it as pending.
The basic block is returned."
(if-let ((bb (gethash name (comp-func-blocks comp-func))))
;; If was already declared sanity check sp.
(cl-assert (or (null sp) (= sp (comp-block-sp bb)))
@ -514,8 +517,8 @@ Restore the original value afterwards."
(unless (cl-find-if (lambda (bb)
(eq (comp-block-name bb) name))
(comp-limplify-pending-blocks comp-pass))
(push (apply #'make--comp-block args)
(comp-limplify-pending-blocks comp-pass)))))
(car (push (apply #'make--comp-block args)
(comp-limplify-pending-blocks comp-pass))))))
(defun comp-call (func &rest args)
"Emit a call for function FUNC with ARGS."
@ -545,10 +548,11 @@ Restore the original value afterwards."
do (aset v i mvar)
finally (return v)))
(defsubst comp-emit (insn)
"Emit INSN into current basic block."
(cl-assert (not (comp-block-closed (comp-limplify-curr-block comp-pass))))
(push insn (comp-block-insns (comp-limplify-curr-block comp-pass))))
(defsubst comp-emit (insn &optional bb)
"Emit INSN in BB is specified or the current basic block otherwise."
(let ((bb (or bb (comp-limplify-curr-block comp-pass))))
(cl-assert (not (comp-block-closed bb)))
(push insn (comp-block-insns bb))))
(defun comp-emit-set-call (call)
"Emit CALL assigning the result the the current slot frame.
@ -634,22 +638,26 @@ Return value is the fall through block name."
(defun comp-emit-handler (lap-label handler-type)
"Emit a non local exit handler to LAP-LABEL of type HANDLER-TYPE."
(cl-destructuring-bind (label-num . label-sp) lap-label
(let ((guarded-bb (comp-new-block-sym))
(handler-bb (comp-lap-to-limple-bb label-num)))
(cl-assert (= (- label-sp 2) (comp-sp)))
(comp-block-maybe-mark-pending :name guarded-bb
(cl-assert (= (- label-sp 2) (comp-sp)))
(let* ((guarded-name (comp-new-block-sym))
(handler-name (comp-lap-to-limple-bb label-num))
(handler-buff-n (comp-func-handler-cnt comp-func))
(handler-bb (comp-block-maybe-mark-pending :name handler-name
:sp (1+ (comp-sp))
:addr
(comp-label-to-addr label-num))))
(comp-block-maybe-mark-pending :name guarded-name
:sp (comp-sp)
:addr (1+ (comp-limplify-pc comp-pass)))
(comp-block-maybe-mark-pending :name handler-bb
:sp (1+ (comp-sp))
:addr (comp-label-to-addr label-num))
(comp-emit (list 'push-handler
(comp-slot+1)
(comp-slot+1)
handler-type
handler-bb
guarded-bb))
(setf (comp-block-closed (comp-limplify-curr-block comp-pass)) t))))
(comp-slot+1)
handler-buff-n
handler-name
guarded-name))
(setf (comp-block-closed (comp-limplify-curr-block comp-pass)) t)
(comp-emit `(fetch-handler ,(comp-slot+1) ,handler-buff-n) handler-bb)
(cl-incf (comp-func-handler-cnt comp-func)))))
(defun comp-limplify-listn (n)
"Limplify list N."

106
src/comp.c
View File

@ -171,6 +171,7 @@ typedef struct {
Lisp_Object func_blocks_h; /* blk_name -> gcc_block. */
Lisp_Object exported_funcs_h; /* subr_name -> gcc_jit_function *. */
Lisp_Object imported_funcs_h; /* subr_name -> reloc_field. */
Lisp_Object buffer_handler_vec; /* All locals used to store non local exit values. */
Lisp_Object emitter_dispatcher;
gcc_jit_rvalue *data_relocs; /* Synthesized struct holding data relocs. */
gcc_jit_lvalue *func_relocs; /* Synthesized struct holding func relocs. */
@ -280,7 +281,7 @@ retrive_block (Lisp_Object block_name)
static void
declare_block (Lisp_Object block_name)
{
char *name_str = (char *) SDATA (SYMBOL_NAME (block_name));
char *name_str = SSDATA (SYMBOL_NAME (block_name));
gcc_jit_block *block = gcc_jit_function_new_block (comp.func, name_str);
Lisp_Object value = make_mint_ptr (block);
ICE_IF (!NILP (Fgethash (block_name, comp.func_blocks_h, Qnil)),
@ -1151,23 +1152,12 @@ emit_limple_call_ref (Lisp_Object insn, bool direct)
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,
Lisp_Object clobbered_mvar)
EMACS_UINT handler_buff_n, gcc_jit_block *handler_bb,
gcc_jit_block *guarded_bb, Lisp_Object clobbered_mvar)
{
/*
Ex: (push-handler #s(comp-mvar 1 8 nil nil nil nil)
#s(comp-mvar 1 7 t done symbol nil)
catcher bb_2 bb_1).
*/
static unsigned pushhandler_n; /* FIXME move at ctxt or func level. */
/* struct handler *c = push_handler (POP, type); */
/* 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));
xmint_pointer (AREF (comp.buffer_handler_vec, handler_buff_n));
gcc_jit_rvalue *args[] = { handler, handler_type };
gcc_jit_block_add_assignment (
@ -1189,29 +1179,6 @@ emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type,
res =
emit_call (intern_c_string (SETJMP_NAME), comp.int_type, 1, args, false);
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)));
emit_frame_assignment (
clobbered_mvar,
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
@ -1222,6 +1189,16 @@ emit_limple_insn (Lisp_Object insn)
Lisp_Object arg0 UNINIT;
gcc_jit_rvalue *res;
Lisp_Object arg[6];
Lisp_Object p = XCDR (insn);
ptrdiff_t n_args = list_length (p);
unsigned i = 0;
FOR_EACH_TAIL (p)
{
eassert (i < n_args);
arg[i++] = XCAR (p);
}
if (CONSP (args))
arg0 = XCAR (args);
@ -1269,9 +1246,11 @@ emit_limple_insn (Lisp_Object insn)
}
else if (EQ (op, Qpush_handler))
{
gcc_jit_rvalue *handler = emit_mvar_val (arg0);
/* (push-handler condition-case #s(comp-mvar 0 3 t (arith-error) cons nil) 1 bb_2 bb_1) */
gcc_jit_rvalue *handler = emit_mvar_val (arg[1]);
int h_num UNINIT;
Lisp_Object handler_spec = THIRD (args);
Lisp_Object handler_spec = arg[0];
EMACS_UINT handler_buff_n = XFIXNUM (arg[2]);
if (EQ (handler_spec, Qcatcher))
h_num = CATCHER;
else if (EQ (handler_spec, Qcondition_case))
@ -1282,10 +1261,10 @@ emit_limple_insn (Lisp_Object insn)
gcc_jit_context_new_rvalue_from_int (comp.ctxt,
comp.int_type,
h_num);
gcc_jit_block *handler_bb = retrive_block (FORTH (args));
gcc_jit_block *guarded_bb = retrive_block (FIFTH (args));
emit_limple_push_handler (handler, handler_type, handler_bb, guarded_bb,
arg0);
gcc_jit_block *handler_bb = retrive_block (arg[3]);
gcc_jit_block *guarded_bb = retrive_block (arg[4]);
emit_limple_push_handler (handler, handler_type, handler_buff_n,
handler_bb, guarded_bb, arg0);
}
else if (EQ (op, Qpop_handler))
{
@ -1309,6 +1288,30 @@ emit_limple_insn (Lisp_Object insn)
comp.handler_next_field)));
}
else if (EQ (op, Qfetch_handler))
{
EMACS_UINT handler_buff_n = XFIXNUM (SECOND (args));
gcc_jit_lvalue *c =
xmint_pointer (AREF (comp.buffer_handler_vec, handler_buff_n));
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)));
emit_frame_assignment (
arg0,
gcc_jit_lvalue_as_rvalue(
gcc_jit_rvalue_dereference_field (gcc_jit_lvalue_as_rvalue (c),
NULL,
comp.handler_val_field)));
}
else if (EQ (op, Qcall))
{
gcc_jit_block_add_eval (comp.block, NULL,
@ -2759,7 +2762,7 @@ compile_function (Lisp_Object func)
frame_size),
"local");
comp.frame = SAFE_ALLOCA (frame_size * sizeof (*comp.frame));
for (unsigned i = 0; i < frame_size; ++i)
for (EMACS_INT i = 0; i < frame_size; ++i)
comp.frame[i] =
gcc_jit_context_new_array_access (
comp.ctxt,
@ -2789,6 +2792,16 @@ compile_function (Lisp_Object func)
format_string ("local%u", i));
}
EMACS_UINT non_local_handlers = XFIXNUM (FUNCALL1 (comp-func-handler-cnt, func));
comp.buffer_handler_vec = make_vector (non_local_handlers, Qnil);
for (unsigned i = 0; i < non_local_handlers; ++i)
ASET (comp.buffer_handler_vec, i,
make_mint_ptr (
gcc_jit_function_new_local (comp.func,
NULL,
comp.handler_ptr_type,
format_string ("handler_%u", i))));
comp.func_blocks_h = CALLN (Fmake_hash_table);
/* Pre declare all basic blocks to gcc.
@ -3304,6 +3317,7 @@ syms_of_comp (void)
/* Others. */
DEFSYM (Qpush_handler, "push-handler");
DEFSYM (Qpop_handler, "pop-handler");
DEFSYM (Qfetch_handler, "fetch-handler");
DEFSYM (Qcondition_case, "condition-case");
/* call operands. */
DEFSYM (Qcatcher, "catcher"); /* FIXME use these allover. */