mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
1a2711a848
* 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.
367 lines
14 KiB
Scheme
367 lines
14 KiB
Scheme
;;; Guile VM frame functions
|
||
|
||
;;; Copyright (C) 2001, 2005, 2009, 2010, 2011, 2012, 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
|
||
;;; License as published by the Free Software Foundation; either
|
||
;;; version 3 of the License, or (at your option) any later version.
|
||
;;;
|
||
;;; This library is distributed in the hope that it will be useful,
|
||
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||
;;; Lesser General Public License for more details.
|
||
;;;
|
||
;;; You should have received a copy of the GNU Lesser General Public
|
||
;;; License along with this library; if not, write to the Free Software
|
||
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||
|
||
;;; Code:
|
||
|
||
(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 (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-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)
|
||
(car bindings))
|
||
(else
|
||
(lp (cdr bindings))))))
|
||
|
||
(define (frame-binding-set! frame var val)
|
||
(frame-local-set! frame
|
||
(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-slot
|
||
(or (frame-lookup-binding frame var)
|
||
(error "variable not bound in frame" var frame)))))
|
||
|
||
|
||
;; This function is always called to get some sort of representation of the
|
||
;; frame to present to the user, so let's do the logical thing and dispatch to
|
||
;; frame-call-representation.
|
||
(define (frame-arguments frame)
|
||
(cdr (frame-call-representation frame)))
|
||
|
||
|
||
|
||
;;;
|
||
;;; Pretty printing
|
||
;;;
|
||
|
||
;; Basically there are two cases to deal with here:
|
||
;;
|
||
;; 1. We've already parsed the arguments, and bound them to local
|
||
;; variables. In a standard (lambda (a b c) ...) call, this doesn't
|
||
;; involve any argument shuffling; but with rest, optional, or
|
||
;; keyword arguments, the arguments as given to the procedure may
|
||
;; not correspond to what's on the stack. We reconstruct the
|
||
;; arguments using e.g. for the case above: `(,a ,b ,c). This works
|
||
;; for rest arguments too: (a b . c) => `(,a ,b . ,c)
|
||
;;
|
||
;; 2. We have failed to parse the arguments. Perhaps it's the wrong
|
||
;; number of arguments, or perhaps we're doing a typed dispatch and
|
||
;; the types don't match. In that case the arguments are all on the
|
||
;; stack, and nothing else is on the stack.
|
||
|
||
(define (frame-call-representation frame)
|
||
(let* ((ip (frame-instruction-pointer frame))
|
||
(info (find-program-debug-info ip))
|
||
(nlocals (frame-num-locals frame))
|
||
(closure (frame-procedure frame)))
|
||
(define (local-ref i)
|
||
(if (< i nlocals)
|
||
(frame-local-ref frame i)
|
||
;; Let's not error here, as we are called during backtraces.
|
||
'???))
|
||
(define (reconstruct-arguments nreq nopt kw has-rest? local)
|
||
(cond
|
||
((positive? nreq)
|
||
(cons (local-ref local)
|
||
(reconstruct-arguments (1- nreq) nopt kw has-rest? (1+ local))))
|
||
((positive? nopt)
|
||
(cons (local-ref local)
|
||
(reconstruct-arguments nreq (1- nopt) kw has-rest? (1+ local))))
|
||
((pair? kw)
|
||
(cons* (caar kw) (local-ref (cdar kw))
|
||
(reconstruct-arguments nreq nopt (cdr kw) has-rest? (1+ local))))
|
||
(has-rest?
|
||
(local-ref local))
|
||
(else
|
||
'())))
|
||
(cons
|
||
(or (and=> info program-debug-info-name)
|
||
(procedure-name closure)
|
||
(and info
|
||
;; No need to give source info, as backtraces will already
|
||
;; take care of that.
|
||
(format #f "#<procedure ~a>"
|
||
(number->string (program-debug-info-addr info) 16)))
|
||
(procedure-name closure)
|
||
closure)
|
||
(cond
|
||
((find-program-arity ip)
|
||
=> (lambda (arity)
|
||
;; case 1
|
||
(reconstruct-arguments (arity-nreq arity)
|
||
(arity-nopt arity)
|
||
(arity-keyword-args arity)
|
||
(arity-has-rest? arity)
|
||
1)))
|
||
((and (primitive? closure)
|
||
(program-arguments-alist closure ip))
|
||
=> (lambda (args)
|
||
(match args
|
||
((('required . req)
|
||
('optional . opt)
|
||
('keyword . kw)
|
||
('allow-other-keys? . _)
|
||
('rest . rest))
|
||
;; case 1
|
||
(reconstruct-arguments (length req) (length opt) kw rest 1)))))
|
||
(else
|
||
;; case 2
|
||
(map local-ref
|
||
;; Cdr past the 0th local, which is the procedure.
|
||
(cdr (iota nlocals))))))))
|
||
|
||
|
||
|
||
;;; Misc
|
||
;;;
|
||
|
||
(define (frame-environment frame)
|
||
(map (lambda (binding)
|
||
(cons (binding-name binding) (frame-binding-ref frame binding)))
|
||
(frame-bindings frame)))
|
||
|
||
(define (frame-object-binding frame obj)
|
||
(do ((bs (frame-bindings frame) (cdr bs)))
|
||
((or (null? bs) (eq? obj (frame-binding-ref frame (car bs))))
|
||
(and (pair? bs) (car bs)))))
|
||
|
||
(define (frame-object-name frame obj)
|
||
(cond ((frame-object-binding frame obj) => binding-name)
|
||
(else #f)))
|