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