mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 14:50:19 +02:00
Code Activity

RTL: Local 0 is the procedure

Browse source 
* libguile/vm-engine.c: Change the RTL VM to number the procedure as
  local 0, and other locals from 1.  In the future we will want the FP
  to point to local 0 instead of local 1.  In the future also we can
  elide the procedure for well-known closures (closures in which all
  references are known call sites).
  (make_closure, free_set): Instead of taking rest arguments, we add a
  new free-set! op that initializes closures.
  (free_ref): Take the closure as an argument.

* libguile/vm.c (rtl_boot_continuation_code): Remove comments, which
  were out of date.
  (rtl_apply_code, rtl_values_code): Update comments.

* module/system/vm/assembler.scm (intern-constant, emit-init-constants):
  Adapt to locals numbering change.
  (begin-kw-arity): For assert-nargs-ee purposes, nreq includes the
  procedure.

* module/system/vm/disassembler.scm (code-annotation): Adapt annotation
  for assert-nargs-ee/locals.

* test-suite/tests/rtl.test: Adapt tests.
This commit is contained in:
Andy Wingo 2013-07-20 20:05:13 +02:00
parent 2a294c7cd3
commit 7396d21670
5 changed files with 208 additions and 204 deletions
Download patch file Download diff file Expand all files Collapse all files

148
libguile/vm-engine.c
View file

@ -486,7 +486,6 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
#undef ALIGNED_P #undef ALIGNED_P
#undef CACHE_REGISTER #undef CACHE_REGISTER
#undef CHECK_OVERFLOW #undef CHECK_OVERFLOW
#undef FREE_VARIABLE_REF
#undef FUNC2 #undef FUNC2
#undef INIT #undef INIT
#undef INUM_MAX #undef INUM_MAX
@ -519,6 +518,9 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
relative to the current virtual machine. At some point it will relative to the current virtual machine. At some point it will
become "the" virtual machine, and we'll delete this paragraph. As become "the" virtual machine, and we'll delete this paragraph. As
such, the rest of the comments speak as if there's only one VM. such, the rest of the comments speak as if there's only one VM.
In difference from the old VM, local 0 is the procedure, and the
first argument is local 1. At some point in the future we should
change the fp to point to the procedure and not to local 1.
<more overview here> <more overview here>
*/ */
@ -554,12 +556,12 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
} while (0) } while (0)
/* Reserve stack space for a frame. Will check that there is sufficient /* Reserve stack space for a frame. Will check that there is sufficient
stack space for N locals, not including the procedure, in addition to stack space for N locals, including the procedure, in addition to
4 words to set up the next frame. Invoke after preparing the new 3 words to set up the next frame. Invoke after preparing the new
frame and setting the fp and ip. */ frame and setting the fp and ip. */
#define ALLOC_FRAME(n) \ #define ALLOC_FRAME(n) \
do { \ do { \
SCM *new_sp = vp->sp = fp - 1 + n; \ SCM *new_sp = vp->sp = fp - 1 + n - 1; \
CHECK_OVERFLOW (new_sp + 4); \ CHECK_OVERFLOW (new_sp + 4); \
} while (0) } while (0)
@ -567,13 +569,14 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
stack expansion is needed. */ stack expansion is needed. */
#define RESET_FRAME(n) \ #define RESET_FRAME(n) \
do { \ do { \
vp->sp = fp - 1 + n; \ vp->sp = fp - 2 + n; \
} while (0) } while (0)
/* Compute the number of locals in the frame. This is equal to the /* Compute the number of locals in the frame. This is equal to the
number of actual arguments when a function is first called. */ number of actual arguments when a function is first called, plus
one for the function. */
#define FRAME_LOCALS_COUNT() \ #define FRAME_LOCALS_COUNT() \
(vp->sp + 1 - fp) (vp->sp + 1 - (fp - 1))
/* Restore registers after returning from a frame. */ /* Restore registers after returning from a frame. */
#define RESTORE_FRAME() \ #define RESTORE_FRAME() \
@ -624,13 +627,12 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
case opcode: case opcode:
#endif #endif
#define LOCAL_REF(i) SCM_FRAME_VARIABLE (fp, i) #define LOCAL_REF(i) SCM_FRAME_VARIABLE (fp, (i) - 1)
#define LOCAL_SET(i,o) SCM_FRAME_VARIABLE (fp, i) = o #define LOCAL_SET(i,o) SCM_FRAME_VARIABLE (fp, (i) - 1) = o
#define VARIABLE_REF(v) SCM_VARIABLE_REF (v) #define VARIABLE_REF(v) SCM_VARIABLE_REF (v)
#define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o) #define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o)
#define VARIABLE_BOUNDP(v) (!scm_is_eq (VARIABLE_REF (v), SCM_UNDEFINED)) #define VARIABLE_BOUNDP(v) (!scm_is_eq (VARIABLE_REF (v), SCM_UNDEFINED))
#define FREE_VARIABLE_REF(i) SCM_RTL_PROGRAM_FREE_VARIABLE_REF (SCM_FRAME_PROGRAM (fp), i)
#define RETURN_ONE_VALUE(ret) \ #define RETURN_ONE_VALUE(ret) \
do { \ do { \
@ -654,7 +656,7 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
fp[-1] = rtl_apply; \ fp[-1] = rtl_apply; \
fp[0] = rtl_values; \ fp[0] = rtl_values; \
fp[1] = vals; \ fp[1] = vals; \
RESET_FRAME (2); \ RESET_FRAME (3); \
ip = (scm_t_uint32 *) rtl_apply_code; \ ip = (scm_t_uint32 *) rtl_apply_code; \
goto op_apply; \ goto op_apply; \
} while (0) } while (0)
@ -879,7 +881,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
base[6] = SCM_PACK (ip); /* ra */ base[6] = SCM_PACK (ip); /* ra */
base[7] = program; base[7] = program;
fp = vp->fp = &base[8]; fp = vp->fp = &base[8];
RESET_FRAME (nargs_); RESET_FRAME (nargs_ + 1);
} }
apply: apply:
@ -902,7 +904,6 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
vp->sp++; vp->sp++;
while (n--) while (n--)
LOCAL_SET (n + 1, LOCAL_REF (n)); LOCAL_SET (n + 1, LOCAL_REF (n));
LOCAL_SET (0, proc);
fp[-1] = SCM_SMOB_DESCRIPTOR (proc).apply_trampoline; fp[-1] = SCM_SMOB_DESCRIPTOR (proc).apply_trampoline;
continue; continue;
@ -914,7 +915,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
SCM ret; SCM ret;
SYNC_ALL (); SYNC_ALL ();
ret = VM_NAME (vm, fp[-1], fp, FRAME_LOCALS_COUNT ()); ret = VM_NAME (vm, fp[-1], fp, FRAME_LOCALS_COUNT () - 1);
if (SCM_UNLIKELY (SCM_VALUESP (ret))) if (SCM_UNLIKELY (SCM_VALUESP (ret)))
RETURN_VALUE_LIST (scm_struct_ref (ret, SCM_INUM0)); RETURN_VALUE_LIST (scm_struct_ref (ret, SCM_INUM0));
@ -938,11 +939,11 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
/* halt _:24 /* halt _:24
* *
* Bring the VM to a halt, returning the single value from r0. * Bring the VM to a halt, returning the single value from slot 1.
*/ */
VM_DEFINE_OP (0, halt, "halt", OP1 (U8_X24)) VM_DEFINE_OP (0, halt, "halt", OP1 (U8_X24))
{ {
SCM ret = LOCAL_REF (0); SCM ret = LOCAL_REF (1);
vp->ip = SCM_FRAME_RETURN_ADDRESS (fp); vp->ip = SCM_FRAME_RETURN_ADDRESS (fp);
vp->sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1; vp->sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
@ -953,20 +954,18 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
/* halt/values _:24 /* halt/values _:24
* *
* Bring the VM to a halt, returning all the values on the stack. * Bring the VM to a halt, returning all the values from the MV stack.
*/ */
VM_DEFINE_OP (1, halt_values, "halt/values", OP1 (U8_X24)) VM_DEFINE_OP (1, halt_values, "halt/values", OP1 (U8_X24))
{ {
scm_t_ptrdiff n; scm_t_ptrdiff n;
SCM *base;
SCM ret = SCM_EOL; SCM ret = SCM_EOL;
SYNC_BEFORE_GC(); SYNC_BEFORE_GC();
base = fp + 4; /* Boot closure in r0, empty stack from r1 to r4, values from r5. */
n = FRAME_LOCALS_COUNT (); for (n = FRAME_LOCALS_COUNT () - 1; n >= 5; n--)
while (n--) ret = scm_cons (LOCAL_REF (n), ret);
ret = scm_cons (base[n], ret);
vp->ip = SCM_FRAME_RETURN_ADDRESS (fp); vp->ip = SCM_FRAME_RETURN_ADDRESS (fp);
vp->sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1; vp->sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
@ -998,15 +997,15 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
VM_HANDLE_INTERRUPTS; VM_HANDLE_INTERRUPTS;
fp = vp->fp = old_fp + from + 4; fp = vp->fp = old_fp + from + 3;
SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp); SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp);
SCM_FRAME_SET_RTL_MV_RETURN_ADDRESS (fp, ip + 3 + nargs); SCM_FRAME_SET_RTL_MV_RETURN_ADDRESS (fp, ip + 3 + nargs);
SCM_FRAME_SET_RTL_RETURN_ADDRESS (fp, ip + 4 + nargs); SCM_FRAME_SET_RTL_RETURN_ADDRESS (fp, ip + 4 + nargs);
fp[-1] = old_fp[proc]; fp[-1] = old_fp[proc - 1];
ALLOC_FRAME (nargs); ALLOC_FRAME (nargs + 1);
for (n = 0; n < nargs; n++) for (n = 0; n < nargs; n++)
LOCAL_SET (n, old_fp[ip[3 + n]]); LOCAL_SET (n + 1, old_fp[ip[3 + n] - 1]);
PUSH_CONTINUATION_HOOK (); PUSH_CONTINUATION_HOOK ();
APPLY_HOOK (); APPLY_HOOK ();
@ -1041,7 +1040,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp); SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp);
SCM_FRAME_SET_RTL_MV_RETURN_ADDRESS (fp, ip + 2); SCM_FRAME_SET_RTL_MV_RETURN_ADDRESS (fp, ip + 2);
SCM_FRAME_SET_RTL_RETURN_ADDRESS (fp, ip + 3); SCM_FRAME_SET_RTL_RETURN_ADDRESS (fp, ip + 3);
fp[-1] = old_fp[proc]; fp[-1] = old_fp[proc - 1];
PUSH_CONTINUATION_HOOK (); PUSH_CONTINUATION_HOOK ();
APPLY_HOOK (); APPLY_HOOK ();
@ -1070,7 +1069,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
fp[-1] = LOCAL_REF (proc); fp[-1] = LOCAL_REF (proc);
/* No need to check for overflow, as the compiler has already /* No need to check for overflow, as the compiler has already
ensured that this frame has enough space. */ ensured that this frame has enough space. */
RESET_FRAME (nargs); RESET_FRAME (nargs + 1);
APPLY_HOOK (); APPLY_HOOK ();
@ -1103,7 +1102,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
{ {
scm_t_uint32 nargs; scm_t_uint32 nargs;
SCM_UNPACK_RTL_24 (op, nargs); SCM_UNPACK_RTL_24 (op, nargs);
RESET_FRAME (nargs); RESET_FRAME (nargs + 1);
fp[-1] = rtl_values; fp[-1] = rtl_values;
goto op_values; goto op_values;
} }
@ -1130,7 +1129,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
SCM_UNPACK_RTL_24 (op, ptr_idx); SCM_UNPACK_RTL_24 (op, ptr_idx);
pointer = FREE_VARIABLE_REF (ptr_idx); pointer = SCM_RTL_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), ptr_idx);
subr = SCM_POINTER_VALUE (pointer); subr = SCM_POINTER_VALUE (pointer);
VM_HANDLE_INTERRUPTS; VM_HANDLE_INTERRUPTS;
@ -1195,12 +1194,13 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
VM_DEFINE_OP (8, foreign_call, "foreign-call", OP1 (U8_U12_U12)) VM_DEFINE_OP (8, foreign_call, "foreign-call", OP1 (U8_U12_U12))
{ {
scm_t_uint16 cif_idx, ptr_idx; scm_t_uint16 cif_idx, ptr_idx;
SCM cif, pointer, ret; SCM closure, cif, pointer, ret;
SCM_UNPACK_RTL_12_12 (op, cif_idx, ptr_idx); SCM_UNPACK_RTL_12_12 (op, cif_idx, ptr_idx);
cif = FREE_VARIABLE_REF (cif_idx); closure = LOCAL_REF (0);
pointer = FREE_VARIABLE_REF (ptr_idx); cif = SCM_RTL_PROGRAM_FREE_VARIABLE_REF (closure, cif_idx);
pointer = SCM_RTL_PROGRAM_FREE_VARIABLE_REF (closure, ptr_idx);
SYNC_IP (); SYNC_IP ();
VM_HANDLE_INTERRUPTS; VM_HANDLE_INTERRUPTS;
@ -1232,7 +1232,8 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
SCM_UNPACK_RTL_24 (op, contregs_idx); SCM_UNPACK_RTL_24 (op, contregs_idx);
contregs = FREE_VARIABLE_REF (contregs_idx); contregs =
SCM_RTL_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), contregs_idx);
SYNC_IP (); SYNC_IP ();
scm_i_check_continuation (contregs); scm_i_check_continuation (contregs);
@ -1296,15 +1297,15 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
ALLOC_FRAME (nargs); ALLOC_FRAME (nargs);
for (i = 0; i < list_idx; i++) for (i = 0; i < list_idx; i++)
fp[i - 1] = fp[i]; LOCAL_SET(i - 1, LOCAL_REF (i));
/* Null out these slots, just in case there are less than 2 elements /* Null out these slots, just in case there are less than 2 elements
in the list. */ in the list. */
fp[list_idx - 1] = SCM_UNDEFINED; LOCAL_SET (list_idx - 1, SCM_UNDEFINED);
fp[list_idx] = SCM_UNDEFINED; LOCAL_SET (list_idx, SCM_UNDEFINED);
for (i = 0; i < list_len; i++, list = SCM_CDR (list)) for (i = 0; i < list_len; i++, list = SCM_CDR (list))
fp[list_idx - 1 + i] = SCM_CAR (list); LOCAL_SET (list_idx - 1 + i, SCM_CAR (list));
APPLY_HOOK (); APPLY_HOOK ();
@ -1342,7 +1343,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
fp[-1] = fp[0]; fp[-1] = fp[0];
fp[0] = cont; fp[0] = cont;
RESET_FRAME (1); RESET_FRAME (2);
APPLY_HOOK (); APPLY_HOOK ();
@ -1366,7 +1367,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
{ {
SCM *base = fp; SCM *base = fp;
#if VM_USE_HOOKS #if VM_USE_HOOKS
int nargs = FRAME_LOCALS_COUNT (); int nargs = FRAME_LOCALS_COUNT () - 1;
#endif #endif
/* We don't do much; it's the caller that's responsible for /* We don't do much; it's the caller that's responsible for
@ -1451,7 +1452,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* *
* Ensure that there is space on the stack for NLOCALS local variables, * Ensure that there is space on the stack for NLOCALS local variables,
* setting them all to SCM_UNDEFINED, except those nargs values that * setting them all to SCM_UNDEFINED, except those nargs values that
* were passed as arguments. * were passed as arguments and procedure.
*/ */
VM_DEFINE_OP (20, reserve_locals, "reserve-locals", OP1 (U8_U24)) VM_DEFINE_OP (20, reserve_locals, "reserve-locals", OP1 (U8_U24))
{ {
@ -1898,27 +1899,14 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
NEXT (1); NEXT (1);
} }
/* free-ref dst:12 src:12 /* make-closure dst:24 offset:32 _:8 nfree:24
*
* Load free variable SRC into local slot DST.
*/
VM_DEFINE_OP (47, free_ref, "free-ref", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst, src;
SCM_UNPACK_RTL_12_12 (op, dst, src);
CHECK_FREE_VARIABLE (src);
LOCAL_SET (dst, FREE_VARIABLE_REF (src));
NEXT (1);
}
/* make-closure dst:24 offset:32 _:8 nfree:24 free0:24 0:8 ...
* *
* Make a new closure, and write it to DST. The code for the closure * Make a new closure, and write it to DST. The code for the closure
* will be found at OFFSET words from the current IP. OFFSET is a * will be found at OFFSET words from the current IP. OFFSET is a
* signed 32-bit integer. The registers for the NFREE free variables * signed 32-bit integer. Space for NFREE free variables will be
* follow. * allocated.
*/ */
VM_DEFINE_OP (48, make_closure, "make-closure", OP3 (U8_U24, L32, X8_R24) | OP_DST) VM_DEFINE_OP (47, make_closure, "make-closure", OP3 (U8_U24, L32, X8_U24) | OP_DST)
{ {
scm_t_uint32 dst, nfree, n; scm_t_uint32 dst, nfree, n;
scm_t_int32 offset; scm_t_int32 offset;
@ -1931,31 +1919,41 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
// FIXME: Assert range of nfree? // FIXME: Assert range of nfree?
closure = scm_words (scm_tc7_rtl_program | (nfree << 16), nfree + 2); closure = scm_words (scm_tc7_rtl_program | (nfree << 16), nfree + 2);
SCM_SET_CELL_WORD_1 (closure, ip + offset); SCM_SET_CELL_WORD_1 (closure, ip + offset);
// FIXME: Elide these initializations?
for (n = 0; n < nfree; n++) for (n = 0; n < nfree; n++)
SCM_RTL_PROGRAM_FREE_VARIABLE_SET (closure, n, LOCAL_REF (ip[n + 3])); SCM_RTL_PROGRAM_FREE_VARIABLE_SET (closure, n, SCM_BOOL_F);
LOCAL_SET (dst, closure); LOCAL_SET (dst, closure);
NEXT (nfree + 3); NEXT (3);
} }
/* fix-closure dst:24 _:8 nfree:24 free0:24 0:8 ... /* free-ref dst:12 src:12 _:8 idx:24
* *
* "Fix" a closure. This is used for lambda expressions bound in a * Load free variable IDX from the closure SRC into local slot DST.
* <fix>, but which are not always called in tail position. In that
* case we allocate the closures first, then destructively update their
* free variables to point to each other. NFREE and the locals FREE0...
* are as in make-closure.
*/ */
VM_DEFINE_OP (49, fix_closure, "fix-closure", OP2 (U8_U24, X8_R24)) VM_DEFINE_OP (48, free_ref, "free-ref", OP2 (U8_U12_U12, X8_U24) | OP_DST)
{ {
scm_t_uint32 dst, nfree, n; scm_t_uint16 dst, src;
SCM closure; scm_t_uint32 idx;
SCM_UNPACK_RTL_12_12 (op, dst, src);
SCM_UNPACK_RTL_24 (ip[1], idx);
/* CHECK_FREE_VARIABLE (src); */
LOCAL_SET (dst, SCM_RTL_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (src), idx));
NEXT (2);
}
SCM_UNPACK_RTL_24 (op, dst); /* free-set! dst:12 src:12 _8 idx:24
SCM_UNPACK_RTL_24 (ip[1], nfree); *
closure = LOCAL_REF (dst); * Set free variable IDX from the closure DST to SRC.
for (n = 0; n < nfree; n++) */
SCM_RTL_PROGRAM_FREE_VARIABLE_SET (closure, n, LOCAL_REF (ip[n + 2])); VM_DEFINE_OP (49, free_set, "free-set!", OP2 (U8_U12_U12, X8_U24))
NEXT (nfree + 2); {
scm_t_uint16 dst, src;
scm_t_uint32 idx;
SCM_UNPACK_RTL_12_12 (op, dst, src);
SCM_UNPACK_RTL_24 (ip[1], idx);
/* CHECK_FREE_VARIABLE (src); */
SCM_RTL_PROGRAM_FREE_VARIABLE_SET (LOCAL_REF (dst), idx, LOCAL_REF (src));
NEXT (2);
} }

8
libguile/vm.c
View file

@ -599,8 +599,8 @@ static SCM rtl_apply;
static SCM rtl_values; static SCM rtl_values;
static const scm_t_uint32 rtl_boot_continuation_code[] = { static const scm_t_uint32 rtl_boot_continuation_code[] = {
SCM_PACK_RTL_24 (scm_rtl_op_halt_values, 0), /* empty stack frame in r0-r2, results from r3 */ SCM_PACK_RTL_24 (scm_rtl_op_halt_values, 0),
SCM_PACK_RTL_24 (scm_rtl_op_halt, 0) /* result in r0 */ SCM_PACK_RTL_24 (scm_rtl_op_halt, 0)
}; };
static scm_t_uint32* rtl_boot_multiple_value_continuation_code = static scm_t_uint32* rtl_boot_multiple_value_continuation_code =
@ -610,11 +610,11 @@ static scm_t_uint32* rtl_boot_single_value_continuation_code =
(scm_t_uint32 *) rtl_boot_continuation_code + 1; (scm_t_uint32 *) rtl_boot_continuation_code + 1;
static const scm_t_uint32 rtl_apply_code[] = { static const scm_t_uint32 rtl_apply_code[] = {
SCM_PACK_RTL_24 (scm_rtl_op_apply, 0) /* proc in r0, args from r1, nargs set */ SCM_PACK_RTL_24 (scm_rtl_op_apply, 0) /* proc in r1, args from r2, nargs set */
}; };
static const scm_t_uint32 rtl_values_code[] = { static const scm_t_uint32 rtl_values_code[] = {
SCM_PACK_RTL_24 (scm_rtl_op_values, 0) /* vals from r0 */ SCM_PACK_RTL_24 (scm_rtl_op_values, 0) /* vals from r1 */
}; };

43
module/system/vm/assembler.scm
View file

@ -525,9 +525,9 @@ table, its existing label is used directly."
(let ((src (recur obj))) (let ((src (recur obj)))
(if src (if src
(list (if (statically-allocatable? obj) (list (if (statically-allocatable? obj)
`(make-non-immediate 0 ,src) `(make-non-immediate 1 ,src)
`(static-ref 0 ,src)) `(static-ref 1 ,src))
`(static-set! 0 ,dst ,n)) `(static-set! 1 ,dst ,n))
'()))) '())))
(define (intern obj label) (define (intern obj label)
(cond (cond
@ -543,24 +543,24 @@ table, its existing label is used directly."
(reverse inits)))) (reverse inits))))
((stringbuf? obj) '()) ((stringbuf? obj) '())
((static-procedure? obj) ((static-procedure? obj)
`((make-non-immediate 0 ,label) `((make-non-immediate 1 ,label)
(link-procedure! 0 ,(static-procedure-code obj)))) (link-procedure! 1 ,(static-procedure-code obj))))
((cache-cell? obj) '()) ((cache-cell? obj) '())
((symbol? obj) ((symbol? obj)
`((make-non-immediate 0 ,(recur (symbol->string obj))) `((make-non-immediate 1 ,(recur (symbol->string obj)))
(string->symbol 0 0) (string->symbol 1 1)
(static-set! 0 ,label 0))) (static-set! 1 ,label 0)))
((string? obj) ((string? obj)
`((make-non-immediate 0 ,(recur (make-stringbuf obj))) `((make-non-immediate 1 ,(recur (make-stringbuf obj)))
(static-set! 0 ,label 1))) (static-set! 1 ,label 1)))
((keyword? obj) ((keyword? obj)
`((static-ref 0 ,(recur (keyword->symbol obj))) `((static-ref 1 ,(recur (keyword->symbol obj)))
(symbol->keyword 0 0) (symbol->keyword 1 1)
(static-set! 0 ,label 0))) (static-set! 1 ,label 0)))
((number? obj) ((number? obj)
`((make-non-immediate 0 ,(recur (number->string obj))) `((make-non-immediate 1 ,(recur (number->string obj)))
(string->number 0 0) (string->number 1 1)
(static-set! 0 ,label 0))) (static-set! 1 ,label 0)))
(else (else
(error "don't know how to intern" obj)))) (error "don't know how to intern" obj))))
(cond (cond
@ -660,7 +660,10 @@ returned instead."
(let* ((meta (car (asm-meta asm))) (let* ((meta (car (asm-meta asm)))
(arity (make-arity req opt rest kw-indices allow-other-keys? (arity (make-arity req opt rest kw-indices allow-other-keys?
(asm-start asm) #f)) (asm-start asm) #f))
(nreq (length req)) ;; The procedure itself is in slot 0, in the standard calling
;; convention. For procedure prologues, nreq includes the
;; procedure, so here we add 1.
(nreq (1+ (length req)))
(nopt (length opt)) (nopt (length opt))
(rest? (->bool rest))) (rest? (->bool rest)))
(set-meta-arities! meta (cons arity (meta-arities meta))) (set-meta-arities! meta (cons arity (meta-arities meta)))
@ -801,10 +804,10 @@ a procedure to do that and return its label. Otherwise return
(let ((label (gensym "init-constants"))) (let ((label (gensym "init-constants")))
(emit-text asm (emit-text asm
`((begin-program ,label ()) `((begin-program ,label ())
(assert-nargs-ee/locals 0 1) (assert-nargs-ee/locals 1 1)
,@(reverse inits) ,@(reverse inits)
(load-constant 0 ,*unspecified*) (load-constant 1 ,*unspecified*)
(return 0) (return 1)
(end-program))) (end-program)))
label)))) label))))

10
module/system/vm/disassembler.scm
View file

@ -236,17 +236,19 @@ address of that offset."
(('make-long-long-immediate _ high low) (('make-long-long-immediate _ high low)
(list "~S" (unpack-scm (logior (ash high 32) low)))) (list "~S" (unpack-scm (logior (ash high 32) low))))
(('assert-nargs-ee/locals nargs locals) (('assert-nargs-ee/locals nargs locals)
(list "~a arg~:p, ~a local~:p" nargs locals)) ;; The nargs includes the procedure.
(list "~a arg~:p, ~a local~:p" (1- nargs) locals))
(('tail-call nargs proc) (('tail-call nargs proc)
(list "~a arg~:p" nargs)) (list "~a arg~:p" nargs))
(('make-closure dst target free ...) (('make-closure dst target nfree)
(let* ((addr (u32-offset->addr (+ offset target) context)) (let* ((addr (u32-offset->addr (+ offset target) context))
(pdi (find-program-debug-info addr context))) (pdi (find-program-debug-info addr context)))
;; FIXME: Disassemble embedded closures as well. ;; FIXME: Disassemble embedded closures as well.
(list "~A at 0x~X" (list "~A at 0x~X (~A free var~:p)"
(or (and pdi (program-debug-info-name pdi)) (or (and pdi (program-debug-info-name pdi))
"(anonymous procedure)") "(anonymous procedure)")
addr))) addr
nfree)))
(('make-non-immediate dst target) (('make-non-immediate dst target)
(list "~@Y" (reference-scm target))) (list "~@Y" (reference-scm target)))
(((or 'static-ref 'static-set!) _ target) (((or 'static-ref 'static-set!) _ target)

203
test-suite/tests/rtl.test
View file

@ -29,9 +29,9 @@
(define (return-constant val) (define (return-constant val)
(assemble-program `((begin-program foo (assemble-program `((begin-program foo
((name . foo))) ((name . foo)))
(begin-standard-arity () 1 #f) (begin-standard-arity () 2 #f)
(load-constant 0 ,val) (load-constant 1 ,val)
(return 0) (return 1)
(end-arity) (end-arity)
(end-program)))) (end-program))))
@ -67,16 +67,16 @@
(assert-equal 42 (assert-equal 42
(((assemble-program `((begin-program foo (((assemble-program `((begin-program foo
((name . foo))) ((name . foo)))
(begin-standard-arity () 1 #f) (begin-standard-arity () 2 #f)
(load-static-procedure 0 bar) (load-static-procedure 1 bar)
(return 0) (return 1)
(end-arity) (end-arity)
(end-program) (end-program)
(begin-program bar (begin-program bar
((name . bar))) ((name . bar)))
(begin-standard-arity () 1 #f) (begin-standard-arity () 2 #f)
(load-constant 0 42) (load-constant 1 42)
(return 0) (return 1)
(end-arity) (end-arity)
(end-program))))))) (end-program)))))))
@ -89,19 +89,19 @@
;; 2: accum ;; 2: accum
'((begin-program countdown '((begin-program countdown
((name . countdown))) ((name . countdown)))
(begin-standard-arity (x) 3 #f) (begin-standard-arity (x) 4 #f)
(br fix-body) (br fix-body)
(label loop-head) (label loop-head)
(br-if-= 1 0 out) (br-if-= 2 1 out)
(add 2 1 2) (add 3 2 3)
(add1 1 1) (add1 2 2)
(br loop-head) (br loop-head)
(label fix-body) (label fix-body)
(load-constant 1 0)
(load-constant 2 0) (load-constant 2 0)
(load-constant 3 0)
(br loop-head) (br loop-head)
(label out) (label out)
(return 2) (return 3)
(end-arity) (end-arity)
(end-program))))) (end-program)))))
(sumto 1000)))) (sumto 1000))))
@ -115,21 +115,22 @@
;; 2: head ;; 2: head
'((begin-program make-accum '((begin-program make-accum
((name . make-accum))) ((name . make-accum)))
(begin-standard-arity () 2 #f) (begin-standard-arity () 3 #f)
(load-constant 0 0) (load-constant 1 0)
(box 0 0) (box 1 1)
(make-closure 1 accum (0)) (make-closure 2 accum 1)
(return 1) (free-set! 2 1 0)
(return 2)
(end-arity) (end-arity)
(end-program) (end-program)
(begin-program accum (begin-program accum
((name . accum))) ((name . accum)))
(begin-standard-arity (x) 3 #f) (begin-standard-arity (x) 4 #f)
(free-ref 1 0) (free-ref 2 0 0)
(box-ref 2 1) (box-ref 3 2)
(add 2 2 0) (add 3 3 1)
(box-set! 1 2) (box-set! 2 3)
(return 2) (return 3)
(end-arity) (end-arity)
(end-program))))) (end-program)))))
(let ((accum (make-accum))) (let ((accum (make-accum)))
@ -143,10 +144,10 @@
(assemble-program (assemble-program
'((begin-program call '((begin-program call
((name . call))) ((name . call)))
(begin-standard-arity (f) 1 #f) (begin-standard-arity (f) 2 #f)
(call 1 0 ()) (call 2 1 ())
(return 1) ;; MVRA from call (return 2) ;; MVRA from call
(return 1) ;; RA from call (return 2) ;; RA from call
(end-arity) (end-arity)
(end-program))))) (end-program)))))
(call (lambda () 42)))) (call (lambda () 42))))
@ -156,11 +157,11 @@
(assemble-program (assemble-program
'((begin-program call-with-3 '((begin-program call-with-3
((name . call-with-3))) ((name . call-with-3)))
(begin-standard-arity (f) 2 #f) (begin-standard-arity (f) 3 #f)
(load-constant 1 3) (load-constant 2 3)
(call 2 0 (1)) (call 3 1 (2))
(return 2) ;; MVRA from call (return 3) ;; MVRA from call
(return 2) ;; RA from call (return 3) ;; RA from call
(end-arity) (end-arity)
(end-program))))) (end-program)))))
(call-with-3 (lambda (x) (* x 2)))))) (call-with-3 (lambda (x) (* x 2))))))
@ -171,8 +172,8 @@
(assemble-program (assemble-program
'((begin-program call '((begin-program call
((name . call))) ((name . call)))
(begin-standard-arity (f) 1 #f) (begin-standard-arity (f) 2 #f)
(tail-call 0 0) (tail-call 0 1)
(end-arity) (end-arity)
(end-program))))) (end-program)))))
(call (lambda () 3)))) (call (lambda () 3))))
@ -182,10 +183,10 @@
(assemble-program (assemble-program
'((begin-program call-with-3 '((begin-program call-with-3
((name . call-with-3))) ((name . call-with-3)))
(begin-standard-arity (f) 2 #f) (begin-standard-arity (f) 3 #f)
(mov 1 0) ;; R1 <- R0 (mov 2 1) ;; R1 <- R0
(load-constant 0 3) ;; R0 <- 3 (load-constant 1 3) ;; R0 <- 3
(tail-call 1 1) (tail-call 1 2)
(end-arity) (end-arity)
(end-program))))) (end-program)))))
(call-with-3 (lambda (x) (* x 2)))))) (call-with-3 (lambda (x) (* x 2))))))
@ -196,18 +197,18 @@
(assemble-program (assemble-program
'((begin-program get-sqrt-trampoline '((begin-program get-sqrt-trampoline
((name . get-sqrt-trampoline))) ((name . get-sqrt-trampoline)))
(begin-standard-arity () 1 #f) (begin-standard-arity () 2 #f)
(cache-current-module! 0 sqrt-scope) (cache-current-module! 1 sqrt-scope)
(load-static-procedure 0 sqrt-trampoline) (load-static-procedure 1 sqrt-trampoline)
(return 0) (return 1)
(end-arity) (end-arity)
(end-program) (end-program)
(begin-program sqrt-trampoline (begin-program sqrt-trampoline
((name . sqrt-trampoline))) ((name . sqrt-trampoline)))
(begin-standard-arity (x) 2 #f) (begin-standard-arity (x) 3 #f)
(cached-toplevel-ref 1 sqrt-scope sqrt) (cached-toplevel-ref 2 sqrt-scope sqrt)
(tail-call 1 1) (tail-call 1 2)
(end-arity) (end-arity)
(end-program))))) (end-program)))))
((get-sqrt-trampoline) 25.0)))) ((get-sqrt-trampoline) 25.0))))
@ -221,20 +222,20 @@
(assemble-program (assemble-program
'((begin-program make-top-incrementor '((begin-program make-top-incrementor
((name . make-top-incrementor))) ((name . make-top-incrementor)))
(begin-standard-arity () 1 #f) (begin-standard-arity () 2 #f)
(cache-current-module! 0 top-incrementor) (cache-current-module! 1 top-incrementor)
(load-static-procedure 0 top-incrementor) (load-static-procedure 1 top-incrementor)
(return 0) (return 1)
(end-arity) (end-arity)
(end-program) (end-program)
(begin-program top-incrementor (begin-program top-incrementor
((name . top-incrementor))) ((name . top-incrementor)))
(begin-standard-arity () 1 #f) (begin-standard-arity () 2 #f)
(cached-toplevel-ref 0 top-incrementor *top-val*) (cached-toplevel-ref 1 top-incrementor *top-val*)
(add1 0 0) (add1 1 1)
(cached-toplevel-set! 0 top-incrementor *top-val*) (cached-toplevel-set! 1 top-incrementor *top-val*)
(return/values 0) (return/values 1)
(end-arity) (end-arity)
(end-program))))) (end-program)))))
((make-top-incrementor)) ((make-top-incrementor))
@ -246,17 +247,17 @@
(assemble-program (assemble-program
'((begin-program get-sqrt-trampoline '((begin-program get-sqrt-trampoline
((name . get-sqrt-trampoline))) ((name . get-sqrt-trampoline)))
(begin-standard-arity () 1 #f) (begin-standard-arity () 2 #f)
(load-static-procedure 0 sqrt-trampoline) (load-static-procedure 1 sqrt-trampoline)
(return 0) (return 1)
(end-arity) (end-arity)
(end-program) (end-program)
(begin-program sqrt-trampoline (begin-program sqrt-trampoline
((name . sqrt-trampoline))) ((name . sqrt-trampoline)))
(begin-standard-arity (x) 2 #f) (begin-standard-arity (x) 3 #f)
(cached-module-ref 1 (guile) #t sqrt) (cached-module-ref 2 (guile) #t sqrt)
(tail-call 1 1) (tail-call 1 2)
(end-arity) (end-arity)
(end-program))))) (end-program)))))
((get-sqrt-trampoline) 25.0)))) ((get-sqrt-trampoline) 25.0))))
@ -268,19 +269,19 @@
(assemble-program (assemble-program
'((begin-program make-top-incrementor '((begin-program make-top-incrementor
((name . make-top-incrementor))) ((name . make-top-incrementor)))
(begin-standard-arity () 1 #f) (begin-standard-arity () 2 #f)
(load-static-procedure 0 top-incrementor) (load-static-procedure 1 top-incrementor)
(return 0) (return 1)
(end-arity) (end-arity)
(end-program) (end-program)
(begin-program top-incrementor (begin-program top-incrementor
((name . top-incrementor))) ((name . top-incrementor)))
(begin-standard-arity () 1 #f) (begin-standard-arity () 2 #f)
(cached-module-ref 0 (tests rtl) #f *top-val*) (cached-module-ref 1 (tests rtl) #f *top-val*)
(add1 0 0) (add1 1 1)
(cached-module-set! 0 (tests rtl) #f *top-val*) (cached-module-set! 1 (tests rtl) #f *top-val*)
(return 0) (return 1)
(end-arity) (end-arity)
(end-program))))) (end-program)))))
((make-top-incrementor)) ((make-top-incrementor))
@ -289,9 +290,9 @@
(with-test-prefix "debug contexts" (with-test-prefix "debug contexts"
(let ((return-3 (assemble-program (let ((return-3 (assemble-program
'((begin-program return-3 ((name . return-3))) '((begin-program return-3 ((name . return-3)))
(begin-standard-arity () 1 #f) (begin-standard-arity () 2 #f)
(load-constant 0 3) (load-constant 1 3)
(return 0) (return 1)
(end-arity) (end-arity)
(end-program))))) (end-program)))))
(pass-if "program name" (pass-if "program name"
@ -311,9 +312,9 @@
(procedure-name (procedure-name
(assemble-program (assemble-program
'((begin-program foo ((name . foo))) '((begin-program foo ((name . foo)))
(begin-standard-arity () 1 #f) (begin-standard-arity () 2 #f)
(load-constant 0 42) (load-constant 1 42)
(return 0) (return 1)
(end-arity) (end-arity)
(end-program)))))) (end-program))))))
@ -322,18 +323,18 @@
(object->string (object->string
(assemble-program (assemble-program
'((begin-program foo ((name . foo))) '((begin-program foo ((name . foo)))
(begin-standard-arity () 1 #f) (begin-standard-arity () 2 #f)
(load-constant 0 42) (load-constant 1 42)
(return 0) (return 1)
(end-arity) (end-arity)
(end-program))))) (end-program)))))
(pass-if-equal "#<procedure foo (x y)>" (pass-if-equal "#<procedure foo (x y)>"
(object->string (object->string
(assemble-program (assemble-program
'((begin-program foo ((name . foo))) '((begin-program foo ((name . foo)))
(begin-standard-arity (x y) 2 #f) (begin-standard-arity (x y) 3 #f)
(load-constant 0 42) (load-constant 1 42)
(return 0) (return 1)
(end-arity) (end-arity)
(end-program))))) (end-program)))))
@ -341,9 +342,9 @@
(object->string (object->string
(assemble-program (assemble-program
'((begin-program foo ((name . foo))) '((begin-program foo ((name . foo)))
(begin-opt-arity (x) (y) z 3 #f) (begin-opt-arity (x) (y) z 4 #f)
(load-constant 0 42) (load-constant 1 42)
(return 0) (return 1)
(end-arity) (end-arity)
(end-program)))))) (end-program))))))
@ -352,9 +353,9 @@
(procedure-documentation (procedure-documentation
(assemble-program (assemble-program
'((begin-program foo ((name . foo) (documentation . "qux qux"))) '((begin-program foo ((name . foo) (documentation . "qux qux")))
(begin-standard-arity () 1 #f) (begin-standard-arity () 2 #f)
(load-constant 0 42) (load-constant 1 42)
(return 0) (return 1)
(end-arity) (end-arity)
(end-program)))))) (end-program))))))
@ -364,9 +365,9 @@
(procedure-properties (procedure-properties
(assemble-program (assemble-program
'((begin-program foo ()) '((begin-program foo ())
(begin-standard-arity () 1 #f) (begin-standard-arity () 2 #f)
(load-constant 0 42) (load-constant 1 42)
(return 0) (return 1)
(end-arity) (end-arity)
(end-program))))) (end-program)))))
@ -376,9 +377,9 @@
(procedure-properties (procedure-properties
(assemble-program (assemble-program
'((begin-program foo ((name . foo) (documentation . "qux qux"))) '((begin-program foo ((name . foo) (documentation . "qux qux")))
(begin-standard-arity () 1 #f) (begin-standard-arity () 2 #f)
(load-constant 0 42) (load-constant 1 42)
(return 0) (return 1)
(end-arity) (end-arity)
(end-program))))) (end-program)))))
@ -391,9 +392,9 @@
'((begin-program foo ((name . foo) '((begin-program foo ((name . foo)
(documentation . "qux qux") (documentation . "qux qux")
(moo . "mooooooooooooo"))) (moo . "mooooooooooooo")))
(begin-standard-arity () 1 #f) (begin-standard-arity () 2 #f)
(load-constant 0 42) (load-constant 1 42)
(return 0) (return 1)
(end-arity) (end-arity)
(end-program))))) (end-program)))))
@ -404,8 +405,8 @@
'((begin-program foo ((name . foo) '((begin-program foo ((name . foo)
(documentation . "qux qux") (documentation . "qux qux")
(moo . "mooooooooooooo"))) (moo . "mooooooooooooo")))
(begin-standard-arity () 1 #f) (begin-standard-arity () 2 #f)
(load-constant 0 42) (load-constant 1 42)
(return 0) (return 1)
(end-arity) (end-arity)
(end-program)))))) (end-program))))))