mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2026-01-23 04:53:12 -08:00
Code Issues Projects Releases Wiki Activity
emacs/src/comp.c
Andrea Corallo 96fc40d7db generate reproducer if needed
2020-01-01 11:33:40 +01:00

1623 lines
38 KiB
C
Raw Blame History

/* Compile byte code produced by bytecomp.el into native code.
Copyright (C) 2019 Free Software Foundation, Inc.
This file is part of GNU Emacs.
GNU Emacs is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or (at
your option) any later version.
GNU Emacs is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <config.h>
#ifdef HAVE_LIBGCCJIT
#include <stdlib.h>
#include <stdio.h>
#include <libgccjit.h>
#include "lisp.h"
#include "buffer.h"
#include "bytecode.h"
#include "atimer.h"
#include "window.h"
#define COMP_DEBUG 1
#define MAX_FUN_NAME 256
/* Max number of args we are able to handle while emitting function calls. */
#define MAX_ARGS 16
#define DISASS_FILE_NAME "emacs-asm.s"
#define CHECK_STACK \
eassert (stack >= stack_base && stack < stack_over)
#define PUSH_LVAL(obj) \
do { \
CHECK_STACK; \
gcc_jit_block_add_assignment (comp.bblock->gcc_bb, \
NULL, \
*stack, \
gcc_jit_lvalue_as_rvalue(obj)); \
stack++; \
} while (0)
#define PUSH_RVAL(obj) \
do { \
CHECK_STACK; \
gcc_jit_block_add_assignment (comp.bblock->gcc_bb, \
NULL, \
*stack, \
(obj)); \
stack++; \
} while (0)
/* This always happens in the first basic block. */
#define PUSH_PARAM(obj) \
do { \
CHECK_STACK; \
gcc_jit_block_add_assignment (bb_map[0].gcc_bb, \
NULL, \
*stack, \
gcc_jit_param_as_rvalue(obj)); \
stack++; \
} while (0)
#define TOS (*(stack - 1))
#define POP0
#define POP1 \
do { \
stack--; \
CHECK_STACK; \
args[0] = gcc_jit_lvalue_as_rvalue (*stack); \
} while (0)
#define POP2 \
do { \
stack--; \
CHECK_STACK; \
args[1] = gcc_jit_lvalue_as_rvalue (*stack); \
stack--; \
args[0] = gcc_jit_lvalue_as_rvalue (*stack); \
} while (0)
#define POP3 \
do { \
stack--; \
CHECK_STACK; \
args[2] = gcc_jit_lvalue_as_rvalue (*stack); \
stack--; \
args[1] = gcc_jit_lvalue_as_rvalue (*stack); \
stack--; \
args[0] = gcc_jit_lvalue_as_rvalue (*stack); \
} 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. */
/* Generate appropriate case and emit convential calls to function. */
#define CASE_CALL_NARGS(name, nargs) \
case B##name: \
POP##nargs; \
res = comp_emit_call (STR(F##name), comp.lisp_obj_type, nargs, args); \
PUSH_LVAL (res); \
break
/* Emit calls to functions with prototype (ptrdiff_t nargs, Lisp_Object *args)
This is done aggregating args into the scratch_call_area. */
#define EMIT_SCRATCH_CALL_N(name, nargs) \
do { \
pop (nargs, &stack, args); \
res = comp_emit_callN (name, nargs, args); \
PUSH_LVAL (res); \
} while (0)
typedef struct {
gcc_jit_block *gcc_bb;
bool terminated;
} basic_block_t;
/* The compiler context */
typedef struct {
gcc_jit_context *ctxt;
gcc_jit_type *void_type;
gcc_jit_type *int_type;
gcc_jit_type *long_type;
gcc_jit_type *long_long_type;
gcc_jit_type *void_ptr_type;
gcc_jit_type *ptrdiff_type;
gcc_jit_type *lisp_obj_type;
gcc_jit_field *lisp_obj_as_ptr;
gcc_jit_field *lisp_obj_as_num;
gcc_jit_function *func; /* Current function being compiled */
gcc_jit_rvalue *scratch; /* Will point to scratch_call_area */
gcc_jit_rvalue *most_positive_fixnum;
gcc_jit_rvalue *most_negative_fixnum;
gcc_jit_rvalue *one;
gcc_jit_rvalue *inttypebits;
gcc_jit_rvalue *lisp_int0;
basic_block_t *bblock; /* Current basic block */
Lisp_Object func_hash; /* f_name -> gcc_func */
} comp_t;
static comp_t comp;
Lisp_Object scratch_call_area[MAX_ARGS];
FILE *logfile = NULL;
/* The result of one function compilation. */
typedef struct {
gcc_jit_result *gcc_res;
short min_args, max_args;
} comp_f_res_t;
INLINE static void pop (unsigned n, gcc_jit_lvalue ***stack_ref,
gcc_jit_rvalue *args[]);
void emacs_native_compile (const char *lisp_f_name, const char *c_f_name,
Lisp_Object func, bool dump_asm);
static void
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, gcc_jit_lvalue ***stack_ref, gcc_jit_rvalue *args[])
{
gcc_jit_lvalue **stack = *stack_ref;
while (n--)
{
stack--;
args[n] = gcc_jit_lvalue_as_rvalue (*stack);
}
*stack_ref = stack;
}
INLINE static gcc_jit_rvalue *
comp_xfixnum (gcc_jit_rvalue *obj)
{
return gcc_jit_context_new_binary_op (
comp.ctxt,
NULL,
GCC_JIT_BINARY_OP_RSHIFT,
comp.long_long_type,
gcc_jit_rvalue_access_field (obj,
NULL,
comp.lisp_obj_as_num),
comp.inttypebits);
}
INLINE static gcc_jit_rvalue *
comp_make_fixnum (gcc_jit_rvalue *obj)
{
gcc_jit_rvalue *tmp =
gcc_jit_context_new_binary_op (comp.ctxt,
NULL,
GCC_JIT_BINARY_OP_LSHIFT,
comp.long_long_type,
obj,
comp.inttypebits);
tmp = gcc_jit_context_new_binary_op (comp.ctxt,
NULL,
GCC_JIT_BINARY_OP_PLUS,
comp.long_long_type,
tmp,
comp.lisp_int0);
gcc_jit_lvalue *res = gcc_jit_function_new_local (comp.func,
NULL,
comp.lisp_obj_type,
"lisp_obj_fixnum");
gcc_jit_block_add_assignment (comp.bblock->gcc_bb,
NULL,
gcc_jit_lvalue_access_field (
res,
NULL,
comp.lisp_obj_as_num),
tmp);
return gcc_jit_lvalue_as_rvalue (res);
}
/* Construct fill and return a lisp object form a raw pointer. */
INLINE static gcc_jit_rvalue *
comp_lisp_obj_as_ptr_from_ptr (basic_block_t *bblock, void *p)
{
gcc_jit_lvalue *lisp_obj = gcc_jit_function_new_local (comp.func,
NULL,
comp.lisp_obj_type,
"lisp_obj_from_ptr");
gcc_jit_lvalue *lisp_obj_as_ptr =
gcc_jit_lvalue_access_field (lisp_obj,
NULL,
comp.lisp_obj_as_ptr);
gcc_jit_rvalue *void_ptr =
gcc_jit_context_new_rvalue_from_ptr(comp.ctxt,
comp.void_ptr_type,
p);
gcc_jit_block_add_assignment (bblock->gcc_bb,
NULL,
lisp_obj_as_ptr,
void_ptr);
return gcc_jit_lvalue_as_rvalue (lisp_obj);
}
static gcc_jit_function *
comp_func_declare (const char *f_name, gcc_jit_type *ret_type,
unsigned nargs, gcc_jit_rvalue **args,
enum gcc_jit_function_kind kind, bool reusable)
{
gcc_jit_param *param[4];
gcc_jit_type *type[4];
/* If args are passed types are extracted from that otherwise assume params */
/* are all lisp objs. */
if (args)
for (int i = 0; i < nargs; i++)
type[i] = gcc_jit_rvalue_get_type (args[i]);
else
for (int i = 0; i < nargs; i++)
type[i] = comp.lisp_obj_type;
switch (nargs) {
case 4:
param[3] = gcc_jit_context_new_param(comp.ctxt,
NULL,
type[3],
"c");
/* Fall through */
FALLTHROUGH;
case 3:
param[2] = gcc_jit_context_new_param(comp.ctxt,
NULL,
type[2],
"c");
/* Fall through */
FALLTHROUGH;
case 2:
param[1] = gcc_jit_context_new_param(comp.ctxt,
NULL,
type[1],
"b");
/* Fall through */
FALLTHROUGH;
case 1:
param[0] = gcc_jit_context_new_param(comp.ctxt,
NULL,
type[0],
"a");
/* Fall through */
FALLTHROUGH;
case 0:
break;
default:
/* Argnum not supported */
eassert (0);
}
gcc_jit_function *func =
gcc_jit_context_new_function(comp.ctxt, NULL,
kind,
comp.lisp_obj_type,
f_name,
nargs,
param,
0);
if (reusable)
{
Lisp_Object value;
Lisp_Object key = make_string (f_name, strlen (f_name));
value = make_pointer_integer (XPL (func));
EMACS_UINT hash = 0;
struct Lisp_Hash_Table *ht = XHASH_TABLE (comp.func_hash);
ptrdiff_t i = hash_lookup (ht, key, &hash);
/* Don't want to declare the same function two times */
eassert (i == -1);
hash_put (ht, key, value, hash);
}
return func;
}
static gcc_jit_lvalue *
comp_emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs,
gcc_jit_rvalue **args)
{
Lisp_Object key = make_string (f_name, strlen (f_name));
EMACS_UINT hash = 0;
struct Lisp_Hash_Table *ht = XHASH_TABLE (comp.func_hash);
ptrdiff_t i = hash_lookup (ht, key, &hash);
if (i == -1)
{
comp_func_declare(f_name, ret_type, nargs, args, GCC_JIT_FUNCTION_IMPORTED,
true);
i = hash_lookup (ht, key, &hash);
eassert (i != -1);
}
Lisp_Object value = HASH_VALUE (ht, hash_lookup (ht, key, &hash));
gcc_jit_function *func = (gcc_jit_function *) XFIXNUMPTR (value);
gcc_jit_lvalue *res = gcc_jit_function_new_local(comp.func,
NULL,
ret_type,
"res");
gcc_jit_block_add_assignment(comp.bblock->gcc_bb, NULL,
res,
gcc_jit_context_new_call(comp.ctxt,
NULL,
func,
nargs,
args));
return res;
}
static gcc_jit_lvalue *
comp_emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args)
{
/* Here we set all the pointers into the scratch call area. */
/* TODO: distinguish primitives for faster calling convention. */
/*
Lisp_Object *p;
p = scratch_call_area;
p[0] = nargs;
p[1] = 0x...;
.
.
.
p[n] = 0x...;
*/
gcc_jit_lvalue *p =
gcc_jit_function_new_local(comp.func,
NULL,
gcc_jit_type_get_pointer (comp.lisp_obj_type),
"p");
gcc_jit_block_add_assignment(comp.bblock->gcc_bb, NULL,
p,
comp.scratch);
for (int i = 0; i < nargs; i++) {
gcc_jit_rvalue *idx =
gcc_jit_context_new_rvalue_from_int (comp.ctxt,
gcc_jit_context_get_type(comp.ctxt,
GCC_JIT_TYPE_UNSIGNED_INT),
i);
gcc_jit_block_add_assignment (comp.bblock->gcc_bb, NULL,
gcc_jit_context_new_array_access (comp.ctxt,
NULL,
gcc_jit_lvalue_as_rvalue(p),
idx),
args[i]);
}
args[0] = gcc_jit_context_new_rvalue_from_int(comp.ctxt,
comp.ptrdiff_type,
nargs);
args[1] = comp.scratch;
return comp_emit_call (f_name, comp.lisp_obj_type, 2, args);
}
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_bblocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data)
{
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 Bpushcatch:
case Bpushconditioncase:
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 Bconstant2:
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:
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;
case Bsub1:
case Breturn:
new_bb = true;
break;
default:
break;
}
}
/* 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;
}
/* for (int i = 0; i < bb_n; i++) */
/* printf ("%d ", bb_start_pc[i]); */
/* printf ("\n"); */
basic_block_t curr_bb;
for (int i = 0, pc = 0; pc < bytestr_length; pc++)
{
if (i < bb_n && pc == bb_start_pc[i])
{
++i;
curr_bb.gcc_bb = gcc_jit_function_new_block (comp.func, NULL);
curr_bb.terminated = false;
}
bb_map[pc] = curr_bb;
}
xfree (bb_start_pc);
return bb_map;
}
/* Close current basic block emitting a conditional. */
static void
comp_emit_conditional (enum gcc_jit_comparison op,
gcc_jit_rvalue *test,
gcc_jit_block *then_target, gcc_jit_block *else_target)
{
gcc_jit_block_end_with_conditional (comp.bblock->gcc_bb,
NULL,
test,
then_target,
else_target);
comp.bblock->terminated = true;
}
/* Close current basic block emitting a comparison between two rval. */
static gcc_jit_rvalue *
comp_emit_comparison (enum gcc_jit_comparison op,
gcc_jit_rvalue *a, gcc_jit_rvalue *b,
gcc_jit_block *then_target, gcc_jit_block *else_target)
{
gcc_jit_rvalue *test = gcc_jit_context_new_comparison (comp.ctxt,
NULL,
op,
a, b);
comp_emit_conditional (op, test, then_target, else_target);
return test;
}
static comp_f_res_t
compile_f (const char *f_name, ptrdiff_t bytestr_length,
unsigned char *bytestr_data,
EMACS_INT stack_depth, Lisp_Object *vectorp,
ptrdiff_t vector_size, Lisp_Object args_template)
{
gcc_jit_lvalue *res;
comp_f_res_t comp_res = { NULL, 0, 0 };
ptrdiff_t pc = 0;
gcc_jit_rvalue *args[4];
unsigned op;
/* This is the stack we use to flat the bytecode written for push and pop
Emacs VM.*/
gcc_jit_lvalue **stack_base, **stack, **stack_over;
stack_base = stack =
(gcc_jit_lvalue **) xmalloc (stack_depth * sizeof (gcc_jit_lvalue *));
stack_over = stack_base + stack_depth;
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;
eassert (!rest);
if (!rest && nonrest < SUBR_MAX_ARGS)
comp_res.max_args = nonrest;
}
else if (CONSP (args_template))
/* FIXME */
comp_res.min_args = comp_res.max_args = XFIXNUM (Flength (args_template));
else
eassert (SYMBOLP (args_template) && args_template == Qnil);
/* Current function being compiled. */
comp.func = comp_func_declare (f_name, comp.lisp_obj_type, comp_res.max_args,
NULL, GCC_JIT_FUNCTION_EXPORTED, false);
char local_name[256];
for (int i = 0; i < stack_depth; ++i)
{
snprintf (local_name, sizeof (local_name), "local_%d", i);
stack[i] = gcc_jit_function_new_local (comp.func,
NULL,
comp.lisp_obj_type,
local_name);
}
basic_block_t *bb_map = compute_bblocks (bytestr_length, bytestr_data);
for (ptrdiff_t i = 0; i < comp_res.max_args; ++i)
PUSH_PARAM (gcc_jit_function_get_param (comp.func, i));
gcc_jit_rvalue *nil = comp_lisp_obj_as_ptr_from_ptr (&bb_map[0], Qnil);
comp.bblock = NULL;
while (pc < bytestr_length)
{
/* If we are changing BB and the last was one wasn't terminated
terminate it with a fall through. */
if (comp.bblock && comp.bblock->gcc_bb != bb_map[pc].gcc_bb &&
!comp.bblock->terminated)
{
gcc_jit_block_end_with_jump (comp.bblock->gcc_bb, NULL, bb_map[pc].gcc_bb);
comp.bblock->terminated = true;
}
comp.bblock = &bb_map[pc];
op = FETCH;
switch (op)
{
case Bstack_ref1:
case Bstack_ref2:
case Bstack_ref3:
case Bstack_ref4:
case Bstack_ref5:
{
PUSH_LVAL (stack_base[(stack - stack_base) - (op - Bstack_ref) - 1]);
break;
}
case Bstack_ref6:
{
PUSH_LVAL (stack_base[(stack - stack_base) - FETCH - 1]);
break;
}
case Bstack_ref7:
{
PUSH_LVAL (stack_base[(stack - stack_base) - FETCH2 - 1]);
break;
}
case Bvarref7:
op = FETCH2;
goto varref;
case Bvarref:
case Bvarref1:
case Bvarref2:
case Bvarref3:
case Bvarref4:
case Bvarref5:
op -= Bvarref;
goto varref;
case Bvarref6:
op = FETCH;
varref:
{
args[0] = comp_lisp_obj_as_ptr_from_ptr (comp.bblock, vectorp[op]);
res = comp_emit_call ("Fsymbol_value", comp.lisp_obj_type, 1, args);
PUSH_LVAL (res);
break;
}
case Bvarset:
case Bvarset1:
case Bvarset2:
case Bvarset3:
case Bvarset4:
case Bvarset5:
op -= Bvarset;
goto varset;
case Bvarset7:
op = FETCH2;
goto varset;
case Bvarset6:
op = FETCH;
varset:
{
POP1;
args[1] = args[0];
args[0] = comp_lisp_obj_as_ptr_from_ptr (comp.bblock, vectorp[op]);
args[2] = nil;
args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt,
comp.int_type,
SET_INTERNAL_SET);
res = comp_emit_call ("set_internal", comp.lisp_obj_type, 4, args);
PUSH_LVAL (res);
}
break;
case Bvarbind6:
op = FETCH;
goto varbind;
case Bvarbind7:
op = FETCH2;
goto varbind;
case Bvarbind:
case Bvarbind1:
case Bvarbind2:
case Bvarbind3:
case Bvarbind4:
case Bvarbind5:
op -= Bvarbind;
varbind:
{
args[0] = comp_lisp_obj_as_ptr_from_ptr (comp.bblock, vectorp[op]);
pop (1, &stack, &args[1]);
res = comp_emit_call ("specbind", comp.lisp_obj_type, 2, args);
PUSH_LVAL (res);
break;
}
case Bcall6:
op = FETCH;
goto docall;
case Bcall7:
op = FETCH2;
goto docall;
case Bcall:
case Bcall1:
case Bcall2:
case Bcall3:
case Bcall4:
case Bcall5:
op -= Bcall;
docall:
{
ptrdiff_t nargs = op + 1;
pop (nargs, &stack, args);
res = comp_emit_callN ("Ffuncall", nargs, args);
PUSH_LVAL (res);
break;
}
case Bunbind6:
op = FETCH;
goto dounbind;
case Bunbind7:
op = FETCH2;
goto dounbind;
case Bunbind:
case Bunbind1:
case Bunbind2:
case Bunbind3:
case Bunbind4:
case Bunbind5:
op -= Bunbind;
dounbind:
{
args[0] = gcc_jit_context_new_rvalue_from_int(comp.ctxt,
comp.ptrdiff_type,
op);
comp_emit_call ("helper_unbind_n", comp.lisp_obj_type, 1, args);
}
break;
case Bpophandler:
error ("Bpophandler unsupported bytecode\n");
break;
case Bpushconditioncase:
error ("Bpushconditioncase unsupported bytecode\n");
break;
case Bpushcatch:
error ("Bpushcatch unsupported bytecode\n");
break;
CASE_CALL_NARGS (nth, 2);
CASE_CALL_NARGS (symbolp, 1);
CASE_CALL_NARGS (consp, 1);
CASE_CALL_NARGS (stringp, 1);
CASE_CALL_NARGS (listp, 1);
CASE_CALL_NARGS (eq, 2);
CASE_CALL_NARGS (memq, 1);
CASE_CALL_NARGS (not, 1);
CASE_CALL_NARGS (car, 1);
CASE_CALL_NARGS (cdr, 1);
CASE_CALL_NARGS (cons, 2);
case BlistN:
op = FETCH;
goto make_list;
case Blist1:
case Blist2:
case Blist3:
case Blist4:
op = op - Blist1;
make_list:
{
POP1;
args[1] = nil;
res = comp_emit_call ("Fcons", comp.lisp_obj_type, 2, args);
PUSH_LVAL (res);
for (int i = 0; i < op; ++i)
{
POP2;
res = comp_emit_call ("Fcons", comp.lisp_obj_type, 2, args);
PUSH_LVAL (res);
}
break;
}
CASE_CALL_NARGS (length, 1);
CASE_CALL_NARGS (aref, 2);
CASE_CALL_NARGS (aset, 3);
CASE_CALL_NARGS (symbol_value, 1);
CASE_CALL_NARGS (symbol_function, 1);
CASE_CALL_NARGS (set, 2);
CASE_CALL_NARGS (fset, 2);
CASE_CALL_NARGS (get, 2);
CASE_CALL_NARGS (substring, 3);
case Bconcat2:
EMIT_SCRATCH_CALL_N ("Fconcat", 2);
break;
case Bconcat3:
EMIT_SCRATCH_CALL_N ("Fconcat", 3);
break;
case Bconcat4:
EMIT_SCRATCH_CALL_N ("Fconcat", 4);
break;
case BconcatN:
op = FETCH;
EMIT_SCRATCH_CALL_N ("Fconcat", op);
break;
case Bsub1:
{
gcc_jit_block *sub1_inline =
gcc_jit_function_new_block (comp.func, "-1 inline");
gcc_jit_block *sub1_fcall =
gcc_jit_function_new_block (comp.func, "-1 fcall");
gcc_jit_rvalue *tos_as_num =
gcc_jit_rvalue_access_field (gcc_jit_lvalue_as_rvalue (TOS),
NULL,
comp.lisp_obj_as_num);
comp_emit_comparison (GCC_JIT_COMPARISON_NE,
tos_as_num,
comp.most_negative_fixnum,
sub1_inline, sub1_fcall);
gcc_jit_rvalue *sub1_inline_res =
gcc_jit_context_new_binary_op (comp.ctxt,
NULL,
GCC_JIT_BINARY_OP_MINUS,
comp.lisp_obj_type,
tos_as_num,
comp.one);
gcc_jit_block_add_assignment (sub1_inline,
NULL,
TOS,
sub1_inline_res);
/* TODO fill sub1_fcall */
/* comp.bblock->gcc_bb = sub1_fcall; */
/* comp.bblock->terminated = false; */
gcc_jit_block_end_with_jump (sub1_inline, NULL,
bb_map[pc].gcc_bb);
gcc_jit_block_end_with_jump (sub1_fcall, NULL,
bb_map[pc].gcc_bb);
}
break;
case Badd1:
error ("Badd1 unsupported bytecode\n");
break;
case Beqlsign:
error ("Beqlsign unsupported bytecode\n");
break;
case Bgtr:
error ("Bgtr unsupported bytecode\n");
break;
case Blss:
error ("Blss unsupported bytecode\n");
break;
case Bleq:
error ("Bleq unsupported bytecode\n");
break;
case Bgeq:
error ("Bgeq unsupported bytecode\n");
break;
case Bdiff:
EMIT_SCRATCH_CALL_N ("Fminus", 2);
break;
case Bnegate:
error ("Bnegate unsupported bytecode\n");
break;
case Bplus:
EMIT_SCRATCH_CALL_N ("Fplus", 2);
break;
case Bmax:
EMIT_SCRATCH_CALL_N ("Fmax", 2);
break;
case Bmin:
EMIT_SCRATCH_CALL_N ("Fmin", 2);
break;
case Bmult:
EMIT_SCRATCH_CALL_N ("Ftimes", 2);
break;
case Bpoint:
error ("Bpoint unsupported bytecode\n");
break;
CASE_CALL_NARGS (goto_char, 1);
case Binsert:
EMIT_SCRATCH_CALL_N ("Finsert", 1);
break;
case Bpoint_max:
error ("Bpoint_max unsupported bytecode\n");
break;
case Bpoint_min:
error ("Bpoint_min unsupported bytecode\n");
break;
CASE_CALL_NARGS (char_after, 1);
CASE_CALL_NARGS (following_char, 0);
case Bpreceding_char:
res = comp_emit_call ("Fprevious_char", comp.lisp_obj_type, 0, args);
PUSH_LVAL (res);
break;
CASE_CALL_NARGS (current_column, 0);
case Bindent_to:
POP1;
args[1] = nil;
res = comp_emit_call ("Findent_to", comp.lisp_obj_type, 2, args);
PUSH_LVAL (res);
break;
CASE_CALL_NARGS (eolp, 0);
case Beobp:
error ("Beobp unsupported bytecode\n");
break;
CASE_CALL_NARGS (bolp, 0);
case Bbobp:
error ("Bbobp unsupported bytecode\n");
break;
CASE_CALL_NARGS (current_buffer, 0);
CASE_CALL_NARGS (set_buffer, 1);
case Bsave_current_buffer: /* Obsolete since ??. */
case Bsave_current_buffer_1:
comp_emit_call ("record_unwind_current_buffer",
comp.void_type, 0, NULL);
break;
case Binteractive_p: /* Obsolete since 24.1. */
PUSH_RVAL (comp_lisp_obj_as_ptr_from_ptr (comp.bblock,
intern ("interactive-p")));
res = comp_emit_call ("call0", comp.lisp_obj_type, 1, args);
PUSH_LVAL (res);
break;
CASE_CALL_NARGS (forward_char, 1);
CASE_CALL_NARGS (forward_word, 1);
CASE_CALL_NARGS (skip_chars_forward, 2);
CASE_CALL_NARGS (skip_chars_backward, 2);
CASE_CALL_NARGS (forward_line, 1);
CASE_CALL_NARGS (char_syntax, 1);
CASE_CALL_NARGS (buffer_substring, 2);
CASE_CALL_NARGS (delete_region, 2);
CASE_CALL_NARGS (narrow_to_region, 2);
CASE_CALL_NARGS (widen, 0);
CASE_CALL_NARGS (end_of_line, 1);
case Bconstant2:
goto do_constant;
break;
case Bgoto:
op = FETCH2;
gcc_jit_block_end_with_jump (comp.bblock->gcc_bb,
NULL,
bb_map[op].gcc_bb);
comp.bblock->terminated = true;
break;
case Bgotoifnil:
op = FETCH2;
POP1;
comp_emit_comparison (GCC_JIT_COMPARISON_EQ, args[0], nil,
bb_map[op].gcc_bb, bb_map[pc].gcc_bb);
break;
case Bgotoifnonnil:
op = FETCH2;
POP1;
comp_emit_comparison (GCC_JIT_COMPARISON_NE, args[0], nil,
bb_map[op].gcc_bb, bb_map[pc].gcc_bb);
break;
case Bgotoifnilelsepop:
op = FETCH2;
comp_emit_comparison (GCC_JIT_COMPARISON_EQ,
gcc_jit_lvalue_as_rvalue (TOS),
nil,
bb_map[op].gcc_bb, bb_map[pc].gcc_bb);
POP1;
break;
case Bgotoifnonnilelsepop:
op = FETCH2;
comp_emit_comparison (GCC_JIT_COMPARISON_NE,
gcc_jit_lvalue_as_rvalue (TOS),
nil,
bb_map[op].gcc_bb, bb_map[pc].gcc_bb);
POP1;
break;
case Breturn:
POP1;
gcc_jit_block_end_with_return(comp.bblock->gcc_bb,
NULL,
args[0]);
comp.bblock->terminated = true;
break;
case Bdiscard:
POP1;
break;
case Bdup:
PUSH_LVAL (TOS);
break;
case Bsave_excursion:
res = comp_emit_call ("record_unwind_protect_excursion",
comp.void_type, 0, args);
break;
case Bsave_window_excursion: /* Obsolete since 24.1. */
POP1;
res = comp_emit_call ("helper_save_window_excursion",
comp.lisp_obj_type, 1, args);
PUSH_LVAL (res);
break;
case Bsave_restriction:
args[0] = comp_lisp_obj_as_ptr_from_ptr (comp.bblock,
save_restriction_restore);
args[1] =
gcc_jit_lvalue_as_rvalue (comp_emit_call ("save_restriction_save",
comp.lisp_obj_type,
0,
NULL));
comp_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] = comp_lisp_obj_as_ptr_from_ptr (comp.bblock, eval_sub);
comp_emit_call ("internal_catch", comp.void_ptr_type, 3, args);
break;
case Bunwind_protect: /* FIXME: avoid closure for lexbind. */
POP1;
comp_emit_call ("helper_unwind_protect", comp.void_type, 1, args);
break;
case Bcondition_case: /* Obsolete since 24.4. */
POP3;
comp_emit_call ("internal_lisp_condition_case",
comp.lisp_obj_type, 3, args);
break;
case Btemp_output_buffer_setup: /* Obsolete since 24.1. */
POP1;
res = comp_emit_call ("helper_temp_output_buffer_setup", comp.lisp_obj_type,
1, args);
PUSH_LVAL (res);
break;
case Btemp_output_buffer_show: /* Obsolete since 24.1. */
POP2;
comp_emit_call ("temp_output_buffer_show", comp.void_type, 1,
&args[1]);
PUSH_RVAL (args[0]);
comp_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 Bset_marker:
error ("Bset_marker not supported");
break;
case Bmatch_beginning:
error ("Bmatch_beginning not supported");
break;
case Bmatch_end:
error ("Bmatch_end not supported");
break;
case Bupcase:
error ("Bupcase not supported");
break;
case Bdowncase:
error ("Bdowncase not supported");
break;
case Bstringeqlsign:
error ("Bstringeqlsign not supported");
break;
case Bstringlss:
error ("Bstringlss not supported");
break;
case Bequal:
error ("Bequal not supported");
break;
case Bnthcdr:
error ("Bnthcdr not supported");
break;
case Belt:
error ("Belt not supported");
break;
case Bmember:
error ("Bmember not supported");
break;
case Bassq:
error ("Bassq not supported");
break;
case Bnreverse:
error ("Bnreverse not supported");
break;
case Bsetcar:
error ("Bsetcar not supported");
break;
case Bsetcdr:
error ("Bsetcdr not supported");
break;
case Bcar_safe:
error ("Bcar_safe not supported");
break;
case Bcdr_safe:
error ("Bcdr_safe not supported");
break;
case Bnconc:
error ("Bnconc not supported");
break;
case Bquo:
error ("Bquo not supported");
break;
case Brem:
error ("Brem not supported");
break;
case Bnumberp:
error ("Bnumberp not supported");
break;
case Bintegerp:
error ("Bintegerp not supported");
break;
case BRgoto:
op = FETCH - 128;
op += pc;
gcc_jit_block_end_with_jump (comp.bblock->gcc_bb,
NULL,
bb_map[op].gcc_bb);
comp.bblock->terminated = true;
break;
case BRgotoifnil:
op = FETCH - 128;
op += pc;
POP1;
comp_emit_comparison (GCC_JIT_COMPARISON_EQ, args[0], nil,
bb_map[op].gcc_bb, bb_map[pc].gcc_bb);
break;
case BRgotoifnonnil:
op = FETCH - 128;
op += pc;
POP1;
comp_emit_comparison (GCC_JIT_COMPARISON_NE, args[0], nil,
bb_map[op].gcc_bb, bb_map[pc].gcc_bb);
break;
case BRgotoifnilelsepop:
op = FETCH - 128;
op += pc;
comp_emit_comparison (GCC_JIT_COMPARISON_EQ,
gcc_jit_lvalue_as_rvalue (TOS),
nil,
bb_map[op].gcc_bb, bb_map[pc].gcc_bb);
POP1;
break;
case BRgotoifnonnilelsepop:
op = FETCH - 128;
op += pc;
comp_emit_comparison (GCC_JIT_COMPARISON_NE,
gcc_jit_lvalue_as_rvalue (TOS),
nil,
bb_map[op].gcc_bb, bb_map[pc].gcc_bb);
POP1;
break;
case BinsertN:
error ("BinsertN not supported");
break;
case Bstack_set:
error ("Bstack_set not supported");
break;
case Bstack_set2:
error ("Bstack_set2 not supported");
break;
case BdiscardN:
error ("BdiscardN not supported");
break;
case Bswitch:
error ("Bswitch not supported");
/* 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 + vector_size)
goto fail;
op -= Bconstant;
do_constant:
/* See the Bswitch case for commentary. */
if (pc >= bytestr_length || bytestr_data[pc] != Bswitch)
{
gcc_jit_rvalue *c =
comp_lisp_obj_as_ptr_from_ptr (comp.bblock, vectorp[op]);
PUSH_RVAL (c);
/* Fprint(vectorp[op], Qnil); */
break;
}
/* We're compiling Bswitch instead. */
++pc;
break;
}
}
}
comp_res.gcc_res = gcc_jit_context_compile(comp.ctxt);
goto exit;
fail:
error ("Something went wrong");
exit:
/* if (nil_ret_bb) */
/* xfree (nil_ret_bb); */
xfree (stack_base);
xfree (bb_map);
return comp_res;
}
void
emacs_native_compile (const char *lisp_f_name, const char *c_f_name,
Lisp_Object func, bool dump_asm)
{
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 (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);
}
DEFUN ("native-compile", Fnative_compile, Snative_compile,
1, 2, 0,
doc: /* Compile as native code function FUNC and load it. */) /* FIXME doc */
(Lisp_Object func, 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;
}
func = indirect_function (func);
if (!COMPILEDP (func))
error ("Not a byte-compiled function");
emacs_native_compile (lisp_f_name, c_f_name, func, disassemble != Qnil);
if (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;
}
void
init_comp (void)
{
comp.ctxt = gcc_jit_context_acquire();
if (COMP_DEBUG > 1)
gcc_jit_context_dump_reproducer_to_file (comp.ctxt, "comp_reproducer.c");
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);
comp.int_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_INT);
comp.long_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_LONG);
comp.long_long_type = gcc_jit_context_get_type (comp.ctxt,
GCC_JIT_TYPE_LONG_LONG);
#if EMACS_INT_MAX <= LONG_MAX
/* 32-bit builds without wide ints, 64-bit builds on Posix hosts. */
comp.lisp_obj_as_ptr = gcc_jit_context_new_field (comp.ctxt,
NULL,
comp.void_ptr_type,
"obj");
comp.lisp_obj_as_num = gcc_jit_context_new_field (comp.ctxt,
NULL,
comp.long_long_type,
"num");
#else
/* 64-bit builds on MS-Windows, 32-bit builds with wide ints. */
comp.lisp_obj_as_ptr = gcc_jit_context_new_field (comp.ctxt,
NULL,
comp.long_long_type,
"obj");
comp.lisp_obj_as_num = gcc_jit_context_new_field (comp.ctxt,
NULL,
comp.long_long_type,
"num");
#endif
gcc_jit_field *lisp_obj_fields[2] = { comp.lisp_obj_as_ptr,
comp.lisp_obj_as_num };
comp.lisp_obj_type = gcc_jit_context_new_union_type (comp.ctxt,
NULL,
"LispObj",
2,
lisp_obj_fields);
comp.most_positive_fixnum =
gcc_jit_context_new_rvalue_from_long (comp.ctxt,
comp.long_long_type, /* FIXME? */
MOST_POSITIVE_FIXNUM);
comp.most_negative_fixnum =
gcc_jit_context_new_rvalue_from_long (comp.ctxt,
comp.long_long_type, /* FIXME? */
MOST_NEGATIVE_FIXNUM);
comp.one =
gcc_jit_context_new_rvalue_from_int (comp.ctxt,
comp.long_long_type, /* FIXME? */
1);
comp.inttypebits =
gcc_jit_context_new_rvalue_from_int (comp.ctxt,
comp.long_long_type, /* FIXME? */
INTTYPEBITS);
comp.lisp_int0 =
gcc_jit_context_new_rvalue_from_int (comp.ctxt,
comp.long_long_type, /* FIXME? */
Lisp_Int0);
enum gcc_jit_types ptrdiff_t_gcc;
if (sizeof (ptrdiff_t) == sizeof (int))
ptrdiff_t_gcc = GCC_JIT_TYPE_INT;
else if (sizeof (ptrdiff_t) == sizeof (long int))
ptrdiff_t_gcc = GCC_JIT_TYPE_LONG;
else if (sizeof (ptrdiff_t) == sizeof (long long int))
ptrdiff_t_gcc = GCC_JIT_TYPE_LONG_LONG;
else
eassert ("ptrdiff_t size not handled.");
comp.ptrdiff_type = gcc_jit_context_get_type(comp.ctxt, ptrdiff_t_gcc);
comp.scratch =
gcc_jit_lvalue_get_address(
gcc_jit_context_new_global (comp.ctxt, NULL,
GCC_JIT_GLOBAL_IMPORTED,
comp.lisp_obj_type,
"scratch_call_area"),
NULL);
comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt);
if (COMP_DEBUG) {
logfile = fopen ("libjit.log", "w");
gcc_jit_context_set_logfile (comp.ctxt,
logfile,
0, 0);
gcc_jit_context_set_bool_option (comp.ctxt,
GCC_JIT_BOOL_OPTION_DUMP_EVERYTHING,
1);
}
gcc_jit_context_set_bool_option (comp.ctxt,
GCC_JIT_BOOL_OPTION_KEEP_INTERMEDIATES,
1);
}
void
release_comp (void)
{
if (comp.ctxt)
gcc_jit_context_release(comp.ctxt);
if (logfile)
fclose (logfile);
}
void
syms_of_comp (void)
{
defsubr (&Snative_compile);
comp.func_hash = Qnil;
staticpro (&comp.func_hash);
}
/******************************************************************************/
/* Helper functions called from the runtime. */
/* These can't be statics till shared mechanism is used to solve relocations. */
/******************************************************************************/
Lisp_Object helper_save_window_excursion (Lisp_Object v1);
void helper_unwind_protect (Lisp_Object handler);
Lisp_Object helper_temp_output_buffer_setup (Lisp_Object x);
Lisp_Object helper_unbind_n (int val);
Lisp_Object
helper_save_window_excursion (Lisp_Object v1)
{
ptrdiff_t count1 = SPECPDL_INDEX ();
record_unwind_protect (restore_window_configuration,
Fcurrent_window_configuration (Qnil));
v1 = Fprogn (v1);
unbind_to (count1, v1);
return v1;
}
void helper_unwind_protect (Lisp_Object handler)
{
/* Support for a function here is new in 24.4. */
record_unwind_protect (FUNCTIONP (handler) ? bcall0 : prog_ignore,
handler);
}
Lisp_Object
helper_temp_output_buffer_setup (Lisp_Object x)
{
CHECK_STRING (x);
temp_output_buffer_setup (SSDATA (x));
return Vstandard_output;
}
Lisp_Object
helper_unbind_n (int val)
{
return unbind_to (SPECPDL_INDEX () - val, Qnil);
}
#endif /* HAVE_LIBJIT */
Reference in a new issue View git blame Copy permalink