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