[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-940-g1a2711a
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-940-g1a2711a |
|
Date: |
Wed, 16 Apr 2014 11:59:35 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=1a2711a84865462fe3f3c4c08aa79dcefa661719
The branch, master has been updated
via 1a2711a84865462fe3f3c4c08aa79dcefa661719 (commit)
via c4c9bfffd74dc52b98259e2ce10a3b2bc26fd279 (commit)
via bc5bcf66375690a2a744a8f14dab37194519101c (commit)
via 20d7d68284613d8040cdaa5c8d93d80e6fa1e068 (commit)
via b7ee9e086e9da40b2e0e4727a14d4ed668168ce2 (commit)
via f9425c8000076e3d3d69f70b8a57e03eb9251f23 (commit)
from 4cbe4d72aab9723d57b9cd779fc99e76b545802e (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 1a2711a84865462fe3f3c4c08aa79dcefa661719
Author: Andy Wingo <address@hidden>
Date: Wed Apr 16 13:58:17 2014 +0200
Update frame-bindings interface
* module/system/repl/debug.scm (print-locals): Update to work with new
interface.
(frame->module): Update. Still doesn't work due to lack of
`program-module', though.
* module/system/vm/program.scm (make-binding, binding:name)
(binding:definition-offset, program-arity-bindings-for-ip): Remove
these.
* module/system/vm/frame.scm (<binding>): New type.
(available-bindings): Return a list of <binding> instances.
(frame-lookup-binding, frame-binding-set!, frame-binding-ref):
(frame-environment, frame-object-name): Adapt.
commit c4c9bfffd74dc52b98259e2ce10a3b2bc26fd279
Author: Andy Wingo <address@hidden>
Date: Wed Apr 16 12:59:45 2014 +0200
Implement frame-bindings
* module/system/vm/frame.scm (parse-code, compute-predecessors):
(compute-genv, compute-defs-by-slot, compute-killv, available-bindings):
(frame-bindings): Add a bunch of hairy code to compute the set of
bindings that are live in a frame.
commit bc5bcf66375690a2a744a8f14dab37194519101c
Author: Andy Wingo <address@hidden>
Date: Wed Apr 16 12:58:35 2014 +0200
Add arity-code
* module/system/vm/debug.scm (arity-code): New interface.
commit 20d7d68284613d8040cdaa5c8d93d80e6fa1e068
Author: Andy Wingo <address@hidden>
Date: Wed Apr 16 12:58:20 2014 +0200
Add parsing interfaces to the disassembler
* module/system/vm/disassembler.scm (instruction-length):
(instruction-has-fallthrough?, instruction-relative-jump-targets):
(instruction-slot-clobbers): New interfaces; to be used when
determining the bindings available at a given point of a procedure.
commit b7ee9e086e9da40b2e0e4727a14d4ed668168ce2
Author: Andy Wingo <address@hidden>
Date: Wed Apr 16 12:51:34 2014 +0200
Fix up some opcode metadata
* libguile/vm-engine.c (make-long-immediate, static-ref): Mark as "dst"
instructions.
commit f9425c8000076e3d3d69f70b8a57e03eb9251f23
Author: Andy Wingo <address@hidden>
Date: Tue Apr 15 22:24:48 2014 +0200
Add ability to query local definitions for a procedure
* module/system/vm/debug.scm (arity-definitions): New interface.
* module/system/vm/program.scm (make-binding, binding:boxed?)
(binding:index, binding:start, binding:end): Remove.
(binding:definition-offset, binding:slot): Add.
(program-arity-bindings-for-ip): Rename from program-bindings-for-ip,
as it gives all definitions in an arity. The user will have to do
data-flow analysis to recover the set of variables that are actually
available at any given point.
(arity->arguments-alist): Remove crufty code.
-----------------------------------------------------------------------
Summary of changes:
libguile/vm-engine.c | 4 +-
module/system/repl/debug.scm | 22 ++--
module/system/vm/debug.scm | 65 +++++++++++
module/system/vm/disassembler.scm | 117 +++++++++++++++++++-
module/system/vm/frame.scm | 220 +++++++++++++++++++++++++++++++++++--
module/system/vm/program.scm | 65 +----------
6 files changed, 407 insertions(+), 86 deletions(-)
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 331f45c..96e6721 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -1662,7 +1662,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
* Make an immediate whose low bits are LOW-BITS, and whose top bits are
* 0.
*/
- VM_DEFINE_OP (53, make_long_immediate, "make-long-immediate", OP2 (U8_U24,
I32))
+ VM_DEFINE_OP (53, make_long_immediate, "make-long-immediate", OP2 (U8_U24,
I32) | OP_DST)
{
scm_t_uint32 dst;
scm_t_bits val;
@@ -1737,7 +1737,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
* that the compiler is unable to statically allocate, like symbols.
* These values would be initialized when the object file loads.
*/
- VM_DEFINE_OP (56, static_ref, "static-ref", OP2 (U8_U24, S32))
+ VM_DEFINE_OP (56, static_ref, "static-ref", OP2 (U8_U24, S32) | OP_DST)
{
scm_t_uint32 dst;
scm_t_int32 offset;
diff --git a/module/system/repl/debug.scm b/module/system/repl/debug.scm
index fdf6bb7..a15defc 100644
--- a/module/system/repl/debug.scm
+++ b/module/system/repl/debug.scm
@@ -1,6 +1,6 @@
;;; Guile VM debugging facilities
-;;; Copyright (C) 2001, 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2009, 2010, 2011, 2013, 2014 Free Software Foundation,
Inc.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
@@ -113,14 +113,10 @@
(format port "~aLocal variables:~%" per-line-prefix)
(for-each
(lambda (binding)
- (let ((v (let ((x (frame-local-ref frame (binding:index binding))))
- (if (binding:boxed? binding)
- (variable-ref x)
- x))))
+ (let ((v (frame-local-ref frame (binding-slot binding))))
(display per-line-prefix port)
(run-hook before-print-hook v)
- (format port "~a~:[~; (boxed)~] = ~v:@y\n"
- (binding:name binding) (binding:boxed? binding) width v)))
+ (format port "~a = ~v:@y\n" (binding-name binding) width v)))
(frame-bindings frame))))))
(define* (print-frame frame #:optional (port (current-output-port))
@@ -171,20 +167,20 @@
(define (frame->module frame)
(let ((proc (frame-procedure frame)))
(if #f
- ;; FIXME!
+ ;; FIXME: program-module does not exist.
(let* ((mod (or (program-module proc) (current-module)))
(mod* (make-module)))
(module-use! mod* mod)
(for-each
(lambda (binding)
- (let* ((x (frame-local-ref frame (binding:index binding)))
- (var (if (binding:boxed? binding) x (make-variable x))))
+ (let* ((x (frame-local-ref frame (binding-slot binding)))
+ (var (if (variable? x) x (make-variable x))))
(format #t
"~:[Read-only~;Mutable~] local variable ~a = ~70:@y\n"
- (binding:boxed? binding)
- (binding:name binding)
+ (not (variable? x))
+ (binding-name binding)
(if (variable-bound? var) (variable-ref var) var))
- (module-add! mod* (binding:name binding) var)))
+ (module-add! mod* (binding-name binding) var)))
(frame-bindings frame))
mod*)
(current-module))))
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index ac2041c..97c3d99 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -58,6 +58,8 @@
arity-has-keyword-args?
arity-keyword-args
arity-is-case-lambda?
+ arity-definitions
+ arity-code
debug-context-from-image
fold-all-debug-contexts
@@ -347,6 +349,69 @@ section of the ELF image. Returns an ELF symbol, or
@code{#f}."
(string->symbol (string-table-ref bv (+ strtab-offset n)))))))
(else (error "couldn't find arities section")))))
+(define* (arity-definitions arity)
+ (let* ((bv (elf-bytes (debug-context-elf (arity-context arity))))
+ (load-symbol (arity-load-symbol arity))
+ (header (arity-header-offset arity))
+ (nlocals (arity-nlocals* bv header))
+ (flags (arity-flags* bv header))
+ (link-offset (arity-offset* bv header))
+ (link (+ (arity-base arity)
+ link-offset
+ (if (has-keyword-args? flags) 4 0))))
+ (define (read-uleb128 bv pos)
+ ;; Unrolled by one.
+ (let ((b (bytevector-u8-ref bv pos)))
+ (if (zero? (logand b #x80))
+ (values b
+ (1+ pos))
+ (let lp ((n (logxor #x80 b)) (pos (1+ pos)) (shift 7))
+ (let ((b (bytevector-u8-ref bv pos)))
+ (if (zero? (logand b #x80))
+ (values (logior (ash b shift) n)
+ (1+ pos))
+ (lp (logior (ash (logxor #x80 b) shift) n)
+ (1+ pos)
+ (+ shift 7))))))))
+ (define (load-definitions pos names)
+ (let lp ((pos pos) (names names))
+ (match names
+ (() '())
+ ((name . names)
+ (call-with-values (lambda () (read-uleb128 bv pos))
+ (lambda (def-offset pos)
+ (call-with-values (lambda () (read-uleb128 bv pos))
+ (lambda (slot pos)
+ (cons (vector name def-offset slot)
+ (lp pos names))))))))))
+ (define (load-symbols pos)
+ (let lp ((pos pos) (n nlocals) (out '()))
+ (if (zero? n)
+ (load-definitions pos (reverse out))
+ (call-with-values (lambda () (read-uleb128 bv pos))
+ (lambda (strtab-offset pos)
+ strtab-offset
+ (lp pos
+ (1- n)
+ (cons (if (zero? strtab-offset)
+ #f
+ (load-symbol strtab-offset))
+ out)))))))
+ (when (is-case-lambda? flags)
+ (error "invalid request for definitions of case-lambda wrapper arity"))
+ (load-symbols link)))
+
+(define (arity-code arity)
+ (let* ((ctx (arity-context arity))
+ (bv (elf-bytes (debug-context-elf ctx)))
+ (header (arity-header-offset arity))
+ (base-addr (+ (debug-context-base ctx) (debug-context-text-base ctx)))
+ (low-pc (+ base-addr (arity-low-pc* bv header)))
+ (high-pc (+ base-addr (arity-high-pc* bv header))))
+ ;; FIXME: We should be able to use a sub-bytevector operation here;
+ ;; it would be safer.
+ (pointer->bytevector (make-pointer low-pc) (- high-pc low-pc))))
+
(define* (arity-locals arity #:optional nlocals)
(let* ((bv (elf-bytes (debug-context-elf (arity-context arity))))
(load-symbol (arity-load-symbol arity))
diff --git a/module/system/vm/disassembler.scm
b/module/system/vm/disassembler.scm
index 4e9bd52..248b44e 100644
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -34,7 +34,12 @@
#:export (disassemble-program
fold-program-code
disassemble-image
- disassemble-file))
+ disassemble-file
+
+ instruction-length
+ instruction-has-fallthrough?
+ instruction-relative-jump-targets
+ instruction-slot-clobbers))
(define-syntax-rule (u32-ref buf n)
(bytevector-u32-native-ref buf (* n 4)))
@@ -486,3 +491,113 @@ address of that offset."
(let* ((thunk (load-thunk-from-file file))
(elf (find-mapped-elf-image (program-code thunk))))
(disassemble-image elf)))
+
+(define-syntax instruction-lengths-vector
+ (lambda (x)
+ (syntax-case x ()
+ ((_)
+ (let ((lengths (make-vector 256 #f)))
+ (for-each (match-lambda
+ ((name opcode kind words ...)
+ (vector-set! lengths opcode (* 4 (length words)))))
+ (instruction-list))
+ (datum->syntax x lengths))))))
+
+(define (instruction-length code pos)
+ (let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
+ (or (vector-ref (instruction-lengths-vector) opcode)
+ (error "Unknown opcode" opcode))))
+
+(define-syntax static-opcode-set
+ (lambda (x)
+ (define (instruction-opcode inst)
+ (cond
+ ((assq inst (instruction-list))
+ => (match-lambda ((name opcode . _) opcode)))
+ (else
+ (error "unknown instruction" inst))))
+
+ (syntax-case x ()
+ ((static-opcode-set inst ...)
+ (let ((bv (make-bitvector 256 #f)))
+ (for-each (lambda (inst)
+ (bitvector-set! bv (instruction-opcode inst) #t))
+ (syntax->datum #'(inst ...)))
+ (datum->syntax #'static-opcode-set bv))))))
+
+(define (instruction-has-fallthrough? code pos)
+ (define non-fallthrough-set
+ (static-opcode-set halt
+ tail-call tail-call-label tail-call/shuffle
+ return return-values
+ subr-call foreign-call continuation-call
+ tail-apply
+ br))
+ (let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
+ (not (bitvector-ref non-fallthrough-set opcode))))
+
+(define-syntax define-jump-parser
+ (lambda (x)
+ (syntax-case x ()
+ ((_ name opcode kind word0 word* ...)
+ (let ((symname (syntax->datum #'name)))
+ (if (or (memq symname '(br prompt))
+ (string-prefix? "br-" (symbol->string symname)))
+ (let ((offset (* 4 (length #'(word* ...)))))
+ #`(vector-set!
+ jump-parsers
+ opcode
+ (lambda (code pos)
+ (let ((target
+ (bytevector-s32-native-ref code (+ pos #,offset))))
+ ;; Assume that the target is in the last word, as
+ ;; an L24 in the high bits.
+ (list (* 4 (ash target -8)))))))
+ #'(begin)))))))
+
+(define jump-parsers (make-vector 256 (lambda (code pos) '())))
+(visit-opcodes define-jump-parser)
+
+(define (instruction-relative-jump-targets code pos)
+ (let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
+ ((vector-ref jump-parsers opcode) code pos)))
+
+(define-syntax define-clobber-parser
+ (lambda (x)
+ (syntax-case x ()
+ ((_ name opcode kind arg ...)
+ (case (syntax->datum #'kind)
+ ((!)
+ (case (syntax->datum #'name)
+ ((call call-label)
+ #'(let ((parse (lambda (code pos nslots)
+ (call-with-values
+ (lambda ()
+ (disassemble-one code (/ pos 4)))
+ (lambda (len elt)
+ (match elt
+ ((_ proc . _)
+ (let lp ((slot (- proc 2)))
+ (if (< slot nslots)
+ (cons slot (lp (1+ slot)))
+ '())))))))))
+ (vector-set! clobber-parsers opcode parse)))
+ (else
+ #'(begin))))
+ ((<-)
+ #'(let ((parse (lambda (code pos nslots)
+ (call-with-values
+ (lambda ()
+ (disassemble-one code (/ pos 4)))
+ (lambda (len elt)
+ (match elt
+ ((_ dst . _) (list dst))))))))
+ (vector-set! clobber-parsers opcode parse)))
+ (else (error "unexpected instruction kind" #'kind)))))))
+
+(define clobber-parsers (make-vector 256 (lambda (code pos nslots) '())))
+(visit-opcodes define-clobber-parser)
+
+(define (instruction-slot-clobbers code pos nslots)
+ (let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
+ ((vector-ref clobber-parsers opcode) code pos nslots)))
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index 1fa25bc..4477c97 100644
--- a/module/system/vm/frame.scm
+++ b/module/system/vm/frame.scm
@@ -20,39 +20,241 @@
(define-module (system vm frame)
#:use-module (system base pmatch)
+ #:use-module (system foreign)
#:use-module (system vm program)
#:use-module (system vm debug)
+ #:use-module (system vm disassembler)
+ #:use-module (srfi srfi-9)
+ #:use-module (rnrs bytevectors)
#:use-module (ice-9 match)
- #:export (frame-bindings
+ #:export (binding-index
+ binding-name
+ binding-slot
+
+ frame-bindings
frame-lookup-binding
frame-binding-ref frame-binding-set!
frame-call-representation
frame-environment
frame-object-binding frame-object-name))
-(define (frame-bindings frame)
- (let ((p (frame-procedure frame)))
- (program-bindings-for-ip p (frame-instruction-pointer frame))))
+(define-record-type <binding>
+ (make-binding idx name slot)
+ binding?
+ (idx binding-index)
+ (name binding-name)
+ (slot binding-slot))
+
+(define (parse-code code)
+ (let ((len (bytevector-length code)))
+ (let lp ((pos 0) (out '()))
+ (cond
+ ((< pos len)
+ (let* ((inst-len (instruction-length code pos))
+ (pos (+ pos inst-len)))
+ (unless (<= pos len)
+ (error "Failed to parse codestream"))
+ (lp pos (cons inst-len out))))
+ (else
+ (list->vector (reverse out)))))))
+
+(define (compute-predecessors code parsed)
+ (let ((preds (make-vector (vector-length parsed) '())))
+ (define (add-pred! from target)
+ (let lp ((to from) (target target))
+ (cond
+ ((negative? target)
+ (lp (1- to) (+ target (vector-ref parsed to))))
+ ((positive? target)
+ (lp (1+ to) (- target (vector-ref parsed to))))
+ ((= to (vector-length preds))
+ ;; This can happen when an arity fails to match. Just ignore
+ ;; this case.
+ #t)
+ (else
+ (vector-set! preds to (cons from (vector-ref preds to)))))))
+ (let lp ((n 0) (pos 0))
+ (when (< n (vector-length preds))
+ (when (instruction-has-fallthrough? code pos)
+ (add-pred! n (vector-ref parsed n)))
+ (for-each (lambda (target)
+ (add-pred! n target))
+ (instruction-relative-jump-targets code pos))
+ (lp (1+ n) (+ pos (vector-ref parsed n)))))
+ preds))
+
+(define (compute-genv parsed defs)
+ (let ((genv (make-vector (vector-length parsed) '())))
+ (define (add-def! pos var)
+ (vector-set! genv pos (cons var (vector-ref genv pos))))
+ (let lp ((var 0) (pos 0) (pc-offset 0))
+ (when (< var (vector-length defs))
+ (match (vector-ref defs var)
+ (#(name offset slot)
+ (when (< offset pc-offset)
+ (error "mismatch between def offsets and parsed code"))
+ (cond
+ ((< pc-offset offset)
+ (lp var (1+ pos) (+ pc-offset (vector-ref parsed pos))))
+ (else
+ (add-def! pos var)
+ (lp (1+ var) pos pc-offset)))))))
+ genv))
+
+(define (compute-defs-by-slot defs)
+ (let* ((nslots (match defs
+ (#(#(_ _ slot) ...) (1+ (apply max slot)))))
+ (by-slot (make-vector nslots #f)))
+ (let lp ((n 0))
+ (when (< n nslots)
+ (vector-set! by-slot n (make-bitvector (vector-length defs) #f))
+ (lp (1+ n))))
+ (let lp ((n 0))
+ (when (< n (vector-length defs))
+ (match (vector-ref defs n)
+ (#(_ _ slot)
+ (bitvector-set! (vector-ref by-slot slot) n #t)
+ (lp (1+ n))))))
+ by-slot))
+
+(define (compute-killv code parsed defs)
+ (let ((defs-by-slot (compute-defs-by-slot defs))
+ (killv (make-vector (vector-length parsed) #f)))
+ (define (kill-slot! n slot)
+ (bit-set*! (vector-ref killv n) (vector-ref defs-by-slot slot) #t))
+ (let lp ((n 0))
+ (when (< n (vector-length killv))
+ (vector-set! killv n (make-bitvector (vector-length defs) #f))
+ (lp (1+ n))))
+ ;; Some defs get into place without explicit instructions -- this is
+ ;; the case if no shuffling need occur, for example. In any case,
+ ;; mark them as killing any previous definitions at that slot.
+ (let lp ((var 0) (pos 0) (pc-offset 0))
+ (when (< var (vector-length defs))
+ (match (vector-ref defs var)
+ (#(name offset slot)
+ (when (< offset pc-offset)
+ (error "mismatch between def offsets and parsed code"))
+ (cond
+ ((< pc-offset offset)
+ (lp var (1+ pos) (+ pc-offset (vector-ref parsed pos))))
+ (else
+ (kill-slot! pos slot)
+ (lp (1+ var) pos pc-offset)))))))
+ (let lp ((n 0) (pos 0))
+ (when (< n (vector-length parsed))
+ (for-each (lambda (slot)
+ (when (< slot (vector-length defs-by-slot))
+ (kill-slot! n slot)))
+ (instruction-slot-clobbers code pos
+ (vector-length defs-by-slot)))
+ (lp (1+ n) (+ pos (vector-ref parsed n)))))
+ killv))
+
+(define (available-bindings arity ip top-frame?)
+ (let* ((defs (list->vector (arity-definitions arity)))
+ (code (arity-code arity))
+ (parsed (parse-code code))
+ (len (vector-length parsed))
+ (preds (compute-predecessors code parsed))
+ (genv (compute-genv parsed defs))
+ (killv (compute-killv code parsed defs))
+ (inv (make-vector len #f))
+ (outv (make-vector len #f))
+ (tmp (make-bitvector (vector-length defs) #f)))
+ (define (bitvector-copy! dst src)
+ (bitvector-fill! dst #f)
+ (bit-set*! dst src #t))
+ (define (bitvector-meet! accum src)
+ (bitvector-copy! tmp src)
+ (bit-invert! tmp)
+ (bit-set*! accum tmp #f))
+
+ (let lp ((n 0))
+ (when (< n len)
+ (vector-set! inv n (make-bitvector (vector-length defs) #f))
+ (vector-set! outv n (make-bitvector (vector-length defs) #f))
+ (lp (1+ n))))
+
+ (let lp ((n 0) (first? #t) (changed? #f))
+ (cond
+ ((< n len)
+ (let ((in (vector-ref inv n))
+ (out (vector-ref outv n))
+ (kill (vector-ref killv n))
+ (gen (vector-ref genv n)))
+ (let ((out-count (or changed? (bit-count #t out))))
+ (bitvector-fill! in (not (zero? n)))
+ (let lp ((preds (vector-ref preds n)))
+ (match preds
+ (() #t)
+ ((pred . preds)
+ (unless (and first? (<= n pred))
+ (bitvector-meet! in (vector-ref outv pred)))
+ (lp preds))))
+ (bitvector-copy! out in)
+ (bit-set*! out kill #f)
+ (for-each (lambda (def)
+ (bitvector-set! out def #t))
+ gen)
+ (lp (1+ n) first?
+ (or changed? (not (eqv? out-count (bit-count #t out))))))))
+ ((or changed? first?)
+ (lp 0 #f #f))))
+
+ (let lp ((n 0) (offset (- ip (arity-low-pc arity))))
+ (when (< offset 0)
+ (error "ip did not correspond to an instruction boundary?"))
+ (if (zero? offset)
+ (let ((live (if top-frame?
+ (vector-ref inv n)
+ ;; If we're not at a top frame, the IP points
+ ;; to the continuation -- but we haven't
+ ;; returned and defined its values yet. The
+ ;; set of live variables is the set that was
+ ;; live going into the call, minus the set
+ ;; killed by the call, but not including
+ ;; values defined by the call.
+ (begin
+ (bitvector-copy! tmp (vector-ref inv (1- n)))
+ (bit-set*! tmp (vector-ref killv (1- n)) #f)
+ tmp))))
+ (let lp ((n 0))
+ (let ((n (bit-position #t live n)))
+ (if n
+ (match (vector-ref defs n)
+ (#(name def-offset slot)
+ (cons (make-binding n name slot) (lp (1+ n)))))
+ '()))))
+ (lp (1+ n) (- offset (vector-ref parsed n)))))))
+
+(define* (frame-bindings frame #:optional top-frame?)
+ (let ((ip (frame-instruction-pointer frame)))
+ (cond
+ ((find-program-arity ip)
+ => (lambda (arity)
+ (available-bindings arity ip top-frame?)))
+ (else '()))))
(define (frame-lookup-binding frame var)
(let lp ((bindings (frame-bindings frame)))
(cond ((null? bindings)
#f)
- ((eq? (binding:name (car bindings)) var)
+ ((eq? (binding-name (car bindings)) var)
(car bindings))
(else
(lp (cdr bindings))))))
(define (frame-binding-set! frame var val)
(frame-local-set! frame
- (binding:index
+ (binding-slot
(or (frame-lookup-binding frame var)
(error "variable not bound in frame" var frame)))
val))
(define (frame-binding-ref frame var)
(frame-local-ref frame
- (binding:index
+ (binding-slot
(or (frame-lookup-binding frame var)
(error "variable not bound in frame" var frame)))))
@@ -152,7 +354,7 @@
(define (frame-environment frame)
(map (lambda (binding)
- (cons (binding:name binding) (frame-binding-ref frame binding)))
+ (cons (binding-name binding) (frame-binding-ref frame binding)))
(frame-bindings frame)))
(define (frame-object-binding frame obj)
@@ -161,5 +363,5 @@
(and (pair? bs) (car bs)))))
(define (frame-object-name frame obj)
- (cond ((frame-object-binding frame obj) => binding:name)
+ (cond ((frame-object-binding frame obj) => binding-name)
(else #f)))
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index b065110..5344d38 100644
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -24,15 +24,10 @@
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
- #:export (make-binding binding:name binding:boxed? binding:index
- binding:start binding:end
-
- source:addr source:line source:column source:file
+ #:export (source:addr source:line source:column source:file
source:line-for-user
program-sources program-sources-pre-retire program-source
- program-bindings-for-ip
-
program-arities program-arity arity:start arity:end
arity:nreq arity:nopt arity:rest? arity:kw arity:allow-other-keys?
@@ -61,14 +56,6 @@
(define (program-properties program)
(find-program-properties (program-code program)))
-(define (make-binding name boxed? index start end)
- (list name boxed? index start end))
-(define (binding:name b) (list-ref b 0))
-(define (binding:boxed? b) (list-ref b 1))
-(define (binding:index b) (list-ref b 2))
-(define (binding:start b) (list-ref b 3))
-(define (binding:end b) (list-ref b 4))
-
(define (source:addr source)
(car source))
(define (source:file source)
@@ -128,40 +115,6 @@
(source-column source)))
(find-program-sources (program-code proc))))
-(define (collapse-locals locs)
- (let lp ((ret '()) (locs locs))
- (if (null? locs)
- (map cdr (sort! ret
- (lambda (x y) (< (car x) (car y)))))
- (let ((b (car locs)))
- (cond
- ((assv-ref ret (binding:index b))
- => (lambda (bindings)
- (append! bindings (list b))
- (lp ret (cdr locs))))
- (else
- (lp (acons (binding:index b) (list b) ret)
- (cdr locs))))))))
-
-;; returns list of list of bindings
-;; (list-ref ret N) == bindings bound to the Nth local slot
-(define (program-bindings-by-index prog)
- ;; FIXME!
- '())
-
-(define (program-bindings-for-ip prog ip)
- (let lp ((in (program-bindings-by-index prog)) (out '()))
- (if (null? in)
- (reverse out)
- (lp (cdr in)
- (let inner ((binds (car in)))
- (cond ((null? binds) out)
- ((<= (binding:start (car binds))
- ip
- (binding:end (car binds)))
- (cons (car binds) out))
- (else (inner (cdr binds)))))))))
-
(define (arity:start a)
(match a ((start end . _) start) (_ (error "bad arity" a))))
(define (arity:end a)
@@ -203,31 +156,21 @@
#:optional
(make-placeholder
(lambda (i) (string->symbol "_"))))
- (define var-by-index
- (let ((rbinds (map (lambda (x)
- (cons (binding:index x) (binding:name x)))
- (program-bindings-for-ip prog
- (arity:start arity)))))
- (lambda (i)
- (or (assv-ref rbinds i)
- ;; if we don't know the name, return a placeholder
- (make-placeholder i)))))
-
(let lp ((nreq (arity:nreq arity)) (req '())
(nopt (arity:nopt arity)) (opt '())
(rest? (arity:rest? arity)) (rest #f)
(n 0))
(cond
((< 0 nreq)
- (lp (1- nreq) (cons (var-by-index n) req)
+ (lp (1- nreq) (cons (make-placeholder n) req)
nopt opt rest? rest (1+ n)))
((< 0 nopt)
(lp nreq req
- (1- nopt) (cons (var-by-index n) opt)
+ (1- nopt) (cons (make-placeholder n) opt)
rest? rest (1+ n)))
(rest?
(lp nreq req nopt opt
- #f (var-by-index (+ n (length (arity:kw arity))))
+ #f (make-placeholder (+ n (length (arity:kw arity))))
(1+ n)))
(else
`((required . ,(reverse req))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-940-g1a2711a,
Andy Wingo <=