summaryrefslogtreecommitdiff
path: root/module/system/vm/frame.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/system/vm/frame.scm')
-rw-r--r--module/system/vm/frame.scm463
1 files changed, 463 insertions, 0 deletions
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
new file mode 100644
index 000000000..2b55ce4f6
--- /dev/null
+++ b/module/system/vm/frame.scm
@@ -0,0 +1,463 @@
+;;; Guile VM frame functions
+
+;;; Copyright (C) 2001, 2005, 2009-2016, 2018 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 (srfi srfi-11)
+ #:use-module (rnrs bytevectors)
+ #:use-module (ice-9 match)
+ #:export (binding-index
+ binding-name
+ binding-slot
+ binding-representation
+
+ frame-bindings
+ frame-lookup-binding
+ binding-ref binding-set!
+
+ frame-call-representation
+ frame-return-values
+ frame-environment
+ frame-object-binding frame-object-name))
+
+(eval-when (expand compile load eval)
+ (load-extension (string-append "libguile-" (effective-version))
+ "scm_init_frames_builtins"))
+
+(define-record-type <binding>
+ (make-binding frame idx name slot representation)
+ binding?
+ (frame binding-frame)
+ (idx binding-index)
+ (name binding-name)
+ (slot binding-slot)
+ (representation binding-representation))
+
+(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 (1- 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-frame-sizes code parsed initial-size)
+ (let ((in-sizes (make-vector (vector-length parsed) #f))
+ (out-sizes (make-vector (vector-length parsed) #f)))
+ ;; This only computes all possible valid stack sizes if the bytecode
+ ;; is sorted topologically. Guiles' compiler does this currently,
+ ;; but if that changes we should do a proper pre-order visit. Of
+ ;; course the bytecode has to be valid too.
+ (define (find-idx n diff)
+ (let lp ((n n) (diff diff))
+ (cond
+ ((= n (vector-length parsed))
+ ;; Possible for jumps to alternate arities.
+ #f)
+ ((negative? diff)
+ (lp (1- n) (+ diff (vector-ref parsed (1- n)))))
+ ((positive? diff)
+ (lp (1+ n) (- diff (vector-ref parsed n))))
+ (else n))))
+ (vector-set! in-sizes 0 initial-size)
+ (let lp ((n 0) (pos 0))
+ (define (offset->idx target)
+ (call-with-values (lambda ()
+ (if (>= target pos)
+ (values n pos)
+ (values 0 0)))
+ (lambda (n pos)
+ (let lp ((n n) (pos pos))
+ (cond
+ ((= pos target) n)
+ ((< pos target) (lp (1+ n) (+ pos (vector-ref parsed n))))
+ (else (error "bad target" target)))))))
+ (when (< n (vector-length parsed))
+ (let* ((in (vector-ref in-sizes n))
+ (out (instruction-stack-size-after code pos in)))
+ (vector-set! out-sizes n out)
+ (when out
+ (when (instruction-has-fallthrough? code pos)
+ (vector-set! in-sizes (1+ n) out))
+ (for-each (lambda (target)
+ (let ((idx (find-idx n target)))
+ (when idx
+ (vector-set! in-sizes idx out))))
+ (instruction-relative-jump-targets code pos))))
+ (lp (1+ n) (+ pos (vector-ref parsed n)))))
+ (values in-sizes out-sizes)))
+
+(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 representation)
+ (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*-values (((defs-by-slot) (compute-defs-by-slot defs))
+ ((initial-frame-size) (vector-length defs-by-slot))
+ ((in-sizes out-sizes)
+ (compute-frame-sizes code parsed initial-frame-size))
+ ((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 representation)
+ (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)))
+ (let ((in (vector-ref in-sizes n))
+ (out (vector-ref out-sizes n)))
+ (instruction-slot-clobbers code pos in out)))
+ (lp (1+ n) (+ pos (vector-ref parsed n)))))
+ killv))
+
+(define (available-bindings frame 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)
+ ;; It shouldn't be the case that both OFFSET and N are zero
+ ;; but TOP-FRAME? is false. Still, it could happen, as is
+ ;; currently the case in frame-arguments.
+ (let ((live (if (or top-frame? (zero? n))
+ (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 representation)
+ (cons (make-binding frame n name slot representation)
+ (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 frame 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 (binding-ref binding)
+ (frame-local-ref (or (binding-frame binding)
+ (error "binding has no frame" binding))
+ (binding-slot binding)
+ (binding-representation binding)))
+
+(define (binding-set! binding val)
+ (frame-local-set! (or (binding-frame binding)
+ (error "binding has no frame" binding))
+ (binding-slot binding)
+ val
+ (binding-representation binding)))
+
+(define* (frame-procedure-name frame #:key
+ (info (find-program-debug-info
+ (frame-instruction-pointer frame))))
+ (if info
+ (program-debug-info-name info)
+ (primitive-code-name (frame-instruction-pointer 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 three 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.
+;;
+;; 3. Alternately it's possible that we're between a primitive call
+;; and its associated return. In that case, we won't be able to
+;; say anything at all.
+
+(define* (frame-call-representation frame #:key top-frame?)
+ (let* ((ip (frame-instruction-pointer frame))
+ (info (find-program-debug-info ip))
+ (nlocals (frame-num-locals frame)))
+ (define (find-slot i bindings)
+ (match bindings
+ (() #f)
+ (((and binding ($ <binding> frame idx name slot)) . bindings)
+ (if (< idx i)
+ (find-slot i bindings)
+ (and (= idx i) binding)))))
+ (define (local-ref i bindings)
+ (cond
+ ((not bindings)
+ ;; This case is only hit for primitives and application
+ ;; arguments.
+ (frame-local-ref frame i 'scm))
+ ((find-slot i bindings)
+ => (lambda (binding)
+ (let ((val (frame-local-ref frame (binding-slot binding)
+ (binding-representation binding))))
+ ;; It could be that there's a value that isn't clobbered
+ ;; by a call but that isn't live after a call either. In
+ ;; that case, if GC runs during the call, the value will
+ ;; be collected, and on the stack it will be replaced
+ ;; with the unspecified value. Assume that clobbering
+ ;; values is more likely than passing the unspecified
+ ;; value as an argument, and replace unspecified with _,
+ ;; as if the binding were not available.
+ (if (unspecified? val) '_ val))))
+ (else
+ '_)))
+ (define (application-arguments)
+ ;; Case 1.
+ (map (lambda (local) (local-ref local #f))
+ ;; Cdr past the 0th local, which is the procedure.
+ (cdr (iota nlocals))))
+ (define (reconstruct-arguments bindings nreq nopt kw has-rest? local)
+ ;; Case 2.
+ (cond
+ ((positive? nreq)
+ (cons (local-ref local bindings)
+ (reconstruct-arguments bindings
+ (1- nreq) nopt kw has-rest? (1+ local))))
+ ((positive? nopt)
+ (cons (local-ref local bindings)
+ (reconstruct-arguments bindings
+ nreq (1- nopt) kw has-rest? (1+ local))))
+ ((pair? kw)
+ (cons* (caar kw) (local-ref (cdar kw) bindings)
+ (reconstruct-arguments bindings
+ nreq nopt (cdr kw) has-rest? (1+ local))))
+ (has-rest?
+ (local-ref local bindings))
+ (else
+ '())))
+ (cons
+ (or (frame-procedure-name frame #:info info) '_)
+ (cond
+ ((find-program-arity ip)
+ => (lambda (arity)
+ (if (and top-frame? (eqv? ip (arity-low-pc arity)))
+ (application-arguments)
+ (reconstruct-arguments
+ (available-bindings frame arity ip top-frame?)
+ (arity-nreq arity)
+ (arity-nopt arity)
+ (arity-keyword-args arity)
+ (arity-has-rest? arity)
+ 1))))
+ ((and (primitive-code? ip)
+ (program-arguments-alist (frame-local-ref frame 0 'scm) ip))
+ => (lambda (args)
+ (match args
+ ((('required . req)
+ ('optional . opt)
+ ('keyword . kw)
+ ('allow-other-keys? . _)
+ ('rest . rest))
+ (reconstruct-arguments #f
+ (length req) (length opt) kw rest 1)))))
+ (else
+ (application-arguments))))))
+
+
+
+;;; Misc
+;;;
+
+(define (frame-environment frame)
+ (map (lambda (binding)
+ (cons (binding-name binding) (binding-ref binding)))
+ (frame-bindings frame)))
+
+(define (frame-object-binding frame obj)
+ (do ((bs (frame-bindings frame) (cdr bs)))
+ ((or (null? bs) (eq? obj (binding-ref (car bs))))
+ (and (pair? bs) (car bs)))))
+
+(define (frame-object-name frame obj)
+ (cond ((frame-object-binding frame obj) => binding-name)
+ (else #f)))