module/system/vm/frame.scm

   1 ;;; Guile VM frame functions
   2
   3 ;;; Copyright (C) 2001 Free Software Foundation, Inc.
   4 ;;; Copyright (C) 2005 Ludovic Courtès  <ludovic.courtes@laas.fr>
   5 ;;;
   6 ;;; This program is free software; you can redistribute it and/or modify
   7 ;;; it under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 2 of the License, or
   9 ;;; (at your option) any later version.
  10 ;;;
  11 ;;; This program is distributed in the hope that it will be useful,
  12 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with this program; if not, write to the Free Software
  18 ;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  19
  20 ;;; Code:
  21
  22 (define-module (system vm frame)
  23   :use-module ((system vm core) :renamer (symbol-prefix-proc 'vm:))
  24   :export (frame-number frame-address
  25            vm-current-frame-chain vm-last-frame-chain
  26            print-frame print-frame-call))
  27
  28 \f
  29 ;;;
  30 ;;; Frame chain
  31 ;;;
  32
  33 (define frame-number (make-object-property))
  34 (define frame-address (make-object-property))
  35
  36 (define (vm-current-frame-chain vm)
  37   (make-frame-chain (vm:vm-this-frame vm) (vm:vm:ip vm)))
  38
  39 (define (vm-last-frame-chain vm)
  40   (make-frame-chain (vm:vm-last-frame vm) (vm:vm:ip vm)))
  41
  42 (define (make-frame-chain frame addr)
  43   (let* ((link (vm:frame-dynamic-link frame))
  44          (chain (if (eq? link #t)
  45                   '()
  46                   (cons frame (make-frame-chain
  47                                link (vm:frame-return-address frame))))))
  48     (set! (frame-number frame) (length chain))
  49     (set! (frame-address frame)
  50           (- addr (program-base (vm:frame-program frame))))
  51     chain))
  52
  53 \f
  54 ;;;
  55 ;;; Pretty printing
  56 ;;;
  57
  58 (define (print-frame frame)
  59   (format #t "#~A " (vm:frame-number frame))
  60   (print-frame-call frame)
  61   (newline))
  62
  63 (define (print-frame-call frame)
  64   (define (abbrev x)
  65     (cond ((list? x)   (if (> (length x) 3)
  66                          (list (abbrev (car x)) (abbrev (cadr x)) '...)
  67                          (map abbrev x)))
  68           ((pair? x)   (cons (abbrev (car x)) (abbrev (cdr x))))
  69           ((vector? x) (case (vector-length x)
  70                          ((0) x)
  71                          ((1) (vector (abbrev (vector-ref x 0))))
  72                          (else (vector (abbrev (vector-ref x 0)) '...))))
  73           (else x)))
  74   (write (abbrev (cons (program-name frame)
  75                        (vm:frame-arguments frame)))))
  76
  77 (define (program-name frame)
  78   (let ((prog (vm:frame-program frame))
  79         (link (vm:frame-dynamic-link frame)))
  80     (or (object-property prog 'name)
  81         (vm:frame-object-name link (1- (vm:frame-address link)) prog)
  82         (hash-fold (lambda (s v d) (if (eq? prog (variable-ref v)) s d))
  83                    prog (module-obarray (current-module))))))