module/system/vm/program.scm

   1 ;;; Guile VM program functions
   2
   3 ;;; Copyright (C) 2001, 2009, 2010 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 program)
  22   #:use-module (system base pmatch)
  23   #:use-module (system vm instruction)
  24   #:use-module (system vm objcode)
  25   #:use-module (rnrs bytevectors)
  26   #:use-module (srfi srfi-1)
  27   #:use-module (srfi srfi-26)
  28   #:export (make-program
  29
  30             make-binding binding:name binding:boxed? binding:index
  31             binding:start binding:end
  32
  33             source:addr source:line source:column source:file
  34             source:line-for-user
  35             program-sources program-sources-pre-retire program-source
  36
  37             program-bindings program-bindings-by-index program-bindings-for-ip
  38             program-arities program-arity arity:start arity:end
  39
  40             arity:nreq arity:nopt arity:rest? arity:kw arity:allow-other-keys?
  41
  42             program-arguments-alist program-lambda-list
  43
  44             program-meta
  45             program-objcode program? program-objects
  46             program-module program-base
  47             program-free-variables
  48             program-num-free-variables
  49             program-free-variable-ref program-free-variable-set!))
  50
  51 (load-extension (string-append "libguile-" (effective-version))
  52                 "scm_init_programs")
  53
  54 (define (make-binding name boxed? index start end)
  55   (list name boxed? index start end))
  56 (define (binding:name b) (list-ref b 0))
  57 (define (binding:boxed? b) (list-ref b 1))
  58 (define (binding:index b) (list-ref b 2))
  59 (define (binding:start b) (list-ref b 3))
  60 (define (binding:end b) (list-ref b 4))
  61
  62 (define (source:addr source)
  63   (car source))
  64 (define (source:file source)
  65   (cadr source))
  66 (define (source:line source)
  67   (caddr source))
  68 (define (source:column source)
  69   (cdddr source))
  70
  71 ;; Lines are zero-indexed inside Guile, but users expect them to be
  72 ;; one-indexed. Columns, on the other hand, are zero-indexed to both. Go
  73 ;; figure.
  74 (define (source:line-for-user source)
  75   (1+ (source:line source)))
  76
  77 ;; FIXME: pull this definition from elsewhere.
  78 (define *bytecode-header-len* 8)
  79
  80 ;; We could decompile the program to get this, but that seems like a
  81 ;; waste.
  82 (define (bytecode-instruction-length bytecode ip)
  83   (let* ((idx (+ ip *bytecode-header-len*))
  84          (inst (opcode->instruction (bytevector-u8-ref bytecode idx))))
  85     ;; 1+ for the instruction itself.
  86     (1+ (cond
  87          ((eq? inst 'load-program)
  88           (+ (bytevector-u32-native-ref bytecode (+ idx 1))
  89              (bytevector-u32-native-ref bytecode (+ idx 5))))
  90          ((< (instruction-length inst) 0)
  91           ;; variable length instruction -- the length is encoded in the
  92           ;; instruction stream.
  93           (+ (ash (bytevector-u8-ref bytecode (+ idx 1)) 16)
  94              (ash (bytevector-u8-ref bytecode (+ idx 2)) 8)
  95              (bytevector-u8-ref bytecode (+ idx 3))))
  96          (else
  97           ;; fixed length
  98           (instruction-length inst))))))
  99
 100 ;; Source information could in theory be correlated with the ip of the
 101 ;; instruction, or the ip just after the instruction is retired. Guile
 102 ;; does the latter, to make backtraces easy -- an error produced while
 103 ;; running an opcode always happens after it has retired its arguments.
 104 ;;
 105 ;; But for breakpoints and such, we need the ip before the instruction
 106 ;; is retired -- before it has had a chance to do anything. So here we
 107 ;; change from the post-retire addresses given by program-sources to
 108 ;; pre-retire addresses.
 109 ;;
 110 (define (program-sources-pre-retire proc)
 111   (let ((bv (objcode->bytecode (program-objcode proc))))
 112     (let lp ((in (program-sources proc))
 113              (out '())
 114              (ip 0))
 115       (cond
 116        ((null? in)
 117         (reverse out))
 118        (else
 119         (pmatch (car in)
 120           ((,post-ip . ,source)
 121            (let lp2 ((ip ip)
 122                      (next ip))
 123              (if (< next post-ip)
 124                  (lp2 next (+ next (bytecode-instruction-length bv next)))
 125                  (lp (cdr in)
 126                      (acons ip source out)
 127                      next))))
 128           (else
 129            (error "unexpected"))))))))
 130
 131 (define (collapse-locals locs)
 132   (let lp ((ret '()) (locs locs))
 133     (if (null? locs)
 134         (map cdr (sort! ret
 135                         (lambda (x y) (< (car x) (car y)))))
 136         (let ((b (car locs)))
 137           (cond
 138            ((assv-ref ret (binding:index b))
 139             => (lambda (bindings)
 140                  (append! bindings (list b))
 141                  (lp ret (cdr locs))))
 142            (else
 143             (lp (acons (binding:index b) (list b) ret)
 144                 (cdr locs))))))))
 145
 146 ;; returns list of list of bindings
 147 ;; (list-ref ret N) == bindings bound to the Nth local slot
 148 (define (program-bindings-by-index prog)
 149   (cond ((program-bindings prog) => collapse-locals)
 150         (else '())))
 151
 152 (define (program-bindings-for-ip prog ip)
 153   (let lp ((in (program-bindings-by-index prog)) (out '()))
 154     (if (null? in)
 155         (reverse out)
 156         (lp (cdr in)
 157             (let inner ((binds (car in)))
 158               (cond ((null? binds) out)
 159                     ((<= (binding:start (car binds))
 160                          ip
 161                          (binding:end (car binds)))
 162                      (cons (car binds) out))
 163                     (else (inner (cdr binds)))))))))
 164
 165 (define (arity:start a)
 166   (pmatch a ((,start ,end . _) start) (else (error "bad arity" a))))
 167 (define (arity:end a)
 168   (pmatch a ((,start ,end . _) end) (else (error "bad arity" a))))
 169 (define (arity:nreq a)
 170   (pmatch a ((_ _ ,nreq . _) nreq) (else 0)))
 171 (define (arity:nopt a)
 172   (pmatch a ((_ _ ,nreq ,nopt . _) nopt) (else 0)))
 173 (define (arity:rest? a)
 174   (pmatch a ((_ _ ,nreq ,nopt ,rest? . _) rest?) (else #f)))
 175 (define (arity:kw a)
 176   (pmatch a ((_ _ ,nreq ,nopt ,rest? (_ . ,kw)) kw) (else '())))
 177 (define (arity:allow-other-keys? a)
 178   (pmatch a ((_ _ ,nreq ,nopt ,rest? (,aok . ,kw)) aok) (else #f)))
 179
 180 (define (program-arity prog ip)
 181   (let ((arities (program-arities prog)))
 182     (and arities
 183          (let lp ((arities arities))
 184            (cond ((null? arities) #f)
 185                  ((not ip) (car arities)) ; take the first one
 186                  ((and (< (arity:start (car arities)) ip)
 187                        (<= ip (arity:end (car arities))))
 188                   (car arities))
 189                  (else (lp (cdr arities))))))))
 190
 191 (define (arglist->arguments-alist arglist)
 192   (pmatch arglist
 193     ((,req ,opt ,keyword ,allow-other-keys? ,rest . ,extents)
 194      `((required . ,req)
 195        (optional . ,opt)
 196        (keyword . ,keyword)
 197        (allow-other-keys? . ,allow-other-keys?)
 198        (rest . ,rest)
 199        (extents . ,extents)))
 200     (else #f)))
 201
 202 (define* (arity->arguments-alist prog arity
 203                                  #:optional
 204                                  (make-placeholder
 205                                   (lambda (i) (string->symbol "_"))))
 206   (define var-by-index
 207     (let ((rbinds (map (lambda (x)
 208                          (cons (binding:index x) (binding:name x)))
 209                        (program-bindings-for-ip prog
 210                                                 (arity:start arity)))))
 211       (lambda (i)
 212         (or (assv-ref rbinds i)
 213             ;; if we don't know the name, return a placeholder
 214             (make-placeholder i)))))
 215
 216   (let lp ((nreq (arity:nreq arity)) (req '())
 217            (nopt (arity:nopt arity)) (opt '())
 218            (rest? (arity:rest? arity)) (rest #f)
 219            (n 0))
 220     (cond
 221      ((< 0 nreq)
 222       (lp (1- nreq) (cons (var-by-index n) req)
 223           nopt opt rest? rest (1+ n)))
 224      ((< 0 nopt)
 225       (lp nreq req
 226           (1- nopt) (cons (var-by-index n) opt)
 227           rest? rest (1+ n)))
 228      (rest?
 229       (lp nreq req nopt opt
 230           #f (var-by-index n)
 231           (1+ n)))
 232      (else
 233       `((required . ,(reverse req))
 234         (optional . ,(reverse opt))
 235         (keyword . ,(arity:kw arity))
 236         (allow-other-keys? . ,(arity:allow-other-keys? arity))
 237         (rest . ,rest))))))
 238
 239 ;; the name "program-arguments" is taken by features.c...
 240 (define* (program-arguments-alist prog #:optional ip)
 241   (let ((arity (program-arity prog ip)))
 242     (and arity
 243          (arity->arguments-alist prog arity))))
 244
 245 (define* (program-lambda-list prog #:optional ip)
 246   (and=> (program-arguments-alist prog ip) arguments-alist->lambda-list))
 247
 248 (define (arguments-alist->lambda-list arguments-alist)
 249   (let ((req (or (assq-ref arguments-alist 'required) '()))
 250         (opt (or (assq-ref arguments-alist 'optional) '()))
 251         (key (map keyword->symbol
 252                   (map car (or (assq-ref arguments-alist 'keyword) '()))))
 253         (rest (or (assq-ref arguments-alist 'rest) '())))
 254     `(,@req
 255       ,@(if (pair? opt) (cons #:optional opt) '())
 256       ,@(if (pair? key) (cons #:key key) '())
 257       . ,rest)))
 258
 259 (define (program-free-variables prog)
 260   "Return the list of free variables of PROG."
 261   (let ((count (program-num-free-variables prog)))
 262     (unfold (lambda (i) (>= i count))
 263             (cut program-free-variable-ref prog <>)
 264             1+
 265             0)))
 266
 267 (define (write-program prog port)
 268   (format port "#<procedure ~a~a>"
 269           (or (procedure-name prog)
 270               (and=> (program-source prog 0)
 271                      (lambda (s)
 272                        (format #f "~a at ~a:~a:~a"
 273                                (number->string (object-address prog) 16)
 274                                (or (source:file s)
 275                                    (if s "<current input>" "<unknown port>"))
 276                                (source:line-for-user s) (source:column s))))
 277               (number->string (object-address prog) 16))
 278           (let ((arities (program-arities prog)))
 279             (if (or (not arities) (null? arities))
 280                 ""
 281                 (string-append
 282                  " " (string-join (map (lambda (a)
 283                                          (object->string
 284                                           (arguments-alist->lambda-list
 285                                            (arity->arguments-alist prog a))))
 286                                        arities)
 287                                   " | "))))))
 288