From: Andrea Corallo Date: Sun, 20 Oct 2019 19:00:17 +0000 (+0200) Subject: add fetch-handler operator X-Git-Tag: emacs-28.0.90~2727^2~1066 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=8d08a8a1070435e12b77517808df34a8093abc67;p=emacs.git add fetch-handler operator --- diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 34e0d02e3b1..9ce1e96b3c8 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -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." diff --git a/src/comp.c b/src/comp.c index be966c2709a..6b3ca832d98 100644 --- a/src/comp.c +++ b/src/comp.c @@ -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. */