From a9894ace841f89bdb1e4510ad48cb7fd76112ac0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 8 Jul 2019 11:18:17 +0200 Subject: [PATCH] purge C side --- lisp/emacs-lisp/comp.el | 6 +- src/comp.c | 1741 +-------------------------------------- test/src/comp-tests.el | 5 + 3 files changed, 50 insertions(+), 1702 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 22dcfc77b36..fda4dc437b6 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -136,7 +136,8 @@ '(comp-slot-n (1+ (comp-sp)))) (defun comp-push-call (src-slot) - "Push call X into frame." + "Push call SRC-SLOT into frame." + (cl-assert src-slot) (cl-incf (comp-sp)) (setf (comp-slot) (make-comp-mvar :slot (comp-sp) @@ -147,6 +148,7 @@ (defun comp-push-slot-n (n) "Push slot number N into frame." (let ((src-slot (comp-slot-n n))) + (cl-assert src-slot) (cl-incf (comp-sp)) (setf (comp-slot) (copy-sequence src-slot)) @@ -186,6 +188,8 @@ VAL is known at compile time." (comp-push-slot-n (comp-sp))) ('byte-varref (comp-push-call `(call Fsymbol_value ,(second inst)))) + ;; ('byte-varset + ;; (comp-push-call `(call Fsymbol_value ,(second inst)))) ('byte-constant (comp-push-const (second inst))) ('byte-stack-ref diff --git a/src/comp.c b/src/comp.c index 4837b122106..fb1fa79d12d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -31,138 +31,12 @@ along with GNU Emacs. If not, see . */ #include "atimer.h" #include "window.h" -#define DEFAULT_SPEED 2 /* From 0 to 3 map to gcc -O */ +#define DEFAULT_SPEED 2 /* See comp-speed var. */ #define COMP_DEBUG 1 -#define MAX_FUN_NAME 256 - -/* Max number of entries of the meta-stack that can get poped. */ - -#define MAX_POP 64 - #define DISASS_FILE_NAME "emacs-asm.s" -#define CHECK_STACK \ - eassert (stack >= stack_base && stack < stack_over) - -#define PUSH_LVAL(obj) \ - do { \ - CHECK_STACK; \ - emit_assign_to_stack_slot (comp.block, \ - stack, \ - gcc_jit_lvalue_as_rvalue (obj)); \ - stack++; \ - } while (0) - -#define PUSH_RVAL(obj) \ - do { \ - CHECK_STACK; \ - emit_assign_to_stack_slot (comp.block, stack, (obj)); \ - stack++; \ - } while (0) - -/* This always happens in the first basic block. */ - -#define PUSH_PARAM(obj) \ - do { \ - CHECK_STACK; \ - emit_assign_to_stack_slot (prologue, \ - stack, \ - gcc_jit_param_as_rvalue (obj)); \ - stack++; \ - } while (0) - -#define TOS (*(stack - 1)) - -#define DISCARD(n) (stack -= (n)) - -#define POP0 - -#define POP1 \ - do { \ - stack--; \ - CHECK_STACK; \ - args[0] = gcc_jit_lvalue_as_rvalue (stack->gcc_lval); \ - } while (0) - -#define POP2 \ - do { \ - stack--; \ - CHECK_STACK; \ - args[1] = gcc_jit_lvalue_as_rvalue (stack->gcc_lval); \ - stack--; \ - args[0] = gcc_jit_lvalue_as_rvalue (stack->gcc_lval); \ - } while (0) - -#define POP3 \ - do { \ - stack--; \ - CHECK_STACK; \ - args[2] = gcc_jit_lvalue_as_rvalue (stack->gcc_lval); \ - stack--; \ - args[1] = gcc_jit_lvalue_as_rvalue (stack->gcc_lval); \ - stack--; \ - args[0] = gcc_jit_lvalue_as_rvalue (stack->gcc_lval); \ - } while (0) - -/* Fetch the next byte from the bytecode stream. */ - -#define FETCH (bytestr_data[pc++]) - -/* Fetch two bytes from the bytecode stream and make a 16-bit number - out of them. */ - -#define FETCH2 (op = FETCH, op + (FETCH << 8)) - -#define STR(s) #s - -/* With most of the ops we need to do the same stuff so this macros are meant - to save some typing. */ - -#define CASE(op) \ - case op : \ - emit_comment (STR(op)) - -/* Pop from the meta-stack, emit the call and push the result */ - -#define EMIT_CALL_N(name, nargs) \ - do { \ - POP##nargs; \ - res = emit_call ((name), comp.lisp_obj_type, (nargs), args); \ - PUSH_RVAL (res); \ - } while (0) - -/* Generate appropriate case and emit call to function. */ - -#define CASE_CALL_N(name, nargs) \ - CASE (B##name); \ - EMIT_CALL_N (STR(F##name), nargs); \ - break - -/* - Emit calls to functions with prototype (ptrdiff_t nargs, Lisp_Object *args). - This is done by passing a reference to the first obj involved on the stack. -*/ - -#define EMIT_CALL_N_REF(name, nargs) \ - do { \ - DISCARD (nargs); \ - res = emit_call_n_ref ((name), (nargs), stack->gcc_lval); \ - PUSH_RVAL (res); \ - } while (0) - -#define EMIT_ARITHCOMPARE(comparison) \ - do { \ - POP2; \ - args[2] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, \ - comp.int_type, \ - (comparison)); \ - res = emit_call ("arithcompare", comp.lisp_obj_type, 3, args); \ - PUSH_RVAL (res); \ - } while (0) - - #define SAFE_ALLOCA_BLOCK(ptr, func, name) \ do { \ (ptr) = SAFE_ALLOCA (sizeof (basic_block_t)); \ @@ -171,6 +45,8 @@ do { \ (ptr)->top = NULL; \ } while (0) +#define STR(s) #s + #define DECL_AND_SAFE_ALLOCA_BLOCK(name, func) \ basic_block_t *(name); \ SAFE_ALLOCA_BLOCK ((name), (func), STR(name)) @@ -304,24 +180,6 @@ bcall0 (Lisp_Object f) Ffuncall (1, &f); } -/* Pop form the main evaluation stack and place the elements in args in reversed - order. */ - -INLINE static void -pop (unsigned n, stack_el_t **stack_ref, gcc_jit_rvalue *args[]) -{ - eassert (n <= MAX_POP); /* FIXME? */ - stack_el_t *stack = *stack_ref; - - while (n--) - { - stack--; - args[n] = gcc_jit_lvalue_as_rvalue (stack->gcc_lval); - } - - *stack_ref = stack; -} - INLINE static gcc_jit_field * type_to_cast_field (gcc_jit_type *type) { @@ -1806,150 +1664,16 @@ define_bool_to_lisp_obj (void) SAFE_FREE (); } -static int -ucmp(const void *a, const void *b) -{ -#define _I(x) *(const int*)x - return _I(a) < _I(b) ? -1 : _I(a) > _I(b); -#undef _I -} - -/* Compute and initialize all basic blocks. */ -static basic_block_t * -compute_blocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data, - Lisp_Object *vectorp, ptrdiff_t const_length) +DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, + 0, 0, 0, + doc: /* Initialize the native compiler context. Return t on success. */) + (void) { - ptrdiff_t pc = 0; - unsigned op; - bool new_bb = true; - basic_block_t *bb_map = xmalloc (bytestr_length * sizeof (basic_block_t)); - unsigned *bb_start_pc = xmalloc (bytestr_length * sizeof (unsigned)); - unsigned bb_n = 0; - - while (pc < bytestr_length) - { - if (new_bb) - { - bb_start_pc[bb_n++] = pc; - new_bb = false; - } - - op = FETCH; - switch (op) - { - /* 3 byte non branch ops */ - case Bvarref7: - case Bvarset7: - case Bvarbind7: - case Bcall7: - case Bunbind7: - case Bstack_ref7: - case Bstack_set2: - pc += 2; - break; - /* 2 byte non branch ops */ - case Bvarref6: - case Bvarset6: - case Bvarbind6: - case Bcall6: - case Bunbind6: - case BlistN: - case BconcatN: - case BinsertN: - case Bstack_ref6: - case Bstack_set: - case BdiscardN: - ++pc; - break; - /* Absolute branches */ - case Bgoto: - case Bgotoifnil: - case Bgotoifnonnil: - case Bgotoifnilelsepop: - case Bgotoifnonnilelsepop: - case Bpushcatch: - case Bpushconditioncase: - op = FETCH2; - bb_start_pc[bb_n++] = op; - new_bb = true; - break; - /* PC relative branches */ - case BRgoto: - case BRgotoifnil: - case BRgotoifnonnil: - case BRgotoifnilelsepop: - case BRgotoifnonnilelsepop: - op = FETCH - 128; - bb_start_pc[bb_n++] = op; - new_bb = true; - break; - /* Other ops changing bb */ - case Bsub1: - case Badd1: - case Bnegate: - case Breturn: - new_bb = true; - break; - case Bswitch: - /* Handled in Bconstant case. */ - emacs_abort (); - break; - case Bconstant2: - op = FETCH2; - FALLTHROUGH; - default: - case Bconstant: - { - if (bytestr_data[pc] != Bswitch) - break; - /* Jump table with following Bswitch. */ - ++pc; - op -= Bconstant; - struct Lisp_Hash_Table *h = XHASH_TABLE (vectorp[op]); - for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i) - if (!NILP (HASH_HASH (h, i))) - { - Lisp_Object pc = HASH_VALUE (h, i); - bb_start_pc[bb_n++] = XFIXNUM (pc); - } - bb_start_pc[bb_n++] = pc; - ++pc; - } - } - } - - /* Sort and remove possible duplicates. */ - qsort (bb_start_pc, bb_n, sizeof(unsigned), ucmp); - { - unsigned i, j; - for (i = j = 0; i < bb_n; i++) - if (bb_start_pc[i] != bb_start_pc[j]) - bb_start_pc[++j] = bb_start_pc[i]; - bb_n = j + 1; - } - - basic_block_t curr_bb; - for (int i = 0, pc = 0; pc < bytestr_length; pc++) + if (comp.ctxt) { - if (i < bb_n && pc == bb_start_pc[i]) - { - ++i; - curr_bb.gcc_bb = - gcc_jit_function_new_block (comp.func, format_string ("bb_%d", i)); - curr_bb.top = NULL; - curr_bb.terminated = false; - } - bb_map[pc] = curr_bb; + error ("Compiler context already taken."); + return Qnil; } - - xfree (bb_start_pc); - - return bb_map; -} - -static void -init_comp (int opt_level) -{ comp.ctxt = gcc_jit_context_acquire(); if (COMP_DEBUG) @@ -1974,14 +1698,9 @@ init_comp (int opt_level) } - gcc_jit_context_set_int_option (comp.ctxt, - GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, - opt_level); - /* Do not inline within a compilation unit. */ gcc_jit_context_add_command_line_option (comp.ctxt, "-fno-inline"); - comp.void_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID); comp.void_ptr_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID_PTR); @@ -2089,1438 +1808,58 @@ init_comp (int opt_level) define_CHECK_IMPURE (); define_bool_to_lisp_obj (); define_setcar_setcdr(); + + return Qt; } -static void -release_comp (void) +DEFUN ("comp-release-ctxt", Fcomp_release_ctxt, Scomp_release_ctxt, + 0, 0, 0, + doc: /* Release the native compiler context. */) + (void) { if (comp.ctxt) gcc_jit_context_release(comp.ctxt); if (logfile) fclose (logfile); -} - -static comp_f_res_t -compile_f (const char *lisp_f_name, const char *c_f_name, - ptrdiff_t bytestr_length, unsigned char *bytestr_data, - EMACS_INT stack_depth, Lisp_Object *vectorp, - ptrdiff_t const_length, Lisp_Object args_template) -{ - USE_SAFE_ALLOCA; - gcc_jit_rvalue *res; - comp_f_res_t comp_res = { NULL, 0, 0 }; - ptrdiff_t pc = 0; - gcc_jit_rvalue *args[MAX_POP]; - unsigned op; - unsigned pushhandler_n = 0; - comp_res.min_args = 0; - comp_res.max_args = MANY; - - /* Meta-stack we use to flat the bytecode written for push and pop - Emacs VM.*/ - stack_el_t *stack_base, *stack, *stack_over; - SAFE_NALLOCA (stack_base, sizeof (stack_el_t), stack_depth); - stack = stack_base; - stack_over = stack_base + stack_depth; - - bool parse_args = true; - if (FIXNUMP (args_template)) - { - ptrdiff_t at = XFIXNUM (args_template); - bool rest = (at & 128) != 0; - int mandatory = at & 127; - ptrdiff_t nonrest = at >> 8; - - comp_res.min_args = mandatory; - - if (!rest && nonrest < SUBR_MAX_ARGS) - { - comp_res.max_args = nonrest; - parse_args = false; - } - } + comp.ctxt = NULL; - if (!parse_args) - { - comp.func = - emit_func_declare (c_f_name, comp.lisp_obj_type, comp_res.max_args, - NULL, GCC_JIT_FUNCTION_EXPORTED, false); - } - else - { - gcc_jit_param *param[] = - { gcc_jit_context_new_param (comp.ctxt, - NULL, - comp.ptrdiff_type, - "nargs"), - gcc_jit_context_new_param (comp.ctxt, - NULL, - comp.lisp_obj_ptr_type, - "args") }; - comp.func = - gcc_jit_context_new_function (comp.ctxt, - NULL, - GCC_JIT_FUNCTION_EXPORTED, - comp.lisp_obj_type, - c_f_name, - 2, - param, - 0); - } - - - gcc_jit_lvalue *meta_stack_array = - gcc_jit_function_new_local ( - comp.func, - NULL, - gcc_jit_context_new_array_type (comp.ctxt, - NULL, - comp.lisp_obj_type, - stack_depth), - "local"); - - for (int i = 0; i < stack_depth; ++i) - stack[i].gcc_lval = gcc_jit_context_new_array_access ( - comp.ctxt, - NULL, - gcc_jit_lvalue_as_rvalue (meta_stack_array), - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.int_type, - i)); - - DECL_AND_SAFE_ALLOCA_BLOCK(prologue, comp.func); - comp.block = prologue; - - basic_block_t *bb_map = - compute_blocks (bytestr_length, bytestr_data, vectorp, const_length); - - if (!parse_args) - { - for (ptrdiff_t i = 0; i < comp_res.max_args; ++i) - PUSH_PARAM (gcc_jit_function_get_param (comp.func, i)); - } - else - { - /* - nargs will be known at runtime therfore we emit: - - prologue: - local[0] = *args; - ++args; - . - . - . - local[min_args - 1] = *args; - ++args; - local[min_args] = list (nargs - min_args, args); - bb_1: - . - . - . - */ - gcc_jit_lvalue *nargs = - gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 0)); - gcc_jit_lvalue *args = - gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 1)); - gcc_jit_rvalue *min_args = - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.ptrdiff_type, - comp_res.min_args); - - for (ptrdiff_t i = 0; i < comp_res.min_args; ++i) - { - PUSH_LVAL (gcc_jit_rvalue_dereference ( - gcc_jit_lvalue_as_rvalue (args), - NULL)); - gcc_jit_block_add_assignment (prologue->gcc_bb, - NULL, - args, - emit_ptr_arithmetic ( - gcc_jit_lvalue_as_rvalue (args), - comp.lisp_obj_ptr_type, - sizeof (Lisp_Object), - comp.one)); - } - - /* - rest arguments - */ - gcc_jit_rvalue *list_args[] = - { gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_MINUS, - comp.ptrdiff_type, - gcc_jit_lvalue_as_rvalue (nargs), - min_args), - gcc_jit_lvalue_as_rvalue (args) }; - - PUSH_RVAL (emit_call ("Flist", comp.lisp_obj_type, 2, list_args)); - } - gcc_jit_block_end_with_jump (prologue->gcc_bb, NULL, bb_map[0].gcc_bb); - comp.block = &bb_map[0]; - gcc_jit_rvalue *nil = emit_lisp_obj_from_ptr (Qnil); - - comp.block = NULL; - - while (pc < bytestr_length) - { - enum handlertype type; - - /* If we are changing BB and the last was one wasn't terminated - terminate it with a fall through. */ - if (comp.block && comp.block->gcc_bb != bb_map[pc].gcc_bb && - !comp.block->terminated) - { - gcc_jit_block_end_with_jump (comp.block->gcc_bb, NULL, bb_map[pc].gcc_bb); - comp.block->terminated = true; - } - comp.block = &bb_map[pc]; - if (bb_map[pc].top) - stack = bb_map[pc].top; - op = FETCH; - - switch (op) - { - CASE (Bstack_ref1); - goto stack_ref; - CASE (Bstack_ref2); - goto stack_ref; - CASE (Bstack_ref3); - goto stack_ref; - CASE (Bstack_ref4); - goto stack_ref; - CASE (Bstack_ref5); - stack_ref: - PUSH_LVAL ( - stack_base[(stack - stack_base) - (op - Bstack_ref) - 1].gcc_lval); - break; - - CASE (Bstack_ref6); - PUSH_LVAL (stack_base[(stack - stack_base) - FETCH - 1].gcc_lval); - break; - - CASE (Bstack_ref7); - PUSH_LVAL (stack_base[(stack - stack_base) - FETCH2 - 1].gcc_lval); - break; - - CASE (Bvarref7); - op = FETCH2; - goto varref; - - CASE (Bvarref); - goto varref_count; - CASE (Bvarref1); - goto varref_count; - CASE (Bvarref2); - goto varref_count; - CASE (Bvarref3); - goto varref_count; - CASE (Bvarref4); - goto varref_count; - CASE (Bvarref5); - varref_count: - op -= Bvarref; - goto varref; - - CASE (Bvarref6); - op = FETCH; - varref: - { - args[0] = emit_lisp_obj_from_ptr (vectorp[op]); - res = emit_call ("Fsymbol_value", comp.lisp_obj_type, 1, args); - PUSH_RVAL (res); - break; - } - - CASE (Bvarset); - goto varset_count; - CASE (Bvarset1); - goto varset_count; - CASE (Bvarset2); - goto varset_count; - CASE (Bvarset3); - goto varset_count; - CASE (Bvarset4); - goto varset_count; - CASE (Bvarset5); - varset_count: - op -= Bvarset; - goto varset; - - CASE (Bvarset7); - op = FETCH2; - goto varset; - - CASE (Bvarset6); - op = FETCH; - varset: - { - POP1; - args[1] = args[0]; - args[0] = emit_lisp_obj_from_ptr (vectorp[op]); - args[2] = nil; - args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.int_type, - SET_INTERNAL_SET); - res = emit_call ("set_internal", comp.lisp_obj_type, 4, args); - PUSH_RVAL (res); - } - break; - - CASE (Bvarbind6); - op = FETCH; - goto varbind; - - CASE (Bvarbind7); - op = FETCH2; - goto varbind; - - CASE (Bvarbind); - goto varbind_count; - CASE (Bvarbind1); - goto varbind_count; - CASE (Bvarbind2); - goto varbind_count; - CASE (Bvarbind3); - goto varbind_count; - CASE (Bvarbind4); - goto varbind_count; - CASE (Bvarbind5); - varbind_count: - op -= Bvarbind; - varbind: - { - args[0] = emit_lisp_obj_from_ptr (vectorp[op]); - pop (1, &stack, &args[1]); - res = emit_call ("specbind", comp.lisp_obj_type, 2, args); - PUSH_RVAL (res); - break; - } - - CASE (Bcall6); - op = FETCH; - goto docall; - - CASE (Bcall7); - op = FETCH2; - goto docall; - - CASE (Bcall); - goto docall_count; - CASE (Bcall1); - goto docall_count; - CASE (Bcall2); - goto docall_count; - CASE (Bcall3); - goto docall_count; - CASE (Bcall4); - goto docall_count; - CASE (Bcall5); - docall_count: - op -= Bcall; - docall: - { - res = NULL; - pop (op + 1, &stack, args); - if (stack->const_set && - stack->type == Lisp_Symbol) - { - char *sym_name = (char *) SDATA (SYMBOL_NAME (stack->constant)); - if (!strcmp (sym_name, - lisp_f_name)) - { - /* Optimize self calls. */ - res = gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.func, - op, - args + 1); - } else if (SUBRP ((XSYMBOL (stack->constant)->u.s.function))) - { - /* Optimize primitive native calls. */ - emit_comment (format_string ("Calling primitive %s", - sym_name)); - /* FIXME we really should check is a primitive too!! */ - struct Lisp_Subr *subr = - XSUBR ((XSYMBOL (stack->constant)->u.s.function)); - if (subr->max_args == MANY) - { - /* f (nargs, args); */ - args[0] = - gcc_jit_context_new_rvalue_from_int ( - comp.ctxt, - comp.ptrdiff_type, - op); - args[1] = - gcc_jit_lvalue_get_address ((stack + 1)->gcc_lval, - NULL); - gcc_jit_type *types[] = - { comp.ptrdiff_type, comp.lisp_obj_ptr_type }; - gcc_jit_type *fn_ptr_type = - gcc_jit_context_new_function_ptr_type ( - comp.ctxt, - NULL, - comp.lisp_obj_type, - 2, types, 0); - res = - gcc_jit_context_new_call_through_ptr ( - comp.ctxt, - NULL, - gcc_jit_context_new_rvalue_from_ptr ( - comp.ctxt, - fn_ptr_type, - subr->function.a0), - 2, args); - } else - { - gcc_jit_type *types[op]; - - for (int i = 0; i < op; i++) - types[i] = comp.lisp_obj_type; - - gcc_jit_type *fn_ptr_type = - gcc_jit_context_new_function_ptr_type ( - comp.ctxt, - NULL, - comp.lisp_obj_type, - op, - types, - 0); - res = - gcc_jit_context_new_call_through_ptr ( - comp.ctxt, - NULL, - gcc_jit_context_new_rvalue_from_ptr ( - comp.ctxt, - fn_ptr_type, - subr->function.a0), - op, - args + 1); - } - } - } - /* Fall back to regular funcall dispatch mechanism. */ - if (!res) - res = emit_call_n_ref ("Ffuncall", op + 1, stack->gcc_lval); - - PUSH_RVAL (res); - break; - } - - CASE (Bunbind6); - op = FETCH; - goto dounbind; - - CASE (Bunbind7); - op = FETCH2; - goto dounbind; - - CASE (Bunbind); - goto dounbind_count; - CASE (Bunbind1); - goto dounbind_count; - CASE (Bunbind2); - goto dounbind_count; - CASE (Bunbind3); - goto dounbind_count; - CASE (Bunbind4); - goto dounbind_count; - CASE (Bunbind5); - dounbind_count: - op -= Bunbind; - dounbind: - { - args[0] = gcc_jit_context_new_rvalue_from_int(comp.ctxt, - comp.ptrdiff_type, - op); - - emit_call ("helper_unbind_n", comp.lisp_obj_type, 1, args); - } - break; - - CASE (Bpophandler); - { - /* 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->gcc_bb, - 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))); - break; - } - - CASE (Bpushconditioncase); /* New in 24.4. */ - type = CONDITION_CASE; - goto pushhandler; - - CASE (Bpushcatch); /* New in 24.4. */ - type = CATCHER; - pushhandler: - { - /* struct handler *c = push_handler (POP, type); */ - int handler_pc = FETCH2; - gcc_jit_lvalue *c = - gcc_jit_function_new_local (comp.func, - NULL, - comp.handler_ptr_type, - format_string ("c_%u", - pushhandler_n)); - POP1; - args[1] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.int_type, - type); - gcc_jit_block_add_assignment ( - comp.block->gcc_bb, - 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); -#ifdef HAVE__SETJMP - res = emit_call ("_setjmp", comp.int_type, 1, args); -#else - res = emit_call ("setjmp", comp.int_type, 1, args); -#endif - basic_block_t *push_h_val_block; - SAFE_ALLOCA_BLOCK (push_h_val_block, - comp.func, - format_string ("push_h_val_%u", - pushhandler_n)); - - emit_cond_jump (res, push_h_val_block, &bb_map[pc]); - - stack_el_t *stack_to_restore = stack; - /* This emit the handler part. */ - - basic_block_t *bb_orig = comp.block; - comp.block = push_h_val_block; - /* current_thread->m_handlerlist = c->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->gcc_bb, - NULL, - m_handlerlist, - gcc_jit_lvalue_as_rvalue( - gcc_jit_rvalue_dereference_field ( - gcc_jit_lvalue_as_rvalue (c), - NULL, - comp.handler_next_field))); - /* PUSH (c->val); */ - PUSH_LVAL (gcc_jit_rvalue_dereference_field ( - gcc_jit_lvalue_as_rvalue (c), - NULL, - comp.handler_val_field)); - bb_map[handler_pc].top = stack; - comp.block = bb_orig; - - gcc_jit_block_end_with_jump (push_h_val_block->gcc_bb, NULL, - bb_map[handler_pc].gcc_bb); - - stack = stack_to_restore; - ++pushhandler_n; - } - break; - - CASE_CALL_N (nth, 2); - CASE_CALL_N (symbolp, 1); - - CASE (Bconsp); - POP1; - res = emit_cast (comp.bool_type, - emit_CONSP (args[0])); - res = gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.bool_to_lisp_obj, - 1, &res); - PUSH_RVAL (res); - break; - - CASE_CALL_N (stringp, 1); - CASE_CALL_N (listp, 1); - CASE_CALL_N (eq, 2); - CASE_CALL_N (memq, 1); - CASE_CALL_N (not, 1); - - case Bcar: - POP1; - res = gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.car, - 1, args); - PUSH_RVAL (res); - break; - - case Bcdr: - POP1; - res = gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.cdr, - 1, args); - PUSH_RVAL (res); - break; - - CASE_CALL_N (cons, 2); - - CASE (BlistN); - op = FETCH; - goto make_list; - - CASE (Blist1); - goto make_list_count; - CASE (Blist2); - goto make_list_count; - CASE (Blist3); - goto make_list_count; - CASE (Blist4); - make_list_count: - op = op - Blist1; - make_list: - { - POP1; - args[1] = nil; - res = emit_call ("Fcons", comp.lisp_obj_type, 2, args); - PUSH_RVAL (res); - for (int i = 0; i < op; ++i) - { - POP2; - res = emit_call ("Fcons", comp.lisp_obj_type, 2, args); - PUSH_RVAL (res); - } - break; - } - - CASE_CALL_N (length, 1); - CASE_CALL_N (aref, 2); - CASE_CALL_N (aset, 3); - CASE_CALL_N (symbol_value, 1); - CASE_CALL_N (symbol_function, 1); - CASE_CALL_N (set, 2); - CASE_CALL_N (fset, 2); - CASE_CALL_N (get, 2); - CASE_CALL_N (substring, 3); - - CASE (Bconcat2); - EMIT_CALL_N_REF ("Fconcat", 2); - break; - CASE (Bconcat3); - EMIT_CALL_N_REF ("Fconcat", 3); - break; - CASE (Bconcat4); - EMIT_CALL_N_REF ("Fconcat", 4); - break; - CASE (BconcatN); - op = FETCH; - EMIT_CALL_N_REF ("Fconcat", op); - break; - - CASE (Bsub1); - { - /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM - ? make_fixnum (XFIXNUM (TOP) - 1) - : Fsub1 (TOP)) */ - - DECL_AND_SAFE_ALLOCA_BLOCK (sub1_inline_block, comp.func); - DECL_AND_SAFE_ALLOCA_BLOCK (sub1_fcall_block, comp.func); - - gcc_jit_rvalue *tos_as_num = - emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS.gcc_lval)); - - emit_cond_jump ( - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_LOGICAL_AND, - comp.bool_type, - emit_cast (comp.bool_type, - emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (TOS.gcc_lval))), - gcc_jit_context_new_comparison (comp.ctxt, - NULL, - GCC_JIT_COMPARISON_NE, - tos_as_num, - comp.most_negative_fixnum)), - sub1_inline_block, - sub1_fcall_block); - - gcc_jit_rvalue *sub1_inline_res = - gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_MINUS, - comp.emacs_int_type, - tos_as_num, - comp.one); - - basic_block_t *bb_orig = comp.block; - - comp.block = sub1_inline_block; - emit_assign_to_stack_slot (sub1_inline_block, - &TOS, - emit_make_fixnum (sub1_inline_res)); - comp.block = sub1_fcall_block; - POP1; - res = emit_call ("Fsub1", comp.lisp_obj_type, 1, args); - PUSH_RVAL (res); - - gcc_jit_block_end_with_jump (sub1_inline_block->gcc_bb, - NULL, - bb_map[pc].gcc_bb); - gcc_jit_block_end_with_jump (sub1_fcall_block->gcc_bb, - NULL, - bb_map[pc].gcc_bb); - comp.block = bb_orig; - SAFE_FREE (); - } - - break; - CASE (Badd1); - { - /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_POSITIVE_FIXNUM - ? make_fixnum (XFIXNUM (TOP) + 1) - : Fadd (TOP)) */ - - DECL_AND_SAFE_ALLOCA_BLOCK (add1_inline_block, comp.func); - DECL_AND_SAFE_ALLOCA_BLOCK (add1_fcall_block, comp.func); - - gcc_jit_rvalue *tos_as_num = - emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS.gcc_lval)); - - emit_cond_jump ( - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_LOGICAL_AND, - comp.bool_type, - emit_cast (comp.bool_type, - emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (TOS.gcc_lval))), - gcc_jit_context_new_comparison (comp.ctxt, - NULL, - GCC_JIT_COMPARISON_NE, - tos_as_num, - comp.most_positive_fixnum)), - add1_inline_block, - add1_fcall_block); - - gcc_jit_rvalue *add1_inline_res = - gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_PLUS, - comp.emacs_int_type, - tos_as_num, - comp.one); - - basic_block_t *bb_orig = comp.block; - comp.block = add1_inline_block; - emit_assign_to_stack_slot(add1_inline_block, - &TOS, - emit_make_fixnum (add1_inline_res)); - comp.block = add1_fcall_block; - POP1; - res = emit_call ("Fadd1", comp.lisp_obj_type, 1, args); - PUSH_RVAL (res); - - gcc_jit_block_end_with_jump (add1_inline_block->gcc_bb, - NULL, - bb_map[pc].gcc_bb); - gcc_jit_block_end_with_jump (add1_fcall_block->gcc_bb, - NULL, - bb_map[pc].gcc_bb); - comp.block = bb_orig; - SAFE_FREE (); - } - break; - - CASE (Beqlsign); - EMIT_ARITHCOMPARE (ARITH_EQUAL); - break; - - CASE (Bgtr); - EMIT_ARITHCOMPARE (ARITH_GRTR); - break; - - CASE (Blss); - EMIT_ARITHCOMPARE (ARITH_LESS); - break; - - CASE (Bleq); - EMIT_ARITHCOMPARE (ARITH_LESS_OR_EQUAL); - break; - - CASE (Bgeq); - EMIT_ARITHCOMPARE (ARITH_GRTR_OR_EQUAL); - break; - - CASE (Bdiff); - EMIT_CALL_N_REF ("Fminus", 2); - break; - - CASE (Bnegate); - { - /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM - ? make_fixnum (- XFIXNUM (TOP)) - : Fminus (1, &TOP)) */ - - DECL_AND_SAFE_ALLOCA_BLOCK (negate_inline_block, comp.func); - DECL_AND_SAFE_ALLOCA_BLOCK (negate_fcall_block, comp.func); - - gcc_jit_rvalue *tos_as_num = - emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS.gcc_lval)); - - emit_cond_jump ( - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_LOGICAL_AND, - comp.bool_type, - emit_cast (comp.bool_type, - emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (TOS.gcc_lval))), - gcc_jit_context_new_comparison (comp.ctxt, - NULL, - GCC_JIT_COMPARISON_NE, - tos_as_num, - comp.most_negative_fixnum)), - negate_inline_block, - negate_fcall_block); - - gcc_jit_rvalue *negate_inline_res = - gcc_jit_context_new_unary_op (comp.ctxt, - NULL, - GCC_JIT_UNARY_OP_MINUS, - comp.emacs_int_type, - tos_as_num); - - basic_block_t *bb_orig = comp.block; - - comp.block = negate_inline_block; - emit_assign_to_stack_slot (negate_inline_block, - &TOS, - emit_make_fixnum (negate_inline_res)); - comp.block = negate_fcall_block; - EMIT_CALL_N_REF ("Fminus", 1); - - gcc_jit_block_end_with_jump (negate_inline_block->gcc_bb, - NULL, - bb_map[pc].gcc_bb); - gcc_jit_block_end_with_jump (negate_fcall_block->gcc_bb, - NULL, - bb_map[pc].gcc_bb); - comp.block = bb_orig; - SAFE_FREE (); - } - break; - CASE (Bplus); - EMIT_CALL_N_REF ("Fplus", 2); - break; - CASE (Bmax); - EMIT_CALL_N_REF ("Fmax", 2); - break; - CASE (Bmin); - EMIT_CALL_N_REF ("Fmin", 2); - break; - CASE (Bmult); - EMIT_CALL_N_REF ("Ftimes", 2); - break; - CASE (Bpoint); - args[0] = - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.ptrdiff_type, - PT); - res = emit_call ("make_fixed_natnum", - comp.lisp_obj_type, - 1, - args); - PUSH_RVAL (res); - break; - - CASE_CALL_N (goto_char, 1); - - CASE (Binsert); - EMIT_CALL_N_REF ("Finsert", 1); - break; - - CASE (Bpoint_max); - args[0] = - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.ptrdiff_type, - ZV); - res = emit_call ("make_fixed_natnum", - comp.lisp_obj_type, - 1, - args); - PUSH_RVAL (res); - break; - - CASE (Bpoint_min); - args[0] = - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.ptrdiff_type, - BEGV); - res = emit_call ("make_fixed_natnum", - comp.lisp_obj_type, - 1, - args); - PUSH_RVAL (res); - break; - - CASE_CALL_N (char_after, 1); - CASE_CALL_N (following_char, 0); - - CASE (Bpreceding_char); - res = emit_call ("Fprevious_char", comp.lisp_obj_type, 0, args); - PUSH_RVAL (res); - break; - - CASE_CALL_N (current_column, 0); - - CASE (Bindent_to); - POP1; - args[1] = nil; - res = emit_call ("Findent_to", comp.lisp_obj_type, 2, args); - PUSH_RVAL (res); - break; - - CASE_CALL_N (eolp, 0); - CASE_CALL_N (eobp, 0); - CASE_CALL_N (bolp, 0); - CASE_CALL_N (bobp, 0); - CASE_CALL_N (current_buffer, 0); - CASE_CALL_N (set_buffer, 1); - - CASE (Bsave_current_buffer); /* Obsolete since ??. */ - goto save_current; - CASE (Bsave_current_buffer_1); - save_current: - emit_call ("record_unwind_current_buffer", - comp.void_type, 0, NULL); - break; - - CASE (Binteractive_p); /* Obsolete since 24.1. */ - PUSH_RVAL (emit_lisp_obj_from_ptr (intern ("interactive-p"))); - res = emit_call ("call0", comp.lisp_obj_type, 1, args); - PUSH_RVAL (res); - break; - - CASE_CALL_N (forward_char, 1); - CASE_CALL_N (forward_word, 1); - CASE_CALL_N (skip_chars_forward, 2); - CASE_CALL_N (skip_chars_backward, 2); - CASE_CALL_N (forward_line, 1); - CASE_CALL_N (char_syntax, 1); - CASE_CALL_N (buffer_substring, 2); - CASE_CALL_N (delete_region, 2); - CASE_CALL_N (narrow_to_region, 2); - CASE_CALL_N (widen, 0); - CASE_CALL_N (end_of_line, 1); - - CASE (Bconstant2); - op = FETCH2; - goto do_constant; - - CASE (Bgoto); - op = FETCH2; - gcc_jit_block_end_with_jump (comp.block->gcc_bb, - NULL, - bb_map[op].gcc_bb); - comp.block->terminated = true; - bb_map[op].top = stack; - break; - - CASE (Bgotoifnil); - op = FETCH2; - POP1; - emit_comparison_jump (GCC_JIT_COMPARISON_EQ, args[0], nil, - &bb_map[op], &bb_map[pc]); - bb_map[op].top = stack; - break; - - CASE (Bgotoifnonnil); - op = FETCH2; - POP1; - emit_comparison_jump (GCC_JIT_COMPARISON_NE, args[0], nil, - &bb_map[op], &bb_map[pc]); - bb_map[op].top = stack; - break; - - CASE (Bgotoifnilelsepop); - op = FETCH2; - emit_comparison_jump (GCC_JIT_COMPARISON_EQ, - gcc_jit_lvalue_as_rvalue (TOS.gcc_lval), - nil, - &bb_map[op], &bb_map[pc]); - bb_map[op].top = stack; - DISCARD (1); - break; - - CASE (Bgotoifnonnilelsepop); - op = FETCH2; - emit_comparison_jump (GCC_JIT_COMPARISON_NE, - gcc_jit_lvalue_as_rvalue (TOS.gcc_lval), - nil, - &bb_map[op], &bb_map[pc]); - bb_map[op].top = stack; - DISCARD (1); - break; - - CASE (Breturn); - POP1; - gcc_jit_block_end_with_return(comp.block->gcc_bb, - NULL, - args[0]); - comp.block->terminated = true; - break; - - CASE (Bdiscard); - DISCARD (1); - break; - - CASE (Bdup); - PUSH_LVAL (TOS.gcc_lval); - break; - - CASE (Bsave_excursion); - res = emit_call ("record_unwind_protect_excursion", - comp.void_type, 0, args); - break; - - CASE (Bsave_window_excursion); /* Obsolete since 24.1. */ - EMIT_CALL_N ("helper_save_window_excursion", 1); - break; - - CASE (Bsave_restriction); - args[0] = emit_lisp_obj_from_ptr (save_restriction_restore); - args[1] = emit_call ("save_restriction_save", - comp.lisp_obj_type, - 0, - NULL); - emit_call ("record_unwind_protect", comp.void_ptr_type, 2, args); - break; - - CASE (Bcatch); /* Obsolete since 24.4. */ - POP2; - args[2] = args[1]; - args[1] = emit_lisp_obj_from_ptr (eval_sub); - emit_call ("internal_catch", comp.void_ptr_type, 3, args); - break; - - CASE (Bunwind_protect); /* FIXME: avoid closure for lexbind. */ - POP1; - emit_call ("helper_unwind_protect", comp.void_type, 1, args); - break; - - CASE (Bcondition_case); /* Obsolete since 24.4. */ - POP3; - emit_call ("internal_lisp_condition_case", - comp.lisp_obj_type, 3, args); - break; - - CASE (Btemp_output_buffer_setup); /* Obsolete since 24.1. */ - EMIT_CALL_N ("helper_temp_output_buffer_setup", 1); - break; - - CASE (Btemp_output_buffer_show); /* Obsolete since 24.1. */ - POP2; - emit_call ("temp_output_buffer_show", comp.void_type, 1, - &args[1]); - PUSH_RVAL (args[0]); - emit_call ("helper_unbind_n", comp.lisp_obj_type, 1, args); - - break; - CASE (Bunbind_all); /* Obsolete. Never used. */ - /* To unbind back to the beginning of this frame. Not used yet, - but will be needed for tail-recursion elimination. */ - error ("Bunbind_all not supported"); - break; - - CASE_CALL_N (set_marker, 3); - CASE_CALL_N (match_beginning, 1); - CASE_CALL_N (match_end, 1); - CASE_CALL_N (upcase, 1); - CASE_CALL_N (downcase, 1); - - CASE (Bstringeqlsign); - EMIT_CALL_N ("Fstring_equal", 2); - break; - - CASE (Bstringlss); - EMIT_CALL_N ("Fstring_lessp", 2); - break; - - CASE_CALL_N (equal, 2); - CASE_CALL_N (nthcdr, 2); - CASE_CALL_N (elt, 2); - CASE_CALL_N (member, 2); - CASE_CALL_N (assq, 2); - - case Bsetcar: - POP2; - res = gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.setcar, - 2, args); - PUSH_RVAL (res); - break; - - case Bsetcdr: - POP2; - res = gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.setcdr, - 2, args); - PUSH_RVAL (res); - break; - - CASE (Bcar_safe); - EMIT_CALL_N ("CAR_SAFE", 1); - break; - - CASE (Bcdr_safe); - EMIT_CALL_N ("CDR_SAFE", 1); - break; - - CASE (Bnconc); - EMIT_CALL_N_REF ("Fnconc", 2); - break; - - CASE (Bquo); - EMIT_CALL_N_REF ("Fquo", 2); - break; - - CASE_CALL_N (rem, 2); - - CASE (Bnumberp); - POP1; - res = emit_NUMBERP (args[0]); - res = gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.bool_to_lisp_obj, - 1, &res); - PUSH_RVAL (res); - break; - - CASE (Bintegerp); - POP1; - res = emit_INTEGERP(args[0]); - res = gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.bool_to_lisp_obj, - 1, &res); - PUSH_RVAL (res); - break; - - CASE (BRgoto); - op = FETCH - 128; - op += pc; - gcc_jit_block_end_with_jump (comp.block->gcc_bb, - NULL, - bb_map[op].gcc_bb); - comp.block->terminated = true; - bb_map[op].top = stack; - break; - - CASE (BRgotoifnil); - op = FETCH - 128; - op += pc; - POP1; - emit_comparison_jump (GCC_JIT_COMPARISON_EQ, args[0], nil, - &bb_map[op], &bb_map[pc]); - bb_map[op].top = stack; - break; - - CASE (BRgotoifnonnil); - op = FETCH - 128; - op += pc; - POP1; - emit_comparison_jump (GCC_JIT_COMPARISON_NE, args[0], nil, - &bb_map[op], &bb_map[pc]); - bb_map[op].top = stack; - break; - - CASE (BRgotoifnilelsepop); - op = FETCH - 128; - op += pc; - emit_comparison_jump (GCC_JIT_COMPARISON_EQ, - gcc_jit_lvalue_as_rvalue (TOS.gcc_lval), - nil, - &bb_map[op], &bb_map[pc]); - bb_map[op].top = stack; - DISCARD (1); - break; - - CASE (BRgotoifnonnilelsepop); - op = FETCH - 128; - op += pc; - emit_comparison_jump (GCC_JIT_COMPARISON_NE, - gcc_jit_lvalue_as_rvalue (TOS.gcc_lval), - nil, - &bb_map[op], &bb_map[pc]); - bb_map[op].top = stack; - DISCARD (1); - break; - - CASE (BinsertN); - op = FETCH; - EMIT_CALL_N_REF ("Finsert", op); - break; - - CASE (Bstack_set); - /* stack-set-0 = discard; stack-set-1 = discard-1-preserve-tos. */ - op = FETCH; - POP1; - if (op > 0) - emit_assign_to_stack_slot (comp.block, stack - op, args[0]); - break; - - CASE (Bstack_set2); - op = FETCH2; - POP1; - emit_assign_to_stack_slot (comp.block, stack - op, args[0]); - break; - - CASE (BdiscardN); - op = FETCH; - if (op & 0x80) - { - op &= 0x7F; - POP1; - emit_assign_to_stack_slot (comp.block, stack - op - 1, args[0]); - } - - DISCARD (op); - break; - CASE (Bswitch); - /* The cases of Bswitch that we handle (which in theory is - all of them) are done in Bconstant, below. This is done - due to a design issue with Bswitch -- it should have - taken a constant pool index inline, but instead looks for - a constant on the stack. */ - goto fail; - break; - - default: - CASE (Bconstant); - { - if (op < Bconstant || op > Bconstant + const_length) - goto fail; - - op -= Bconstant; - do_constant: - - /* See the Bswitch case for commentary. */ - if (pc >= bytestr_length || bytestr_data[pc] != Bswitch) - { - gcc_jit_rvalue *c = - emit_lisp_obj_from_ptr (vectorp[op]); - PUSH_RVAL (c); - TOS.type = XTYPE (vectorp[op]); - if (TOS.type == Lisp_Symbol) - { - /* Store the symbol value for later use is used while - optimizing native and self calls. */ - TOS.constant = vectorp[op]; - TOS.const_set = true; - } - break; - } - - /* Jump table with following Bswitch. */ - ++pc; - - struct Lisp_Hash_Table *h = XHASH_TABLE (vectorp[op]); - POP1; - basic_block_t *jump_block; - for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i) - if (!NILP (HASH_HASH (h, i))) - { - SAFE_ALLOCA_BLOCK (jump_block, - comp.func, - format_string ("jump_t_%ld", - i)); - ptrdiff_t target_pc = XFIXNUM (HASH_VALUE (h, i)); - gcc_jit_rvalue *val = - emit_lisp_obj_from_ptr (HASH_KEY (h, i)); - emit_cond_jump (emit_EQ (args[0], val), &bb_map[target_pc], - jump_block); - comp.block = jump_block; - } - - break; - } - } - } - - if (COMP_DEBUG) - gcc_jit_context_dump_to_file (comp.ctxt, "gcc-ctxt-dump.c", 1); - comp_res.gcc_res = gcc_jit_context_compile(comp.ctxt); - - goto exit; - - fail: - error ("Something went wrong"); - - exit: - xfree (bb_map); - SAFE_FREE (); - return comp_res; + return Qt; } -void -emacs_native_compile (const char *lisp_f_name, const char *c_f_name, - Lisp_Object func, int opt_level, bool dump_asm) +DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, + 1, 1, 0, + doc: /* Add limple FUNC to the current compilation context. */) + (Lisp_Object func) { - init_comp (opt_level); - Lisp_Object bytestr = AREF (func, COMPILED_BYTECODE); - CHECK_STRING (bytestr); - - if (STRING_MULTIBYTE (bytestr)) - /* BYTESTR must have been produced by Emacs 20.2 or the earlier - because they produced a raw 8-bit string for byte-code and now - such a byte-code string is loaded as multibyte while raw 8-bit - characters converted to multibyte form. Thus, now we must - convert them back to the originally intended unibyte form. */ - bytestr = Fstring_as_unibyte (bytestr); - - ptrdiff_t bytestr_length = SBYTES (bytestr); - - Lisp_Object vector = AREF (func, COMPILED_CONSTANTS); - CHECK_VECTOR (vector); - Lisp_Object *vectorp = XVECTOR (vector)->contents; - - Lisp_Object maxdepth = AREF (func, COMPILED_STACK_DEPTH); - CHECK_FIXNAT (maxdepth); - - /* Gcc doesn't like being interrupted. */ - sigset_t oldset; - block_atimers (&oldset); - - comp_f_res_t comp_res = compile_f (lisp_f_name, c_f_name, bytestr_length, - SDATA (bytestr), XFIXNAT (maxdepth) + 1, - vectorp, ASIZE (vector), - AREF (func, COMPILED_ARGLIST)); - - union Aligned_Lisp_Subr *x = xmalloc (sizeof (union Aligned_Lisp_Subr)); - - x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; - x->s.function.a0 = gcc_jit_result_get_code(comp_res.gcc_res, c_f_name); - eassert (x->s.function.a0); - x->s.min_args = comp_res.min_args; - x->s.max_args = comp_res.max_args; - x->s.symbol_name = lisp_f_name; - defsubr(x); - - if (dump_asm) - { - gcc_jit_context_compile_to_file (comp.ctxt, - GCC_JIT_OUTPUT_KIND_ASSEMBLER, - DISASS_FILE_NAME); - } - unblock_atimers (&oldset); - release_comp (); + return Qt; } -DEFUN ("native-compile", Fnative_compile, Snative_compile, - 1, 3, 0, - doc: /* Compile as native code function FUNC and load it. */) /* FIXME doc */ - (Lisp_Object func, Lisp_Object speed, Lisp_Object disassemble) +DEFUN ("comp-compile-ctxt", Fcomp_compile_ctxt, Scomp_compile_ctxt, + 0, 1, 0, + doc: /* Compile as native code the current context. */) + (Lisp_Object disassemble) { - static char c_f_name[MAX_FUN_NAME]; - char *lisp_f_name; - - if (!SYMBOLP (func)) - error ("Not a symbol."); - - lisp_f_name = (char *) SDATA (SYMBOL_NAME (func)); - - int res = snprintf (c_f_name, MAX_FUN_NAME, "Fnative_comp_%s", lisp_f_name); - - if (res >= MAX_FUN_NAME) - error ("Function name too long"); - - /* FIXME how many other characters are not allowed in C? - This will introduce name clashs too. */ - char *c = c_f_name; - while (*c) - { - if (*c == '-' || - *c == '+') - *c = '_'; - ++c; - } - - func = indirect_function (func); - if (!COMPILEDP (func)) - error ("Not a byte-compiled function"); - - if (speed != Qnil && - (!FIXNUMP (speed) || - !(XFIXNUM (speed) >= 0 && - XFIXNUM (speed) <= 3))) - error ("opt-level must be number between 0 and 3"); - - int opt_level; - if (speed == Qnil) - opt_level = DEFAULT_SPEED; - else - opt_level = XFIXNUM (speed); - - emacs_native_compile (lisp_f_name, c_f_name, func, opt_level, - !NILP (disassemble)); - - if (!NILP (disassemble)) - { - FILE *fd; - Lisp_Object str; - - if ((fd = fopen (DISASS_FILE_NAME, "r"))) - { - fseek (fd , 0L, SEEK_END); - long int size = ftell (fd); - fseek (fd , 0L, SEEK_SET); - char *buffer = xmalloc (size + 1); - ptrdiff_t nread = fread (buffer, 1, size, fd); - if (nread > 0) - { - size = nread; - buffer[size] = '\0'; - str = make_string (buffer, size); - fclose (fd); - } - else - str = empty_unibyte_string; - xfree (buffer); - return str; - } - else - { - error ("disassemble file could not be found"); - } - } - - return Qnil; + gcc_jit_context_set_int_option (comp.ctxt, + GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, + comp_speed); + return Qt; } void syms_of_comp (void) { - defsubr (&Snative_compile); + defsubr (&Scomp_init_ctxt); + defsubr (&Scomp_release_ctxt); + defsubr (&Scomp_add_func_to_ctxt); + defsubr (&Scomp_compile_ctxt); comp.func_hash = Qnil; staticpro (&comp.func_hash); + + DEFVAR_INT ("comp-speed", comp_speed, + doc: /* From 0 to 3. */); + comp_speed = DEFAULT_SPEED; + } /******************************************************************************/ diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 421f77008a4..c6ee5b76855 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -103,6 +103,11 @@ (defun comp-tests-varset-f () (setq comp-tests-var1 55)) (comp-test-compile #'comp-tests-varset-f) +((byte-constant 55 . 1) + (byte-dup . 0) + (byte-varset comp-tests-var1 . 0) + (byte-return . 0)) + (comp-tests-varset-f) (should (= comp-tests-var1 55))) -- 2.39.5