mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-30 15:00:21 +02:00
Code Activity

frame-call-representation checks available-bindings, as appropriate

Browse source 
* module/system/vm/frame.scm (available-bindings): Map indexes in such a
  way that the first argument is index 1.
  (frame-call-representation): Update to search the bindings for live
  bindings.
This commit is contained in:
Andy Wingo 2014-04-16 14:19:18 +02:00
parent 1a2711a848
commit d856931d8d
1 changed files with 34 additions and 17 deletions
Download patch file Download diff file Expand all files Collapse all files

51
module/system/vm/frame.scm
View file

@ -224,7 +224,10 @@
(if n (if n
(match (vector-ref defs n) (match (vector-ref defs n)
(#(name def-offset slot) (#(name def-offset slot)
(cons (make-binding n name slot) (lp (1+ n))))) ;; Binding 0 is the closure, and is not present
;; in arity-definitions.
(cons (make-binding (1+ n) name slot)
(lp (1+ n)))))
'())))) '()))))
(lp (1+ n) (- offset (vector-ref parsed n))))))) (lp (1+ n) (- offset (vector-ref parsed n)))))))
@ -286,29 +289,41 @@
;; the types don't match. In that case the arguments are all on the ;; the types don't match. In that case the arguments are all on the
;; stack, and nothing else is on the stack. ;; stack, and nothing else is on the stack.
(define (frame-call-representation frame) (define* (frame-call-representation frame #:optional top-frame?)
(let* ((ip (frame-instruction-pointer frame)) (let* ((ip (frame-instruction-pointer frame))
(info (find-program-debug-info ip)) (info (find-program-debug-info ip))
(nlocals (frame-num-locals frame)) (nlocals (frame-num-locals frame))
(closure (frame-procedure frame))) (closure (frame-procedure frame)))
(define (local-ref i) (define (find-slot i bindings)
(if (< i nlocals) (match bindings
(frame-local-ref frame i) (#f (and (< i nlocals) i))
;; Let's not error here, as we are called during backtraces. (() #f)
'???)) ((($ <binding> idx name slot) . bindings)
(define (reconstruct-arguments nreq nopt kw has-rest? local) (if (< idx i)
(find-slot i bindings)
(and (= idx i) slot)))))
(define (local-ref i bindings)
(cond
((find-slot i bindings)
=> (lambda (slot) (frame-local-ref frame slot)))
(else
'_)))
(define (reconstruct-arguments bindings nreq nopt kw has-rest? local)
(cond (cond
((positive? nreq) ((positive? nreq)
(cons (local-ref local) (cons (local-ref local bindings)
(reconstruct-arguments (1- nreq) nopt kw has-rest? (1+ local)))) (reconstruct-arguments bindings
(1- nreq) nopt kw has-rest? (1+ local))))
((positive? nopt) ((positive? nopt)
(cons (local-ref local) (cons (local-ref local bindings)
(reconstruct-arguments nreq (1- nopt) kw has-rest? (1+ local)))) (reconstruct-arguments bindings
nreq (1- nopt) kw has-rest? (1+ local))))
((pair? kw) ((pair? kw)
(cons* (caar kw) (local-ref (cdar kw)) (cons* (caar kw) (local-ref (cdar kw) bindings)
(reconstruct-arguments nreq nopt (cdr kw) has-rest? (1+ local)))) (reconstruct-arguments bindings
nreq nopt (cdr kw) has-rest? (1+ local))))
(has-rest? (has-rest?
(local-ref local)) (local-ref local bindings))
(else (else
'()))) '())))
(cons (cons
@ -325,7 +340,8 @@
((find-program-arity ip) ((find-program-arity ip)
=> (lambda (arity) => (lambda (arity)
;; case 1 ;; case 1
(reconstruct-arguments (arity-nreq arity) (reconstruct-arguments (available-bindings arity ip top-frame?)
(arity-nreq arity)
(arity-nopt arity) (arity-nopt arity)
(arity-keyword-args arity) (arity-keyword-args arity)
(arity-has-rest? arity) (arity-has-rest? arity)
@ -340,7 +356,8 @@
('allow-other-keys? . _) ('allow-other-keys? . _)
('rest . rest)) ('rest . rest))
;; case 1 ;; case 1
(reconstruct-arguments (length req) (length opt) kw rest 1))))) (reconstruct-arguments #f
(length req) (length opt) kw rest 1)))))
(else (else
;; case 2 ;; case 2
(map local-ref (map local-ref