module/system/vm/frame.scm

   1 ;;; Guile VM frame functions
   2
   3 ;;; Copyright (C) 2001, 2005, 2009, 2010, 2011 Free Software Foundation, Inc.
   4 ;;;
   5 ;;; This library is free software; you can redistribute it and/or
   6 ;;; modify it under the terms of the GNU Lesser General Public
   7 ;;; License as published by the Free Software Foundation; either
   8 ;;; version 3 of the License, or (at your option) any later version.
   9 ;;;
  10 ;;; This library is distributed in the hope that it will be useful,
  11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;; Lesser General Public License for more details.
  14 ;;;
  15 ;;; You should have received a copy of the GNU Lesser General Public
  16 ;;; License along with this library; if not, write to the Free Software
  17 ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 ;;; Code:
  20
  21 (define-module (system vm frame)
  22   #:use-module (system base pmatch)
  23   #:use-module (system vm program)
  24   #:use-module (system vm instruction)
  25   #:use-module (system vm objcode)
  26   #:export (frame-bindings
  27             frame-lookup-binding
  28             frame-binding-ref frame-binding-set!
  29             frame-next-source frame-call-representation
  30             frame-environment
  31             frame-object-binding frame-object-name
  32             frame-return-values))
  33
  34 (define (frame-bindings frame)
  35   (program-bindings-for-ip (frame-procedure frame)
  36                            (frame-instruction-pointer frame)))
  37
  38 (define (frame-lookup-binding frame var)
  39   (let lp ((bindings (frame-bindings frame)))
  40     (cond ((null? bindings)
  41            #f)
  42           ((eq? (binding:name (car bindings)) var)
  43            (car bindings))
  44           (else
  45            (lp (cdr bindings))))))
  46
  47 (define (frame-binding-set! frame var val)
  48   (frame-local-set! frame
  49                     (binding:index
  50                      (or (frame-lookup-binding frame var)
  51                          (error "variable not bound in frame" var frame)))
  52                     val))
  53
  54 (define (frame-binding-ref frame var)
  55   (frame-local-ref frame
  56                    (binding:index
  57                     (or (frame-lookup-binding frame var)
  58                         (error "variable not bound in frame" var frame)))))
  59
  60
  61 ;; This function is always called to get some sort of representation of the
  62 ;; frame to present to the user, so let's do the logical thing and dispatch to
  63 ;; frame-call-representation.
  64 (define (frame-arguments frame)
  65   (cdr (frame-call-representation frame)))
  66
  67
  68 \f
  69 ;;;
  70 ;;; Pretty printing
  71 ;;;
  72
  73 (define (frame-next-source frame)
  74   (let ((proc (frame-procedure frame)))
  75     (program-source proc
  76                     (frame-instruction-pointer frame)
  77                     (program-sources-pre-retire proc))))
  78
  79
  80 ;; Basically there are two cases to deal with here:
  81 ;;
  82 ;;   1. We've already parsed the arguments, and bound them to local
  83 ;;      variables. In a standard (lambda (a b c) ...) call, this doesn't
  84 ;;      involve any argument shuffling; but with rest, optional, or
  85 ;;      keyword arguments, the arguments as given to the procedure may
  86 ;;      not correspond to what's on the stack. We reconstruct the
  87 ;;      arguments using e.g. for the case above: `(,a ,b ,c). This works
  88 ;;      for rest arguments too: (a b . c) => `(,a ,b . ,c)
  89 ;;
  90 ;;   2. We have failed to parse the arguments. Perhaps it's the wrong
  91 ;;      number of arguments, or perhaps we're doing a typed dispatch and
  92 ;;      the types don't match. In that case the arguments are all on the
  93 ;;      stack, and nothing else is on the stack.
  94
  95 (define (frame-call-representation frame)
  96   (let ((p (frame-procedure frame)))
  97     (cons
  98      (or (procedure-name p) p)
  99      (cond
 100       ((program-arguments-alist p (frame-instruction-pointer frame))
 101        ;; case 1
 102        => (lambda (arguments)
 103             (define (binding-ref sym i)
 104               (cond
 105                ((frame-lookup-binding frame sym)
 106                 => (lambda (b) (frame-local-ref frame (binding:index b))))
 107                ((< i (frame-num-locals frame))
 108                 (frame-local-ref frame i))
 109                (else
 110                 ;; let's not error here, as we are called during backtraces...
 111                 '???)))
 112             (let lp ((req (or (assq-ref arguments 'required) '()))
 113                      (opt (or (assq-ref arguments 'optional) '()))
 114                      (key (or (assq-ref arguments 'keyword) '()))
 115                      (rest (or (assq-ref arguments 'rest) #f))
 116                      (i 0))
 117               (cond
 118                ((pair? req)
 119                 (cons (binding-ref (car req) i)
 120                       (lp (cdr req) opt key rest (1+ i))))
 121                ((pair? opt)
 122                 (cons (binding-ref (car opt) i)
 123                       (lp req (cdr opt) key rest (1+ i))))
 124                ((pair? key)
 125                 (cons* (caar key)
 126                        (frame-local-ref frame (cdar key))
 127                        (lp req opt (cdr key) rest (1+ i))))
 128                (rest
 129                 (binding-ref rest i))
 130                (else
 131                 '())))))
 132       (else
 133        ;; case 2
 134        (map (lambda (i)
 135               (frame-local-ref frame i))
 136             (iota (frame-num-locals frame))))))))
 137
 138
 139 \f
 140 ;;; Misc
 141 ;;;
 142
 143 (define (frame-environment frame)
 144   (map (lambda (binding)
 145          (cons (binding:name binding) (frame-binding-ref frame binding)))
 146        (frame-bindings frame)))
 147
 148 (define (frame-object-binding frame obj)
 149   (do ((bs (frame-bindings frame) (cdr bs)))
 150       ((or (null? bs) (eq? obj (frame-binding-ref frame (car bs))))
 151        (and (pair? bs) (car bs)))))
 152
 153 (define (frame-object-name frame obj)
 154   (cond ((frame-object-binding frame obj) => binding:name)
 155         (else #f)))
 156
 157 ;; Nota bene, only if frame is in a return context (i.e. in a
 158 ;; pop-continuation hook dispatch).
 159 (define (frame-return-values frame)
 160   (let* ((len (frame-num-locals frame))
 161          (nvalues (frame-local-ref frame (1- len))))
 162     (map (lambda (i)
 163            (frame-local-ref frame (+ (- len nvalues 1) i)))
 164          (iota nvalues))))