module/system/vm/frame.scm

   1 ;;; Guile VM frame functions
   2
   3 ;;; Copyright (C) 2001, 2005, 2009, 2010, 2011, 2012 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   (let ((p (frame-procedure frame)))
  36     (if (program? p)
  37         (program-bindings-for-ip p (frame-instruction-pointer frame))
  38         '())))
  39
  40 (define (frame-lookup-binding frame var)
  41   (let lp ((bindings (frame-bindings frame)))
  42     (cond ((null? bindings)
  43            #f)
  44           ((eq? (binding:name (car bindings)) var)
  45            (car bindings))
  46           (else
  47            (lp (cdr bindings))))))
  48
  49 (define (frame-binding-set! frame var val)
  50   (frame-local-set! frame
  51                     (binding:index
  52                      (or (frame-lookup-binding frame var)
  53                          (error "variable not bound in frame" var frame)))
  54                     val))
  55
  56 (define (frame-binding-ref frame var)
  57   (frame-local-ref frame
  58                    (binding:index
  59                     (or (frame-lookup-binding frame var)
  60                         (error "variable not bound in frame" var frame)))))
  61
  62
  63 ;; This function is always called to get some sort of representation of the
  64 ;; frame to present to the user, so let's do the logical thing and dispatch to
  65 ;; frame-call-representation.
  66 (define (frame-arguments frame)
  67   (cdr (frame-call-representation frame)))
  68
  69
  70 \f
  71 ;;;
  72 ;;; Pretty printing
  73 ;;;
  74
  75 (define (frame-next-source frame)
  76   (let ((proc (frame-procedure frame)))
  77     (if (program? proc)
  78         (program-source proc
  79                         (frame-instruction-pointer frame)
  80                         (program-sources-pre-retire proc))
  81         '())))
  82
  83
  84 ;; Basically there are two cases to deal with here:
  85 ;;
  86 ;;   1. We've already parsed the arguments, and bound them to local
  87 ;;      variables. In a standard (lambda (a b c) ...) call, this doesn't
  88 ;;      involve any argument shuffling; but with rest, optional, or
  89 ;;      keyword arguments, the arguments as given to the procedure may
  90 ;;      not correspond to what's on the stack. We reconstruct the
  91 ;;      arguments using e.g. for the case above: `(,a ,b ,c). This works
  92 ;;      for rest arguments too: (a b . c) => `(,a ,b . ,c)
  93 ;;
  94 ;;   2. We have failed to parse the arguments. Perhaps it's the wrong
  95 ;;      number of arguments, or perhaps we're doing a typed dispatch and
  96 ;;      the types don't match. In that case the arguments are all on the
  97 ;;      stack, and nothing else is on the stack.
  98
  99 (define (frame-call-representation frame)
 100   (let ((p (frame-procedure frame)))
 101     (cons
 102      (or (false-if-exception (procedure-name p)) p)
 103      (cond
 104       ((and (program? p)
 105             (program-arguments-alist p (frame-instruction-pointer frame)))
 106        ;; case 1
 107        => (lambda (arguments)
 108             (define (binding-ref sym i)
 109               (cond
 110                ((frame-lookup-binding frame sym)
 111                 => (lambda (b) (frame-local-ref frame (binding:index b))))
 112                ((< i (frame-num-locals frame))
 113                 (frame-local-ref frame i))
 114                (else
 115                 ;; let's not error here, as we are called during backtraces...
 116                 '???)))
 117             (let lp ((req (or (assq-ref arguments 'required) '()))
 118                      (opt (or (assq-ref arguments 'optional) '()))
 119                      (key (or (assq-ref arguments 'keyword) '()))
 120                      (rest (or (assq-ref arguments 'rest) #f))
 121                      (i 0))
 122               (cond
 123                ((pair? req)
 124                 (cons (binding-ref (car req) i)
 125                       (lp (cdr req) opt key rest (1+ i))))
 126                ((pair? opt)
 127                 (cons (binding-ref (car opt) i)
 128                       (lp req (cdr opt) key rest (1+ i))))
 129                ((pair? key)
 130                 (cons* (caar key)
 131                        (frame-local-ref frame (cdar key))
 132                        (lp req opt (cdr key) rest (1+ i))))
 133                (rest
 134                 (binding-ref rest i))
 135                (else
 136                 '())))))
 137       (else
 138        ;; case 2
 139        (map (lambda (i)
 140               (frame-local-ref frame i))
 141             (iota (frame-num-locals frame))))))))
 142
 143
 144 \f
 145 ;;; Misc
 146 ;;;
 147
 148 (define (frame-environment frame)
 149   (map (lambda (binding)
 150          (cons (binding:name binding) (frame-binding-ref frame binding)))
 151        (frame-bindings frame)))
 152
 153 (define (frame-object-binding frame obj)
 154   (do ((bs (frame-bindings frame) (cdr bs)))
 155       ((or (null? bs) (eq? obj (frame-binding-ref frame (car bs))))
 156        (and (pair? bs) (car bs)))))
 157
 158 (define (frame-object-name frame obj)
 159   (cond ((frame-object-binding frame obj) => binding:name)
 160         (else #f)))
 161
 162 ;; Nota bene, only if frame is in a return context (i.e. in a
 163 ;; pop-continuation hook dispatch).
 164 (define (frame-return-values frame)
 165   (let* ((len (frame-num-locals frame))
 166          (nvalues (frame-local-ref frame (1- len))))
 167     (map (lambda (i)
 168            (frame-local-ref frame (+ (- len nvalues 1) i)))
 169          (iota nvalues))))