module/system/vm/frame.scm

   1 ;;; Guile VM frame functions
   2
   3 ;;; Copyright (C) 2001, 2005, 2009, 2010, 2011, 2012, 2013, 2014 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 frame)
  22   #:use-module (system base pmatch)
  23   #:use-module (system foreign)
  24   #:use-module (system vm program)
  25   #:use-module (system vm debug)
  26   #:use-module (system vm disassembler)
  27   #:use-module (rnrs bytevectors)
  28   #:use-module (ice-9 match)
  29   #:export (frame-bindings
  30             frame-lookup-binding
  31             frame-binding-ref frame-binding-set!
  32             frame-call-representation
  33             frame-environment
  34             frame-object-binding frame-object-name))
  35
  36 (define (parse-code code)
  37   (let ((len (bytevector-length code)))
  38     (let lp ((pos 0) (out '()))
  39       (cond
  40        ((< pos len)
  41         (let* ((inst-len (instruction-length code pos))
  42                (pos (+ pos inst-len)))
  43           (unless (<= pos len)
  44             (error "Failed to parse codestream"))
  45           (lp pos (cons inst-len out))))
  46        (else
  47         (list->vector (reverse out)))))))
  48
  49 (define (compute-predecessors code parsed)
  50   (let ((preds (make-vector (vector-length parsed) '())))
  51     (define (add-pred! from target)
  52       (let lp ((to from) (target target))
  53         (cond
  54          ((negative? target)
  55           (lp (1- to) (+ target (vector-ref parsed to))))
  56          ((positive? target)
  57           (lp (1+ to) (- target (vector-ref parsed to))))
  58          ((= to (vector-length preds))
  59           ;; This can happen when an arity fails to match.  Just ignore
  60           ;; this case.
  61           #t)
  62          (else
  63           (vector-set! preds to (cons from (vector-ref preds to)))))))
  64     (let lp ((n 0) (pos 0))
  65       (when (< n (vector-length preds))
  66         (when (instruction-has-fallthrough? code pos)
  67           (add-pred! n (vector-ref parsed n)))
  68         (for-each (lambda (target)
  69                     (add-pred! n target))
  70                   (instruction-relative-jump-targets code pos))
  71         (lp (1+ n) (+ pos (vector-ref parsed n)))))
  72     preds))
  73
  74 (define (compute-genv parsed defs)
  75   (let ((genv (make-vector (vector-length parsed) '())))
  76     (define (add-def! pos var)
  77       (vector-set! genv pos (cons var (vector-ref genv pos))))
  78     (let lp ((var 0) (pos 0) (pc-offset 0))
  79       (when (< var (vector-length defs))
  80         (match (vector-ref defs var)
  81           (#(name offset slot)
  82            (when (< offset pc-offset)
  83              (error "mismatch between def offsets and parsed code"))
  84            (cond
  85             ((< pc-offset offset)
  86              (lp var (1+ pos) (+ pc-offset (vector-ref parsed pos))))
  87             (else
  88              (add-def! pos var)
  89              (lp (1+ var) pos pc-offset)))))))
  90     genv))
  91
  92 (define (compute-defs-by-slot defs)
  93   (let* ((nslots (match defs
  94                    (#(#(_ _ slot) ...) (1+ (apply max slot)))))
  95          (by-slot (make-vector nslots #f)))
  96     (let lp ((n 0))
  97       (when (< n nslots)
  98         (vector-set! by-slot n (make-bitvector (vector-length defs) #f))
  99         (lp (1+ n))))
 100     (let lp ((n 0))
 101       (when (< n (vector-length defs))
 102         (match (vector-ref defs n)
 103           (#(_ _ slot)
 104            (bitvector-set! (vector-ref by-slot slot) n #t)
 105            (lp (1+ n))))))
 106     by-slot))
 107
 108 (define (compute-killv code parsed defs)
 109   (let ((defs-by-slot (compute-defs-by-slot defs))
 110         (killv (make-vector (vector-length parsed) #f)))
 111     (define (kill-slot! n slot)
 112       (bit-set*! (vector-ref killv n) (vector-ref defs-by-slot slot) #t))
 113     (let lp ((n 0))
 114       (when (< n (vector-length killv))
 115         (vector-set! killv n (make-bitvector (vector-length defs) #f))
 116         (lp (1+ n))))
 117     ;; Some defs get into place without explicit instructions -- this is
 118     ;; the case if no shuffling need occur, for example.  In any case,
 119     ;; mark them as killing any previous definitions at that slot.
 120     (let lp ((var 0) (pos 0) (pc-offset 0))
 121       (when (< var (vector-length defs))
 122         (match (vector-ref defs var)
 123           (#(name offset slot)
 124            (when (< offset pc-offset)
 125              (error "mismatch between def offsets and parsed code"))
 126            (cond
 127             ((< pc-offset offset)
 128              (lp var (1+ pos) (+ pc-offset (vector-ref parsed pos))))
 129             (else
 130              (kill-slot! pos slot)
 131              (lp (1+ var) pos pc-offset)))))))
 132     (let lp ((n 0) (pos 0))
 133       (when (< n (vector-length parsed))
 134         (for-each (lambda (slot)
 135                     (when (< slot (vector-length defs-by-slot))
 136                       (kill-slot! n slot)))
 137                   (instruction-slot-clobbers code pos
 138                                              (vector-length defs-by-slot)))
 139         (lp (1+ n) (+ pos (vector-ref parsed n)))))
 140     killv))
 141
 142 (define (available-bindings arity ip top-frame?)
 143   (let* ((defs (list->vector (arity-definitions arity)))
 144          (code (arity-code arity))
 145          (parsed (parse-code code))
 146          (len (vector-length parsed))
 147          (preds (compute-predecessors code parsed))
 148          (genv (compute-genv parsed defs))
 149          (killv (compute-killv code parsed defs))
 150          (inv (make-vector len #f))
 151          (outv (make-vector len #f))
 152          (tmp (make-bitvector (vector-length defs) #f)))
 153     (define (bitvector-copy! dst src)
 154       (bitvector-fill! dst #f)
 155       (bit-set*! dst src #t))
 156     (define (bitvector-meet! accum src)
 157       (bitvector-copy! tmp src)
 158       (bit-invert! tmp)
 159       (bit-set*! accum tmp #f))
 160
 161     (let lp ((n 0))
 162       (when (< n len)
 163         (vector-set! inv n (make-bitvector (vector-length defs) #f))
 164         (vector-set! outv n (make-bitvector (vector-length defs) #f))
 165         (lp (1+ n))))
 166
 167     (let lp ((n 0) (first? #t) (changed? #f))
 168       (cond
 169        ((< n len)
 170         (let ((in (vector-ref inv n))
 171               (out (vector-ref outv n))
 172               (kill (vector-ref killv n))
 173               (gen (vector-ref genv n)))
 174           (let ((out-count (or changed? (bit-count #t out))))
 175             (bitvector-fill! in (not (zero? n)))
 176             (let lp ((preds (vector-ref preds n)))
 177               (match preds
 178                 (() #t)
 179                 ((pred . preds)
 180                  (unless (and first? (<= n pred))
 181                    (bitvector-meet! in (vector-ref outv pred)))
 182                  (lp preds))))
 183             (bitvector-copy! out in)
 184             (bit-set*! out kill #f)
 185             (for-each (lambda (def)
 186                         (bitvector-set! out def #t))
 187                       gen)
 188             (lp (1+ n) first?
 189                 (or changed? (not (eqv? out-count (bit-count #t out))))))))
 190        ((or changed? first?)
 191         (lp 0 #f #f))))
 192
 193     (let lp ((n 0) (offset (- ip (arity-low-pc arity))))
 194       (when (< offset 0)
 195         (error "ip did not correspond to an instruction boundary?"))
 196       (if (zero? offset)
 197           (let ((live (if top-frame?
 198                           (vector-ref inv n)
 199                           ;; If we're not at a top frame, the IP points
 200                           ;; to the continuation -- but we haven't
 201                           ;; returned and defined its values yet.  The
 202                           ;; set of live variables is the set that was
 203                           ;; live going into the call, minus the set
 204                           ;; killed by the call, but not including
 205                           ;; values defined by the call.
 206                           (begin
 207                             (bitvector-copy! tmp (vector-ref inv (1- n)))
 208                             (bit-set*! tmp (vector-ref killv (1- n)) #f)
 209                             tmp))))
 210             (let lp ((n 0))
 211               (let ((n (bit-position #t live n)))
 212                 (if n
 213                     (match (vector-ref defs n)
 214                       (#(name def-offset slot)
 215                        (acons name slot (lp (1+ n)))))
 216                     '()))))
 217           (lp (1+ n) (- offset (vector-ref parsed n)))))))
 218
 219 (define* (frame-bindings frame #:optional top-frame?)
 220   (let ((ip (frame-instruction-pointer frame)))
 221     (cond
 222      ((find-program-arity ip)
 223       => (lambda (arity)
 224            (available-bindings arity ip top-frame?)))
 225      (else '()))))
 226
 227 (define (frame-lookup-binding frame var)
 228   (let lp ((bindings (frame-bindings frame)))
 229     (cond ((null? bindings)
 230            #f)
 231           ((eq? (binding:name (car bindings)) var)
 232            (car bindings))
 233           (else
 234            (lp (cdr bindings))))))
 235
 236 (define (frame-binding-set! frame var val)
 237   (frame-local-set! frame
 238                     (binding:index
 239                      (or (frame-lookup-binding frame var)
 240                          (error "variable not bound in frame" var frame)))
 241                     val))
 242
 243 (define (frame-binding-ref frame var)
 244   (frame-local-ref frame
 245                    (binding:index
 246                     (or (frame-lookup-binding frame var)
 247                         (error "variable not bound in frame" var frame)))))
 248
 249
 250 ;; This function is always called to get some sort of representation of the
 251 ;; frame to present to the user, so let's do the logical thing and dispatch to
 252 ;; frame-call-representation.
 253 (define (frame-arguments frame)
 254   (cdr (frame-call-representation frame)))
 255
 256
 257 \f
 258 ;;;
 259 ;;; Pretty printing
 260 ;;;
 261
 262 ;; Basically there are two cases to deal with here:
 263 ;;
 264 ;;   1. We've already parsed the arguments, and bound them to local
 265 ;;      variables. In a standard (lambda (a b c) ...) call, this doesn't
 266 ;;      involve any argument shuffling; but with rest, optional, or
 267 ;;      keyword arguments, the arguments as given to the procedure may
 268 ;;      not correspond to what's on the stack. We reconstruct the
 269 ;;      arguments using e.g. for the case above: `(,a ,b ,c). This works
 270 ;;      for rest arguments too: (a b . c) => `(,a ,b . ,c)
 271 ;;
 272 ;;   2. We have failed to parse the arguments. Perhaps it's the wrong
 273 ;;      number of arguments, or perhaps we're doing a typed dispatch and
 274 ;;      the types don't match. In that case the arguments are all on the
 275 ;;      stack, and nothing else is on the stack.
 276
 277 (define (frame-call-representation frame)
 278   (let* ((ip (frame-instruction-pointer frame))
 279          (info (find-program-debug-info ip))
 280          (nlocals (frame-num-locals frame))
 281          (closure (frame-procedure frame)))
 282     (define (local-ref i)
 283       (if (< i nlocals)
 284           (frame-local-ref frame i)
 285           ;; Let's not error here, as we are called during backtraces.
 286           '???))
 287     (define (reconstruct-arguments nreq nopt kw has-rest? local)
 288       (cond
 289        ((positive? nreq)
 290         (cons (local-ref local)
 291               (reconstruct-arguments (1- nreq) nopt kw has-rest? (1+ local))))
 292        ((positive? nopt)
 293         (cons (local-ref local)
 294               (reconstruct-arguments nreq (1- nopt) kw has-rest? (1+ local))))
 295        ((pair? kw)
 296         (cons* (caar kw) (local-ref (cdar kw))
 297                (reconstruct-arguments nreq nopt (cdr kw) has-rest? (1+ local))))
 298        (has-rest?
 299         (local-ref local))
 300        (else
 301         '())))
 302     (cons
 303      (or (and=> info program-debug-info-name)
 304          (procedure-name closure)
 305          (and info
 306               ;; No need to give source info, as backtraces will already
 307               ;; take care of that.
 308               (format #f "#<procedure ~a>"
 309                       (number->string (program-debug-info-addr info) 16)))
 310          (procedure-name closure)
 311          closure)
 312      (cond
 313       ((find-program-arity ip)
 314        => (lambda (arity)
 315             ;; case 1
 316             (reconstruct-arguments (arity-nreq arity)
 317                                    (arity-nopt arity)
 318                                    (arity-keyword-args arity)
 319                                    (arity-has-rest? arity)
 320                                    1)))
 321       ((and (primitive? closure)
 322             (program-arguments-alist closure ip))
 323        => (lambda (args)
 324             (match args
 325               ((('required . req)
 326                 ('optional . opt)
 327                 ('keyword . kw)
 328                 ('allow-other-keys? . _)
 329                 ('rest . rest))
 330                ;; case 1
 331                (reconstruct-arguments (length req) (length opt) kw rest 1)))))
 332       (else
 333        ;; case 2
 334        (map local-ref
 335             ;; Cdr past the 0th local, which is the procedure.
 336             (cdr (iota nlocals))))))))
 337
 338
 339 \f
 340 ;;; Misc
 341 ;;;
 342
 343 (define (frame-environment frame)
 344   (map (lambda (binding)
 345          (cons (binding:name binding) (frame-binding-ref frame binding)))
 346        (frame-bindings frame)))
 347
 348 (define (frame-object-binding frame obj)
 349   (do ((bs (frame-bindings frame) (cdr bs)))
 350       ((or (null? bs) (eq? obj (frame-binding-ref frame (car bs))))
 351        (and (pair? bs) (car bs)))))
 352
 353 (define (frame-object-name frame obj)
 354   (cond ((frame-object-binding frame obj) => binding:name)
 355         (else #f)))