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 program)
  24   :use-module ((srfi srfi-1) :select (fold))
  25   :export (frame-number frame-address
  26            make-frame-chain
  27            print-frame print-frame-chain-as-backtrace
  28            frame-arguments frame-local-variables frame-external-variables
  29            frame-environment
  30            frame-variable-exists? frame-variable-ref frame-variable-set!
  31            frame-object-name
  32            frame-local-ref frame-external-link frame-local-set!
  33            frame-return-address frame-program
  34            frame-dynamic-link frame?))
  35
  36 (dynamic-call "scm_init_frames" (dynamic-link "libguile-vm"))
  37
  38 ;;;
  39 ;;; Frame chain
  40 ;;;
  41
  42 (define frame-number (make-object-property))
  43 (define frame-address (make-object-property))
  44
  45 (define (make-frame-chain frame addr)
  46   (let* ((link (frame-dynamic-link frame))
  47          (chain (cons frame
  48                       (if (eq? link #t)
  49                           '()
  50                           (make-frame-chain
  51                            link (frame-return-address frame))))))
  52     (set! (frame-number frame) (1- (length chain)))
  53     (set! (frame-address frame)
  54           (- addr (program-base (frame-program frame))))
  55     chain))
  56
  57 \f
  58 ;;;
  59 ;;; Pretty printing
  60 ;;;
  61
  62 (define (frame-line-number frame)
  63   (let ((addr (frame-address frame)))
  64     (cond ((assv-ref (program-sources (frame-program frame)) addr)
  65            => source:line)
  66           (else (format #f "@~a" addr)))))
  67
  68 (define (frame-file frame prev)
  69   (let ((sources (program-sources (frame-program frame))))
  70     (if (null? sources)
  71         prev
  72         (or (source:file (car sources))
  73             "current input"))))
  74
  75 (define (print-frame frame)
  76   (format #t "~4@a: ~a ~a\n" (frame-line-number frame) (frame-number frame)
  77           (frame-call-representation frame)))
  78
  79
  80 (define (frame-call-representation frame)
  81   (define (abbrev x)
  82     (cond ((list? x)
  83            (if (> (length x) 3)
  84                (list (abbrev (car x)) (abbrev (cadr x)) '...)
  85                (map abbrev x)))
  86           ((pair? x)
  87            (cons (abbrev (car x)) (abbrev (cdr x))))
  88           ((vector? x)
  89            (case (vector-length x)
  90              ((0) x)
  91              ((1) (vector (abbrev (vector-ref x 0))))
  92              (else (vector (abbrev (vector-ref x 0)) '...))))
  93           (else x)))
  94   (abbrev (cons (program-name frame) (frame-arguments frame))))
  95
  96 (define (print-frame-chain-as-backtrace frames)
  97   (if (null? frames)
  98       (format #t "No backtrace available.\n")
  99       (begin
 100         (format #t "Backtrace:\n")
 101         (pk frames (map frame-program frames)
 102              (map frame-address frames)
 103              )
 104         (fold (lambda (frame file)
 105                 (let ((new-file (frame-file frame file)))
 106                   (if (not (eqv? new-file file))
 107                       (format #t "In ~a:\n" new-file))
 108                   (print-frame frame)
 109                   new-file))
 110               'no-file
 111               frames))))
 112
 113 (define (program-name frame)
 114   (let ((prog (frame-program frame))
 115         (link (frame-dynamic-link frame)))
 116     (or (object-property prog 'name)
 117         (and (frame? link)
 118              (frame-object-name link (1- (frame-address link)) prog))
 119         (hash-fold (lambda (s v d) (if (eq? prog (variable-ref v)) s d))
 120                    prog (module-obarray (current-module))))))
 121
 122 \f
 123 ;;;
 124 ;;; Frames
 125 ;;;
 126
 127 (define (frame-arguments frame)
 128   (let* ((prog (frame-program frame))
 129          (arity (program-arity prog)))
 130     (do ((n (+ (arity:nargs arity) -1) (1- n))
 131          (l '() (cons (frame-local-ref frame n) l)))
 132         ((< n 0) l))))
 133
 134 (define (frame-local-variables frame)
 135   (let* ((prog (frame-program frame))
 136          (arity (program-arity prog)))
 137     (do ((n (+ (arity:nargs arity) (arity:nlocs arity) -1) (1- n))
 138          (l '() (cons (frame-local-ref frame n) l)))
 139         ((< n 0) l))))
 140
 141 (define (frame-external-variables frame)
 142   (frame-external-link frame))
 143
 144 (define (frame-external-ref frame index)
 145   (list-ref (frame-external-link frame) index))
 146
 147 (define (frame-external-set! frame index val)
 148   (list-set! (frame-external-link frame) index val))
 149
 150 (define (frame-binding-ref frame binding)
 151   (if (binding:extp binding)
 152     (frame-external-ref frame (binding:index binding))
 153     (frame-local-ref frame (binding:index binding))))
 154
 155 (define (frame-binding-set! frame binding val)
 156   (if (binding:extp binding)
 157     (frame-external-set! frame (binding:index binding) val)
 158     (frame-local-set! frame (binding:index binding) val)))
 159
 160 (define (frame-bindings frame addr)
 161   (do ((bs (program-bindings (frame-program frame)) (cdr bs))
 162        (ls '() (if (cdar bs) (cons (cdar bs) ls) (cdr ls))))
 163       ((or (null? bs) (> (caar bs) addr))
 164        (apply append ls))))
 165
 166 (define (frame-lookup-binding frame addr sym)
 167   (do ((bs (frame-bindings frame addr) (cdr bs)))
 168       ((or (null? bs) (eq? sym (binding:name (car bs))))
 169        (and (pair? bs) (car bs)))))
 170
 171 (define (frame-object-binding frame addr obj)
 172   (do ((bs (frame-bindings frame addr) (cdr bs)))
 173       ((or (null? bs) (eq? obj (frame-binding-ref frame (car bs))))
 174        (and (pair? bs) (car bs)))))
 175
 176 (define (frame-environment frame addr)
 177   (map (lambda (binding)
 178          (cons (binding:name binding) (frame-binding-ref frame binding)))
 179        (frame-bindings frame addr)))
 180
 181 (define (frame-variable-exists? frame addr sym)
 182   (if (frame-lookup-binding frame addr sym) #t #f))
 183
 184 (define (frame-variable-ref frame addr sym)
 185   (cond ((frame-lookup-binding frame addr sym) =>
 186          (lambda (binding) (frame-binding-ref frame binding)))
 187         (else (error "Unknown variable:" sym))))
 188
 189 (define (frame-variable-set! frame addr sym val)
 190   (cond ((frame-lookup-binding frame addr sym) =>
 191          (lambda (binding) (frame-binding-set! frame binding val)))
 192         (else (error "Unknown variable:" sym))))
 193
 194 (define (frame-object-name frame addr obj)
 195   (cond ((frame-object-binding frame addr obj) => binding:name)
 196         (else #f)))