module/system/vm/program.scm

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