diff options
Diffstat (limited to 'module/system/vm/frame.scm')
-rw-r--r-- | module/system/vm/frame.scm | 463 |
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))) |