mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

Add instrumentation to VM builtins

Browse source 
* libguile/intrinsics.h: Add "intrinsic" for handle-interrupts code.
  Unlike the other intrinsics, this one isn't a function.
* libguile/programs.c (try_parse_arity): Add cases for instructions used
  in VM builtins.
  (scm_primitive_call_ip): Return #f if call-ip not found.
* libguile/vm-engine.c (handle-interrupts): Get code from intrinsics.
* libguile/vm.c
* libguile/vm.c (instrumented_code, define_vm_builtins): Add
  instrumentation to the builtins, so that they can be JIT-compiled.
  (INIT_BUILTIN): Remove min-arity setting; the fallback min-arity
  interpreter should figure it out.
  (scm_bootstrap_vm): Call the new define_vm_builtins function.
* libguile/gsubr.c (primitive_call_ip): Return 0 if call IP not found.
  (primitive_subr_idx): Interpret call ip == 0 as not-a-subr.
* module/system/vm/program.scm (program-arguments-alist): Allow a #f
  call-ip.
This commit is contained in:
Andy Wingo 2018-08-17 08:15:04 +02:00
parent e6304fb242
commit 3827769aff
6 changed files with 97 additions and 63 deletions
Download patch file Download diff file Expand all files Collapse all files

7
libguile/gsubr.c
View file

@ -400,7 +400,7 @@ primitive_call_ip (const uint32_t *code)
code -= 1;
break;
default:
abort ();
return 0;
}
}
}
@ -410,8 +410,11 @@ static const uint32_t NOT_A_SUBR_CALL = 0xffffffff;
static uint32_t
primitive_subr_idx (const uint32_t *code)
{
uint32_t word;
uintptr_t call_ip = primitive_call_ip (code);
uint32_t word = ((uint32_t *) call_ip)[0];
if (call_ip == 0)
return NOT_A_SUBR_CALL;
word = ((uint32_t *) call_ip)[0];
if ((word & 0xff) == scm_op_subr_call)
{
uint32_t idx = word >> 8;

2
libguile/intrinsics.h
View file

@ -92,6 +92,7 @@ typedef SCM (*scm_t_scm_from_ptr_intrinsic) (SCM*);
typedef void (*scm_t_ptr_scm_intrinsic) (SCM*, SCM);
typedef SCM (*scm_t_scm_from_ptr_scm_intrinsic) (SCM*, SCM);
typedef SCM (*scm_t_scm_from_ptr_scm_scm_intrinsic) (SCM*, SCM, SCM);
typedef uint32_t* scm_t_vcode_intrinsic;
#define SCM_FOR_ALL_VM_INTRINSICS(M) \
M(scm_from_scm_scm, add, "add", ADD) \
@ -167,6 +168,7 @@ typedef SCM (*scm_t_scm_from_ptr_scm_scm_intrinsic) (SCM*, SCM, SCM);
M(ptr_scm, atomic_set_scm, "atomic-set-scm", ATOMIC_SET_SCM) \
M(scm_from_ptr_scm, atomic_swap_scm, "atomic-swap-scm", ATOMIC_SWAP_SCM) \
M(scm_from_ptr_scm_scm, atomic_compare_and_swap_scm, "atomic-compare-and-swap-scm", ATOMIC_COMPARE_AND_SWAP_SCM) \
M(vcode, handle_interrupt_code, "%handle-interrupt-code", HANDLE_INTERRUPT_CODE) \
/* Add new intrinsics here; also update scm_bootstrap_intrinsics. */
enum scm_vm_intrinsic

12
libguile/programs.c
View file

@ -172,9 +172,12 @@ SCM_DEFINE (scm_primitive_call_ip, "primitive-call-ip", 1, 0, 0,
"")
#define FUNC_NAME s_scm_primitive_call_ip
{
uintptr_t ip;
SCM_MAKE_VALIDATE (1, prim, PRIMITIVE_P);
return scm_from_uintptr_t (scm_i_primitive_call_ip (prim));
ip = scm_i_primitive_call_ip (prim);
return ip ? scm_from_uintptr_t (ip) : SCM_BOOL_F;
}
#undef FUNC_NAME
@ -312,11 +315,18 @@ try_parse_arity (SCM program, int *req, int *opt, int *rest)
*opt = slots - min;
*rest = 1;
return 1;
case scm_op_shuffle_down:
case scm_op_abort:
*req = min - 1;
*opt = 0;
*rest = 1;
return 1;
default:
return 0;
}
case scm_op_continuation_call:
case scm_op_compose_continuation:
case scm_op_shuffle_down:
*req = 0;
*opt = 0;
*rest = 1;

2
libguile/vm-engine.c
View file

@ -2385,7 +2385,7 @@ VM_NAME (scm_thread *thread)
SYNC_IP ();
CALL_INTRINSIC (push_interrupt_frame, (thread, 0));
CACHE_SP ();
ip = (uint32_t *) vm_handle_interrupt_code;
ip = scm_vm_intrinsics.handle_interrupt_code;
NEXT (0);
}

135
libguile/vm.c
View file

@ -300,60 +300,17 @@ vm_error_bad_instruction (uint32_t inst)
static SCM vm_boot_continuation;
static SCM vm_builtin_apply;
static SCM vm_builtin_values;
static SCM vm_builtin_abort_to_prompt;
static SCM vm_builtin_call_with_values;
static SCM vm_builtin_call_with_current_continuation;
#define DECLARE_BUILTIN(builtin, BUILTIN, req, opt, rest) \
static SCM vm_builtin_##builtin; \
static uint32_t *vm_builtin_##builtin##_code;
FOR_EACH_VM_BUILTIN (DECLARE_BUILTIN)
#undef DECLARE_BUILTIN
static const uint32_t vm_boot_continuation_code[] = {
SCM_PACK_OP_24 (halt, 0)
};
static const uint32_t vm_builtin_apply_code[] = {
SCM_PACK_OP_24 (assert_nargs_ge, 3),
SCM_PACK_OP_12_12 (shuffle_down, 1, 0),
SCM_PACK_OP_24 (expand_apply_argument, 0),
SCM_PACK_OP_24 (tail_call, 0),
};
static const uint32_t vm_builtin_values_code[] = {
SCM_PACK_OP_12_12 (shuffle_down, 1, 0),
SCM_PACK_OP_24 (return_values, 0)
};
static const uint32_t vm_builtin_abort_to_prompt_code[] = {
SCM_PACK_OP_24 (assert_nargs_ge, 2),
SCM_PACK_OP_24 (abort, 0), /* tag in r1, vals from r2 */
/* FIXME: Partial continuation should capture caller regs. */
SCM_PACK_OP_24 (return_values, 0) /* vals from r0 */
};
static const uint32_t vm_builtin_call_with_values_code[] = {
SCM_PACK_OP_24 (assert_nargs_ee, 3),
SCM_PACK_OP_24 (alloc_frame, 8),
SCM_PACK_OP_12_12 (mov, 0, 6),
SCM_PACK_OP_24 (call, 7), SCM_PACK_OP_ARG_8_24 (0, 1),
SCM_PACK_OP_24 (long_fmov, 0), SCM_PACK_OP_ARG_8_24 (0, 2),
SCM_PACK_OP_12_12 (shuffle_down, 7, 1),
SCM_PACK_OP_24 (tail_call, 0)
};
static const uint32_t vm_builtin_call_with_current_continuation_code[] = {
SCM_PACK_OP_24 (assert_nargs_ee, 2),
SCM_PACK_OP_12_12 (mov, 1, 0),
SCM_PACK_OP_24 (capture_continuation, 0),
SCM_PACK_OP_24 (tail_call, 0)
};
static const uint32_t vm_handle_interrupt_code[] = {
SCM_PACK_OP_24 (alloc_frame, 4),
SCM_PACK_OP_12_12 (mov, 0, 3),
SCM_PACK_OP_24 (call, 3), SCM_PACK_OP_ARG_8_24 (0, 1),
SCM_PACK_OP_24 (return_from_interrupt, 0)
};
int
scm_i_vm_is_boot_continuation_code (uint32_t *ip)
{
@ -423,6 +380,75 @@ scm_init_vm_builtins (void)
scm_vm_builtin_index_to_name);
}
static uint32_t*
instrumented_code (const uint32_t *code, size_t byte_size)
{
uint32_t *ret, *write;
ret = scm_i_alloc_primitive_code_with_instrumentation (byte_size / 4, &write);
memcpy (write, code, byte_size);
return ret;
}
static void
define_vm_builtins (void)
{
const uint32_t apply_code[] = {
SCM_PACK_OP_24 (assert_nargs_ge, 3),
SCM_PACK_OP_12_12 (shuffle_down, 1, 0),
SCM_PACK_OP_24 (expand_apply_argument, 0),
SCM_PACK_OP_24 (tail_call, 0),
};
const uint32_t values_code[] = {
SCM_PACK_OP_12_12 (shuffle_down, 1, 0),
SCM_PACK_OP_24 (return_values, 0)
};
const uint32_t abort_to_prompt_code[] = {
SCM_PACK_OP_24 (assert_nargs_ge, 2),
SCM_PACK_OP_24 (abort, 0), /* tag in r1, vals from r2 */
/* FIXME: Partial continuation should capture caller regs. */
SCM_PACK_OP_24 (return_values, 0) /* vals from r0 */
};
const uint32_t call_with_values_code[] = {
SCM_PACK_OP_24 (assert_nargs_ee, 3),
SCM_PACK_OP_24 (alloc_frame, 8),
SCM_PACK_OP_12_12 (mov, 0, 6),
SCM_PACK_OP_24 (call, 7), SCM_PACK_OP_ARG_8_24 (0, 1),
SCM_PACK_OP_24 (long_fmov, 0), SCM_PACK_OP_ARG_8_24 (0, 2),
SCM_PACK_OP_12_12 (shuffle_down, 7, 1),
SCM_PACK_OP_24 (tail_call, 0)
};
const uint32_t call_with_current_continuation_code[] = {
SCM_PACK_OP_24 (assert_nargs_ee, 2),
SCM_PACK_OP_12_12 (mov, 1, 0),
SCM_PACK_OP_24 (capture_continuation, 0),
SCM_PACK_OP_24 (tail_call, 0)
};
/* This one isn't exactly a builtin but we still handle it here. */
const uint32_t handle_interrupt_code[] = {
SCM_PACK_OP_24 (alloc_frame, 4),
SCM_PACK_OP_12_12 (mov, 0, 3),
SCM_PACK_OP_24 (call, 3), SCM_PACK_OP_ARG_8_24 (0, 1),
SCM_PACK_OP_24 (return_from_interrupt, 0)
};
#define DEFINE_BUILTIN(builtin, BUILTIN, req, opt, rest) \
{ \
size_t sz = sizeof (builtin##_code); \
vm_builtin_##builtin##_code = instrumented_code (builtin##_code, sz); \
vm_builtin_##builtin = scm_i_make_program (vm_builtin_##builtin##_code); \
}
FOR_EACH_VM_BUILTIN (DEFINE_BUILTIN);
#undef INDEX_TO_NAME
scm_vm_intrinsics.handle_interrupt_code =
instrumented_code (handle_interrupt_code, sizeof (handle_interrupt_code));
}
SCM
scm_i_call_with_current_continuation (SCM proc)
{
@ -1701,11 +1727,7 @@ scm_init_vm_builtin_properties (void)
#define INIT_BUILTIN(builtin, BUILTIN, req, opt, rest) \
scm_set_procedure_property_x (vm_builtin_##builtin, scm_sym_name, \
scm_sym_##builtin); \
scm_set_procedure_minimum_arity_x (vm_builtin_##builtin, \
SCM_I_MAKINUM (req), \
SCM_I_MAKINUM (opt), \
scm_from_bool (rest));
scm_sym_##builtin);
FOR_EACH_VM_BUILTIN (INIT_BUILTIN);
#undef INIT_BUILTIN
}
@ -1748,10 +1770,7 @@ scm_bootstrap_vm (void)
(SCM_CELL_WORD_0 (vm_boot_continuation)
| SCM_F_PROGRAM_IS_BOOT));
#define DEFINE_BUILTIN(builtin, BUILTIN, req, opt, rest) \
vm_builtin_##builtin = scm_i_make_program (vm_builtin_##builtin##_code);
FOR_EACH_VM_BUILTIN (DEFINE_BUILTIN);
#undef DEFINE_BUILTIN
define_vm_builtins ();
}
void

2
module/system/vm/program.scm
View file

@ -204,7 +204,7 @@ of integers."
((nreq nopt rest?)
(let ((start (primitive-call-ip prog)))
;; Assume that there is only one IP for the call.
(and (or (not ip) (= start ip))
(and (or (not ip) (and start (= start ip)))
(arity->arguments-alist
prog
(list 0 0 nreq nopt rest? '(#f . ()))))))))