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