#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)); \
(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))
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)
{
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)
}
- 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);
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;
+
}
/******************************************************************************/
projects / emacs.git / commitdiff