wingo pushed a commit to branch master in repository guile. commit 70e3a4a311220e087a1ff1b198548a27dea2dc15 Author: Andy Wingo <wi...@pobox.com> Date: Tue Apr 10 14:36:15 2018 +0200
Add load-label instruction * libguile/vm-engine.c (load-label): New instruction. * module/system/vm/assembler.scm: Add emit-load-label. * module/system/vm/disassembler.scm (code-annotation): (fold-code-range): Add load-label support. --- libguile/vm-engine.c | 22 +++++++++++++++++----- module/system/vm/assembler.scm | 1 + module/system/vm/disassembler.scm | 9 +++++++++ 3 files changed, 27 insertions(+), 5 deletions(-) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 05d88aa..9355110 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -2126,13 +2126,25 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, } - - - /* - * Strings, symbols, and keywords + /* load-label dst:24 offset:32 + * + * Load a label OFFSET words away from the current IP and write it to + * DST. OFFSET is a signed 32-bit integer. */ + VM_DEFINE_OP (76, load_label, "load-label", OP2 (X8_S24, L32) | OP_DST) + { + scm_t_uint32 dst; + scm_t_int32 offset; + SCM closure; + + UNPACK_24 (op, dst); + offset = ip[1]; + + SP_SET_U64 (dst, ip + offset); + + NEXT (2); + } - VM_DEFINE_OP (76, unused_76, NULL, NOP) VM_DEFINE_OP (77, unused_77, NULL, NOP) { vm_error_bad_instruction (op); diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 6bb1475..b3d2bb2 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -216,6 +216,7 @@ emit-bind-kwargs emit-bind-rest emit-make-closure + emit-load-label emit-current-module emit-resolve emit-define! diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm index 286a0f1..6840668 100644 --- a/module/system/vm/disassembler.scm +++ b/module/system/vm/disassembler.scm @@ -250,6 +250,13 @@ address of that offset." "anonymous procedure"))) (push-addr! addr name) (list "~A at #x~X (~A free var~:p)" name addr nfree))) + (('load-label dst src) + (let* ((addr (u32-offset->addr (+ offset src) context)) + (pdi (find-program-debug-info addr context)) + (name (or (and pdi (program-debug-info-name pdi)) + "anonymous procedure"))) + (push-addr! addr name) + (list "~A at #x~X" name addr))) (('call-label closure nlocals target) (let* ((addr (u32-offset->addr (+ offset target) context)) (pdi (find-program-debug-info addr context)) @@ -411,6 +418,8 @@ address of that offset." `(make-closure ,dst ,(u32-offset->addr (+ offset target) context) ,nfree)) + (('load-label dst src) + `(load-label ,dst ,(u32-offset->addr (+ offset src) context))) (('make-non-immediate dst target) `(make-non-immediate ,dst ,(reference-scm target))) (('builtin-ref dst idx)