Re: [v8-users] Debugging and GDB

[Andy Wingo]

On Fri 20 Feb 2015 18:04, Andy Wingo <wi...@igalia.com> writes:

> One thing I wrote was a simple backtrace printer, building on my
> previous Scheme pretty-printers for V8 objects.  I attach the current
> version, which is getting pretty ugly.

voici:

-- 
-- 
v8-users mailing list
v8-users@googlegroups.com
http://groups.google.com/group/v8-users
--- 
You received this message because you are subscribed to the Google Groups 
"v8-users" group.
To unsubscribe from this group and stop receiving emails from it, send an email 
to v8-users+unsubscr...@googlegroups.com.
For more options, visit https://groups.google.com/d/optout.

;;; Copyright 2015 the V8 project authors.  All rights reserved.
;;; Use of this source code is governed by a BSD-style license that can be
;;; found in the LICENSE file.

(define-module (d8-gdb)
  #:use-module (ice-9 format)
  #:use-module (ice-9 rdelim)
  #:use-module ((gdb) #:hide (symbol?))
  #:use-module (gdb printing)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-41))

;;; Commentary:
;;;
;;; This file defines GDB extensions to pretty-print V8 objects.  To
;;; use, first you need a GDB that supports Guile, and then you need to
;;; have it load this file.  Probably the easiest way is to link it
;;; along side the file you are debugging:
;;;
;;;   ln -s `pwd`/tools/d8-gdb.scm out/x64.debug/
;;;
;;; Then d8-gdb.scm will be automatically loaded whenever d8 is run.  If
;;; you need it for other binaries, add more symlinks as appropriate,
;;; changing the link name.  To instead load the file manually, enter
;;; the following at the gdb prompt:
;;;
;;;   source tools/d8-gdb.scm
;;;
;;; If your GDB doesn't have Guile support, you'll have to build it
;;; yourself.  Fortunately it's not that bad.  See
;;;
;;;   https://groups.google.com/d/msg/v8-users/kIVoA7GZAcY/Hekm9QuaUKAJ
;;;
;;; for build instructions.
;;;
;;; Code:

(define (v8-name name)
  (string-append "v8::internal::" name))

(define (v8-base-name name)
  (string-append "v8::base::" name))

(define (v8-type name)
  (or (lookup-type (v8-name name))
      (error "type not found" name)))

(define (v8-handle-name name)
  (v8-name (string-append "Handle<" (v8-name name) ">")))

(define (v8-handle-type name)
  (or (lookup-type (v8-handle-name name))
      (error "type not found" name)))

(define (v8-pointer-type name)
  (type-pointer (lookup-type (v8-name name))))

(define (v8-symbol name)
  (or (and=> (lookup-symbol (v8-name name)) car)
      (error "symbol not found" name)))

(define (v8-base-symbol name)
  (or (and=> (lookup-symbol (v8-base-name name)) car)
      (error "symbol not found" name)))

(define (v8-constant name)
  (let ((sym (v8-symbol name)))
    (unless (symbol-constant? sym)
      (error "symbol not a constant" sym))
    (symbol-value sym)))

(define (v8-value-has-tag? val tag size)
  (value=? (value-logand (value-cast val (arch-uint-type (current-arch)))
                         (value-sub (value-lsh 1 (v8-constant size)) 1))
           (v8-constant tag)))

(define (v8-smi? obj)
  (v8-value-has-tag? obj "kSmiTag" "kSmiTagSize"))

(define (->type type-or-string)
  (if (string? type-or-string)
      (v8-type type-or-string)
      type-or-string))

(define (v8-field-ptr obj offset type)
  (let* ((char* (type-pointer (arch-char-type (current-arch))))
         (offset (if (string? offset)
                     (v8-constant offset)
                     offset))
         (byte-ptr (value-sub (value-add (value-cast obj char*)
                                         offset)
                              (v8-constant "kHeapObjectTag"))))
    (value-cast byte-ptr type)))

(define (v8-field obj offset type)
  (let ((type (type-pointer (->type type))))
    (value-dereference (v8-field-ptr obj offset type))))

(define (v8-smi-field-ptr obj offset)
  (v8-field-ptr obj offset (type-pointer (v8-type "Smi"))))

(define (v8-smi-value obj)
  (value->integer
   (value-cast
    (value-rsh (value-cast obj
                           (lookup-type "intptr_t"))
               (value-add (v8-constant "kSmiTagSize")
                          (v8-constant "kSmiShiftSize")))
    (arch-int-type (current-arch)))))

(define (v8-smi-field obj offset)
  (v8-smi-value (value-dereference (v8-smi-field-ptr obj offset))))

(define (v8-int-field-ptr obj offset)
  (v8-field-ptr obj offset (type-pointer (arch-int-type (current-arch)))))

(define (v8-int-field obj offset)
  (value-dereference (v8-int-field-ptr obj offset)))

(define (v8-pointer-field-ptr obj offset type)
  (v8-field-ptr obj offset (type-pointer (->type type))))

(define (v8-pointer-field obj offset type)
  (let ((type (type-pointer (->type type))))
    (value-dereference (v8-pointer-field-ptr obj offset type))))

(define (map-instance-type map)
  (value-cast
   (v8-field map "Map::kInstanceTypeOffset" (arch-uint8-type (current-arch)))
   (v8-type "InstanceType")))

;; Handles forwarding words, so is gc-safe.
(define (heap-object-map obj)
  (let ((map-word (value-field (v8-field obj "HeapObject::kMapOffset" "MapWord")
                               "value_")))
    (if (v8-smi? map-word)
        ;; It's a forwarding address: recurse.
        (heap-object-map
         (value-cast (value-add map-word (v8-constant "kHeapObjectTag"))
                     (v8-pointer-type "HeapObject")))
        (value-cast map-word (v8-pointer-type "Map")))))

(define (instance-type obj)
  (map-instance-type (heap-object-map obj)))

(define (camel-cased-instance-type type)
  (define (enum-type-name type)
    (let lp ((fields (type-fields (value-type type))))
      (match fields
        (() (format #f "(Unknown type ~a)" (value->integer type)))
        ((f . fields)
         (if (value=? (field-enumval f) type)
             (match (string-split (field-name f) #\:)
               ((_ ... tail) tail))
             (lp fields))))))
  (match (string-split (enum-type-name type) #\_)
    ((word ... "TYPE")
     (string-join (map (lambda (str)
                         (if (string-suffix? "JS" str)
                             str
                             (string-titlecase str)))
                       word)
                  ""))))

(define-syntax v8-constant-case
  (lambda (x)
    (define (visit-clauses var clauses)
      (syntax-case clauses (else)
        ((((name ...) body ...) clause ...)
         #`(if (or (value=? #,var (v8-constant name)) ...)
               (let () body ...)
               #,(visit-clauses var #'(clause ...))))
        (((else body ...))
         #'(let () body ...))
        (()
         #`(error "unexpected value" #,var))))
    (syntax-case x (else)
      ((_ exp clause ...)
       #`(let ((var exp))
           #,(visit-clauses #'var #'(clause ...)))))))
; (put 'v8-constant-case 'scheme-indent-function 1)

(define (v8-string? obj)
  (value<? (instance-type obj) (v8-constant "FIRST_NONSTRING_TYPE")))

(define (v8-string-length str)
  (v8-smi-field str "String::kLengthOffset"))

(define (raw-string-chars ptr start end one-byte?)
  (let* ((ptr (value-cast ptr (type-pointer (arch-uint8-type (current-arch)))))
         (elt-size (if one-byte? 1 2))
         (bytes (* elt-size (- end start))))
    (if (zero? bytes)
        ""
        (let ((port (open-memory
                     #:mode "r"
                     #:start (+ (value->integer ptr) (* elt-size start))
                     #:size bytes)))
          (set-port-encoding! port (if one-byte? "ISO-8859-1" "UTF-16"))
          (read-delimited "" port)))))

(define* (v8-seq-string-chars str start end #:key one-byte?)
  (let ((uint8* (type-pointer (arch-uint8-type (current-arch)))))
    (raw-string-chars (v8-field-ptr str "SeqString::kHeaderSize" uint8*)
                      start end one-byte?)))

(define* (v8-external-string-chars str start end #:key one-byte?)
  (let* ((type (v8-type (if one-byte?
                            "ExternalOneByteString::Resource"
                            "ExternalString::Resource")))
         (resource (v8-pointer-field str "ExternalString::kResourceOffset"
                                     type))
         (rtti (value-dynamic-type (value-dereference resource))))
    (define (get-pointer)
      (cond
       ((not (type? rtti))
        (error "could not get type of external string resource"))
       ((equal? rtti (v8-type "NativesExternalStringResource"))
        (value-field (value-cast resource (type-pointer rtti)) "data_"))
       ((lookup-symbol
         (string-append (type-name rtti) "::data"))
        => (lambda (pair)
             ;; Bah.  Give up and call the virtual method on the inferior.
             (let ((method (symbol-value (car pair))))
               (value-call method (list resource)))))
       (else
        (error "could not resolve ::data method for external resource" rtti))))
    (raw-string-chars (get-pointer) start end one-byte?)))

(define* (print-default port val #:optional
                        (type-name (type-print-name (value-type val))))
  (format port "(~a) 0x~x" type-name (value->integer val)))

(define (print-v8-smi port smi)
  (format port "~a" (v8-smi-value smi)))

(define* (print-v8-string port str #:optional (start 0)
                          (end (v8-string-length str)))
  (let ((type (instance-type str)))
    (v8-constant-case type
      (("SLICED_STRING_TYPE" "SLICED_ONE_BYTE_STRING_TYPE")
       (print-v8-string
        port
        (v8-pointer-field str "SlicedString::kParentOffset" "String")
        (+ start (v8-smi-field str "SlicedString::kOffsetOffset"))
        (- end start)))

      (("CONS_STRING_TYPE" "CONS_ONE_BYTE_STRING_TYPE")
       (let* ((left (v8-pointer-field str "ConsString::kFirstOffset" "String"))
              (left-len (v8-string-length left))
              (right (v8-pointer-field str "ConsString::kSecondOffset" 
"String")))
         (when (< start left-len)
           (print-v8-string port left start (min end left-len)))
         (when (> end left-len)
           (print-v8-string port right 0 (- end left-len)))))

      (("STRING_TYPE" "INTERNALIZED_STRING_TYPE")
       (display (v8-seq-string-chars str start end #:one-byte? #f) port))
      (("ONE_BYTE_STRING_TYPE" "ONE_BYTE_INTERNALIZED_STRING_TYPE")
       (display (v8-seq-string-chars str start end #:one-byte? #t) port))

      (("EXTERNAL_ONE_BYTE_STRING_TYPE")
       (display (v8-external-string-chars str start end #:one-byte? #t) port))
      (("EXTERNAL_STRING_TYPE")
       (display (v8-external-string-chars str start end #:one-byte? #f) port))

      (("EXTERNAL_ONE_BYTE_STRING_TYPE"
        "EXTERNAL_STRING_WITH_ONE_BYTE_DATA_TYPE"
        "SHORT_EXTERNAL_STRING_TYPE"
        "SHORT_EXTERNAL_ONE_BYTE_STRING_TYPE"
        "SHORT_EXTERNAL_STRING_WITH_ONE_BYTE_DATA_TYPE")
       (print-default port str (v8-name "ExternalString *")))

      (("EXTERNAL_INTERNALIZED_STRING_TYPE"
        "EXTERNAL_ONE_BYTE_INTERNALIZED_STRING_TYPE"
        "EXTERNAL_INTERNALIZED_STRING_WITH_ONE_BYTE_DATA_TYPE"
        "SHORT_EXTERNAL_INTERNALIZED_STRING_TYPE"
        "SHORT_EXTERNAL_ONE_BYTE_INTERNALIZED_STRING_TYPE"
        "SHORT_EXTERNAL_INTERNALIZED_STRING_WITH_ONE_BYTE_DATA_TYPE")
       (print-default port str (v8-name "ExternalInternalizedString *")))
      (else
       (format (current-warning-port) "warning: unknown string type ~a" type)
       (print-default port str (v8-name "String *"))))))

(define (v8-string-value string)
  (call-with-output-string (lambda (port) (print-v8-string port string))))

(define (print-v8-symbol port obj)
  (let ((name (v8-pointer-field obj "Symbol::kNameOffset" "Object")))
    (display "Symbol(" port)
    (if (v8-string? name)
        (print-v8-string port name)
        (format port "0x~x" (value->integer obj)))
    (display ")" port)))

(define (print-v8-oddball port obj)
  (let ((kind (v8-smi-field obj "Oddball::kKindOffset")))
    (format port "~a"
            (v8-constant-case kind
              (("Oddball::kFalse") "false")
              (("Oddball::kTrue") "true")
              (("Oddball::kTheHole") "the-hole")
              (("Oddball::kNull") "null")
              (("Oddball::kArgumentMarker") "argument-marker")
              (("Oddball::kUndefined") "undefined")
              (("Oddball::kUninitialized") "uninitialized")
              (else (string-append "Oddball(" (number->string kind ")")))))))

(define (print-v8-heap-number port obj)
  (let ((value (v8-field obj "HeapNumber::kValueOffset"
                         (arch-double-type (current-arch)))))
    (format port "~f" (value->real value))))

(define (print-v8-heap-object port obj)
  (cond
   ((v8-string? obj)
    (print-v8-string port obj))
   (else
    (let ((type (instance-type obj)))
      (v8-constant-case type
        (("SYMBOL_TYPE") (print-v8-symbol port obj))
        (("ODDBALL_TYPE") (print-v8-oddball port obj))
        (("HEAP_NUMBER_TYPE") (print-v8-heap-number port obj))
        (else
         (let ((actual-type (v8-name (string-append
                                      (camel-cased-instance-type type)
                                      " *")))
               (declared-type (type-print-name (value-type obj))))
           (if (equal? actual-type declared-type)
               (format port "(~a) 0x~x" actual-type (value->integer obj))
               (format port "(~a) ((~a) 0x~x)" declared-type actual-type
                       (value->integer obj))))))))))

(define (print-v8-object port obj)
  (if (v8-smi? obj)
      (print-v8-smi port obj)
      (print-v8-heap-object port obj)))

(define (print-v8-handle port handle)
  (let ((loc (value-field handle "location_")))
    (display "Handle(" port)
    (if (value=? loc 0)
        (print-default port loc
                       (type-print-name (type-target (value-type loc))))
        (print-v8-object port (value-dereference loc)))
    (display ")" port)))

(define (print-v8-maybe-handle port handle)
  (let ((loc (value-field handle "location_")))
    (if (value=? loc 0)
        (format port "MaybeHandle<~a>()"
                (type-print-name (type-target (value-type loc))))
        (begin
          (display "MaybeHandle(" port)
          (print-v8-object port (value-dereference loc))
          (display ")" port)))))

(define* (install-pretty-printers #:optional (objfile (current-objfile)))
  (define (writer-worker printer value)
    (lambda (_)
      (call-with-output-string
       (lambda (port) (printer port value)))))
  (define (make-worker hint printer value)
    (make-pretty-printer-worker hint (writer-worker printer value) #f))
  (define (default-predicate name)
    (lambda (value)
      (equal? (type-print-name (value-type value))
              (v8-name (string-append name " *")))))
  (define* (register! name hint printer #:optional
                      (predicate (default-predicate name)))
    (define (handler pp value)
      (and (predicate value)
           (make-worker hint printer value)))
    (prepend-pretty-printer! objfile (make-pretty-printer name handler)))

  (register! "Object" #f print-v8-object)
  (register! "Smi" #f print-v8-smi)
  (register! "String" "string" print-v8-string)
  (register! "Handle" #f print-v8-handle
             (lambda (value)
               (let ((type-name (type-print-name (value-type value))))
                 (string-prefix? (v8-name "Handle<") type-name))))
  (register! "MaybeHandle" #f print-v8-maybe-handle
             (lambda (value)
               (let ((type-name (type-print-name (value-type value))))
                 (string-prefix? (v8-name "MaybeHandle<") type-name)))))


;;;
;;; The JavaScript stack.
;;;
(define-record-type <v8-frame>
  (make-v8-frame type sp fp pc-address constant-pool-address isolate)
  v8-frame?
  (type v8-frame-type)
  (sp v8-frame-sp)
  (fp v8-frame-fp)
  (pc-address v8-frame-pc-address)
  (constant-pool-address v8-frame-constant-pool-address)
  (isolate v8-frame-isolate))

(define (v8-frame-pc frame)
  (value-dereference (v8-frame-pc-address frame)))

;; This is the only function in this file that actually calls into the
;; inferior.  Sadly, there is no portable way to do this; even for
;; pthread backends, in which Thread::LocalStorageKey is actually a
;; pthread_key_t, you still can't get easily get at the value:
;; 
http://stackoverflow.com/questions/10841219/thread-specific-data-from-linux-core-dump
(define (get-thread-local key)
  (value-call (symbol-value (v8-base-symbol "Thread::GetThreadLocal"))
              (list key)))

;; -> Isolate*
(define (current-isolate)
  (value-cast (get-thread-local
               (symbol-value (v8-symbol "Isolate::isolate_key_")))
              (v8-pointer-type "Isolate")))

;; int-or-pointer -> bool
(define (value-null? value)
  (value=? value 0))

;; Address Isolate* -> bool
(define (valid-stack-address? addr isolate)
  (and (not (value-null? addr))
       (value<=? addr
                 (value-field (value-field isolate "thread_local_top_")
                              "js_entry_sp_"))
       (value<=? (parse-and-eval "$sp") addr)))

;; Address -> Address
(define (compute-exit-frame-sp fp)
  (value-dereference
   (value-cast (value-add fp (v8-constant "ExitFrameConstants::kSPOffset"))
              (v8-pointer-type "Address"))))

;; Address -> Address*
(define (compute-exit-frame-pc-address sp)
  (value-cast (value-sub sp (v8-constant "kPCOnStackSize"))
              (v8-pointer-type "Address")))

;; Address -> Address*
(define (compute-exit-frame-constant-pool-address fp)
  (value-cast (value-add fp (v8-constant
                             "ExitFrameConstants::kConstantPoolOffset"))
              (v8-pointer-type "Address")))

;; Address -> bool
(define (valid-exit-frame? fp isolate)
  (and (valid-stack-address? fp isolate)
       (let ((sp (compute-exit-frame-sp fp)))
         (and (valid-stack-address? sp isolate)
              (let ((pc-address (compute-exit-frame-pc-address sp)))
                (and (valid-stack-address? pc-address isolate)
                     (not (value-null? (value-dereference pc-address)))))))))

;; Address -> Address
(define (compute-entry-frame-caller-fp fp)
  (value-dereference
   (value-cast (value-add fp (v8-constant
                              "EntryFrameConstants::kCallerFPOffset"))
               (v8-pointer-type "Address"))))

;; Address -> Address*
(define (compute-standard-frame-pc-address fp)
  (value-cast (value-add fp (v8-constant
                             "StandardFrameConstants::kCallerPCOffset"))
              (v8-pointer-type "Address")))

;; Address -> Object**
(define (compute-standard-frame-marker-address fp)
  (value-cast (value-add fp (v8-constant
                             "StandardFrameConstants::kMarkerOffset"))
              (type-pointer (v8-pointer-type "Object"))))

;; ThreadLocalTop Isolate* -> bool
(define (valid-thread-top? top isolate)
  (let ((c-entry-fp (value-field top "c_entry_fp_"))
        (handler (value-field top "handler_")))
    (and (valid-exit-frame? c-entry-fp isolate)
         ;; Should be at least one JS_ENTRY stack handler.
         (not (value-null? handler))
         ;; Check that there are no js frames on top of the native frames.
         (value<=? c-entry-fp handler))))

;; Address -> bool
(define (arguments-adaptor-frame? fp)
  (let ((obj (value-dereference
              (value-cast
               (value-add fp (v8-constant
                              "StandardFrameConstants::kContextOffset"))
               (type-pointer (v8-pointer-type "Object"))))))
    (and (v8-smi? obj)
         (eqv? (v8-smi-value obj)
               (v8-constant "StackFrame::ARGUMENTS_ADAPTOR")))))

;; HashMap int-or-pointer int? -> HashMap::Entry
;; Assume that pointer equality is the match function.
(define* (hash-map-lookup hashmap key #:optional (hash key))
  (let ((entries (value-field hashmap "map_"))
        (mask (value-sub (value-field hashmap "capacity_") 1)))
    (let lp ((hash hash))
      (let* ((entry (value-add entries (value-logand hash mask)))
             (entry-key (value-field entry "key")))
        (and (not (value-null? entry-key))
             (if (value=? key entry-key)
                 entry
                 (lp (1+ hash))))))))

(define (find-large-page lo-space addr)
  (let ((hashmap (value-field lo-space "chunk_map_"))
        (key (floor/ (value->integer addr)
                     (value->integer
                      (v8-constant "MemoryChunk::kAlignment")))))
    (and=> (hash-map-lookup hashmap key)
           (lambda (entry)
             (let* ((value (value-field entry "value"))
                    (page (value-cast value (v8-pointer-type "LargePage")))
                    (start (value-field page "area_start_"))
                    (end (value-field page "area_end_")))
               (and (value<=? start addr) (value<=? addr end) page))))))

(define (address->page addr)
  (value-cast (value-logand (value-cast addr (lookup-type "uintptr_t"))
                            (value-lognot
                             (v8-constant "Page::kPageAlignmentMask")))
              (v8-pointer-type "Page")))

(define (address->heap-object addr)
  (value-cast (value-add addr (v8-constant "kHeapObjectTag"))
              (v8-pointer-type "HeapObject")))

(define (round-up addr align)
  (value-logand (value-add addr (value-sub align 1))
                (value-sub 0 align)))

(define (code-instruction-start code)
  (v8-field-ptr code "Code::kHeaderSize" (v8-type "Address")))

(define (code-instruction-size code)
  (v8-int-field code "Code::kInstructionSizeOffset"))

(define (heap-object-size obj)
  (let ((type (instance-type obj)))
    (v8-constant-case type
      (("CODE_TYPE")
       (let ((body-size (round-up (code-instruction-size obj)
                                  (v8-constant "kObjectAlignment"))))
         (round-up (value-add (v8-constant "Code::kHeaderSize") body-size)
                   (v8-constant "kCodeAlignment"))))
      (("FREE_SPACE_TYPE")
       (v8-smi-field obj "FreeSpace::kSizeOffset"))
      (else
       (error "heap-object-size not yet implemented for type" type)))))

(define (lookup-code-for-pc pc isolate)
  (let* ((ipcc (value-field isolate "inner_pointer_to_code_cache_"))
         (heap (value-field isolate "heap_")))
    (cond
     ((find-large-page (value-field heap "lo_space_") pc)
      => (lambda (page)
           (value-cast page (v8-pointer-type "Code"))))
     (else
      (let* ((page (address->page pc))
             (skip-list (value-field page "skip_list_"))
             (starts (value-field skip-list "starts_"))
             (region-number (value-rsh
                             (value-logand
                              (value-cast pc (lookup-type "uintptr_t"))
                              (v8-constant "Page::kPageAlignmentMask"))
                             (v8-constant "SkipList::kRegionSizeLog2")))
             (addr (value-subscript starts region-number))
             (code-space (value-field heap "code_space_"))
             (code-space-info (value-field code-space "allocation_info_"))
             (top (value-field code-space-info "top_"))
             (limit (value-field code-space-info "limit_")))
        (let lp ((addr addr))
          (if (and (value=? addr top) (not (value=? addr limit)))
              (lp limit)
              (let ((obj (address->heap-object addr)))
                (let ((next (value-add addr (heap-object-size obj))))
                  (if (value<? pc next)
                      (value-cast obj (v8-pointer-type "Code"))
                      (lp next)))))))))))

(define (code-kind code)
  ;; Sadly, all-static classes are vulnerable to a bug in which GCC
  ;; folds the values early, but then forgets that the class is used
  ;; and.  Thinking that the class is unused, it then prunes the class
  ;; from debug output:
  ;;
  ;;   https://gcc.gnu.org/bugzilla/show_bug.cgi?id=65108
  ;; 
  ;; So here we hard-code some defaults.
  (define-syntax-rule (exception-or exp val)
    (catch #t (lambda () exp) (lambda _ val)))
  (value-rsh (value-logand (v8-int-field code "Code::kFlagsOffset")
                           (exception-or
                            (v8-constant "Code::KindField::kMask")
                            (ash (1- (ash 1 4)) 7)))
             (exception-or (v8-constant "Code::KindField::kShift")
                           7)))

(define (code-optimized? code)
  (value=? (code-kind code) (v8-constant "Code::OPTIMIZED_FUNCTION")))

(define (build-js-frame sp fp pc-address isolate)
  (define (frame-type type)
    (v8-constant-case type
      (("StackFrame::ENTRY") 'entry)
      (("StackFrame::ENTRY_CONSTRUCT") 'entry-construct)
      (("StackFrame::EXIT") 'exit)
      (("StackFrame::JAVA_SCRIPT") 'javascript)
      (("StackFrame::OPTIMIZED") 'optimized)
      (("StackFrame::STUB") 'stub)
      (("StackFrame::STUB_FAILURE_TRAMPOLINE") 'stub-failure-trampoline)
      (("StackFrame::INTERNAL") 'internal)
      (("StackFrame::CONSTRUCT") 'construct)
      (("StackFrame::ARGUMENTS_ADAPTOR") 'arguments-adaptor)
      (else #f)))
  (define (build-frame type)
    (let ((type-sym (frame-type type)))
      (and type-sym
           (make-v8-frame type-sym sp fp pc-address #f isolate))))
  (cond
   ((not (and (valid-stack-address? sp isolate)
              (valid-stack-address? fp isolate)))
    #f)
   ((arguments-adaptor-frame? fp)
    (make-v8-frame 'arguments-adaptor sp fp pc-address #f isolate))
   (else
    (let ((marker-obj (value-dereference
                       (compute-standard-frame-marker-address fp))))
      (build-frame
       (if (v8-smi? marker-obj)
           (value-cast (make-value (v8-smi-value marker-obj))
                       (v8-type "StackFrame::Type"))
           (let* ((pc (value-dereference pc-address))
                  (code (lookup-code-for-pc pc isolate)))
             (if (code-optimized? code)
                 (v8-constant "StackFrame::OPTIMIZED")
                 (v8-constant "StackFrame::JAVA_SCRIPT")))))))))

(define (compute-exit-frame-older-sp fp)
  (value-add fp (v8-constant "ExitFrameConstants::kCallerSPDisplacement")))

(define (compute-exit-frame-older-fp fp)
  (value-dereference
   (value-cast (value-add fp (v8-constant
                              "ExitFrameConstants::kCallerFPOffset"))
               (v8-pointer-type "Address"))))

;; Assuming there is no return address location resolver (i.e., we're
;; not in a simulator).
(define (compute-exit-frame-older-pc-address fp)
  (value-cast (value-add fp (v8-constant
                             "ExitFrameConstants::kCallerPCOffset"))
              (v8-pointer-type "Address")))

(define (compute-standard-frame-older-fp fp)
  (value-dereference
   (value-cast (value-add fp (v8-constant
                              "StandardFrameConstants::kCallerFPOffset"))
               (v8-pointer-type "Address"))))

(define (compute-standard-frame-older-sp fp)
  (value-add fp (v8-constant
                 "StandardFrameConstants::kCallerSPOffset")))

(define (compute-frame-older-sp fp type)
  (case type
    ((entry entry-construct) #f)
    ((exit stub) (compute-exit-frame-older-sp fp))
    ((javascript optimized arguments-adaptor internal stub-failure-trampoline)
     (compute-standard-frame-older-sp fp))))

(define (make-exit-frame fp isolate)
  (let* ((sp (compute-exit-frame-sp fp))
         (pc-address (compute-exit-frame-pc-address sp))
         (pool-address (compute-exit-frame-constant-pool-address fp)))
    (make-v8-frame 'exit sp fp pc-address pool-address isolate)))

(define (v8-frame-older frame)
  (let ((sp (v8-frame-sp frame))
        (fp (v8-frame-fp frame))
        (isolate (v8-frame-isolate frame))
        (type (v8-frame-type frame)))
    (case type
      ((entry entry-construct)
       (let ((caller-fp (compute-entry-frame-caller-fp fp)))
         (and (valid-exit-frame? caller-fp isolate)
              (make-exit-frame caller-fp isolate))))
      ((exit)
       (build-js-frame (compute-exit-frame-older-sp fp)
                       (compute-exit-frame-older-fp fp)
                       (compute-exit-frame-older-pc-address fp)
                       isolate))
      (else
       (let* ((pc-address (compute-standard-frame-pc-address fp))
              (sp (compute-frame-older-sp fp type))
              (fp (compute-standard-frame-older-fp fp)))
         (build-js-frame sp fp pc-address isolate))))))

;; This corresponds to the SafeStackFrameIterator constructor.
(define* (newest-v8-frame #:key (isolate (current-isolate)))
  (let* ((top (value-field isolate "thread_local_top_")))
    (cond
     ((valid-thread-top? top isolate)
      (make-exit-frame (value-field top "c_entry_fp_") isolate))
     (else
      (let* ((fp (value-cast (parse-and-eval "$rbp") (v8-type "Address")))
             (sp (value-cast (parse-and-eval "$sp") (v8-type "Address")))
             (pc-address (compute-standard-frame-pc-address fp)))
        (if (valid-stack-address? (compute-standard-frame-marker-address fp)
                                  isolate)
            (build-js-frame sp fp pc-address isolate)
            ;; Top frame incomplete; advance to next.
            (v8-frame-older
             (make-v8-frame 'javascript sp fp pc-address #f isolate))))))))

(define (v8-frames)
  "Return a SRFI-41 stream of the current VM frame stack."
  (stream-unfold identity
                 v8-frame?
                 v8-frame-older
                 (newest-v8-frame)))

(define (js-frame-function frame)
  (value-dereference
   (value-cast
    (value-add (v8-frame-fp frame)
               (v8-constant "JavaScriptFrameConstants::kFunctionOffset"))
    (type-pointer (v8-pointer-type "HeapObject")))))

(define (js-function-code function)
  (address->heap-object
   (value-sub (v8-field function "JSFunction::kCodeEntryOffset" "Address")
              (v8-constant "Code::kHeaderSize"))))

(define (js-function-shared-function-info function)
  (v8-pointer-field function
                    "JSFunction::kSharedFunctionInfoOffset"
                    "SharedFunctionInfo"))

(define (shared-function-info-name shared)
  (let ((name (v8-pointer-field shared
                                "SharedFunctionInfo::kNameOffset"
                                "Object")))
    (if (and (v8-string? name)
             (not (zero? (v8-string-length name))))
        (v8-string-value name)
        (let ((name (v8-pointer-field shared
                                      "SharedFunctionInfo::kInferredNameOffset"
                                      "Object")))
          (and (v8-string? name)
               (v8-string-value name))))))

(define (byte-array-start-address byte-array)
  (v8-field-ptr byte-array "ByteArray::kHeaderSize" (v8-pointer-type "byte")))

(define (fixed-array-length byte-array)
  (v8-smi-field byte-array "FixedArrayBase::kLengthOffset"))

(define (byte-array-length byte-array)
  (fixed-array-length byte-array))

(define-record-type <reloc-info>
  (make-reloc-info type pc data)
  reloc-info?
  (type reloc-info-type)
  (pc reloc-info-pc)
  (data reloc-info-data))

(define (reloc-info-stream code)
  (let* ((pc (code-instruction-start code))
         (buf (v8-pointer-field code "Code::kRelocationInfoOffset" "ByteArray"))
         ;; Reloc info is written backwards.
         (end (byte-array-start-address buf))
         (size (byte-array-length buf))
         (pos (value-add end size))
         (last-id 0)
         (last-position 0))
    (define (current-byte)
      (value-dereference pos))
    (define (advance-pos! n)
      (set! pos (value-sub pos n)))
    (define (advance-last-id! n)
      (set! last-id (value-add last-id n)))
    (define (advance-last-position! n)
      (set! last-position (value-add last-position n)))
    (define (next-byte!)
      (advance-pos! 1)
      (current-byte))
    (define (next-tag!)
      (value-logand (next-byte!) (v8-constant "kTagMask")))
    (define (bits->mask bits)
      (value-sub (value-lsh 1 bits) 1))
    (define (extra-tag)
      (value-logand (value-rsh (current-byte) (v8-constant "kTagBits"))
                    (bits->mask (v8-constant "kExtraTagBits"))))
    (define (top-tag)
      (value-rsh (current-byte) (value-add (v8-constant "kTagBits")
                                           (v8-constant "kExtraTagBits"))))
    (define (tagged-pc-advance)
      (value-rsh (current-byte) (v8-constant "kTagBits")))
    (define (next-pc-advance!)
      (next-byte!))
    (define (advance-pc! diff)
      (set! pc (value-add pc diff)))
    (define (next-int!)
      (define type (lookup-type "int"))
      (let lp ((x (value-cast (make-value 0) type)) (i 0))
        (if (value<? i (v8-constant "kIntSize"))
            (let* ((shift (value-mul i (v8-constant "kBitsPerByte")))
                   (next (value-cast (next-byte!) type)))
              (lp (value-logior x (value-lsh next shift)) (1+ i)))
            x)))
    (define (next-intptr!)
      (define type (lookup-type "intptr_t"))
      (let lp ((x (value-cast (make-value 0) type)) (i 0))
        (if (value<? i (v8-constant "kIntptrSize"))
            (let* ((shift (value-mul i (v8-constant "kBitsPerByte")))
                   (next (value-cast (next-byte!) type)))
              (lp (value-logior x (value-lsh next shift)) (1+ i)))
            x)))
    (define (next-variable-length-pc-advance!)
      (value-lsh
       (let lp ((x (value-cast (make-value 0) (lookup-type "uint32_t"))) (i 0))
         (if (value<? i (v8-constant "kIntSize"))
             (let* ((part (next-byte!))
                    (diff (value-lsh
                           (value-rsh part (v8-constant "kLastChunkTagBits"))
                           (value-mul i (v8-constant "kChunkBits"))))
                    (x (value-logior x diff))
                    (mask (v8-constant "kLastChunkTagMask")))
               (if (value=? (value-logand part mask) 1)
                   x
                   (lp x (1+ i))))
             x))
       (v8-constant "kSmallPCDeltaBits")))
    (define (locatable-type-tag)
      (value-logand (current-byte)
                    (bits->mask (v8-constant "kLocatableTypeTagBits"))))
    (define (locatable-type-tagged-data)
      ;; Signed.
      (value-rsh (value-cast (current-byte) (arch-schar-type (current-arch)))
                 (v8-constant "kLocatableTypeTagBits")))
    (define (tagged-data)
      (value-rsh (current-byte) (v8-constant "kTagBits")))
    (let lp ()
      (define (return type data)
        (stream-cons (make-reloc-info type pc data) (lp)))
      (cond
       ((value<=? pos end) stream-null)
       (else
        (v8-constant-case (next-tag!)
          (("kEmbeddedObjectTag")
           (advance-pc! (tagged-pc-advance))
           (return 'embedded-object #f))
          (("kCodeTargetTag")
           (advance-pc! (tagged-pc-advance))
           (return 'code-target #f))
          (("kLocatableTag")
           (advance-pc! (tagged-pc-advance))
           (advance-pos! 1)
           (v8-constant-case (locatable-type-tag)
             (("kCodeWithIdTag")
              (advance-last-id! (locatable-type-tagged-data))
              (return 'code-target-with-id last-id))
             (("kDeoptReasonTag")
              (return 'deopt-reason (tagged-data)))
             (("kStatementPositionTag")
              (advance-last-position! (locatable-type-tagged-data))
              (return 'statement-position last-position))
             (("kNonstatementPositionTag" "kStatementPositionTag")
              (advance-last-position! (locatable-type-tagged-data))
              (return 'non-statement-position last-position))))
          (("kDefaultTag")
           (v8-constant-case (extra-tag)
             (("kPCJumpExtraTag")
              (advance-pc! (v8-constant-case (top-tag)
                             (("kVariableLengthPCJumpTopTag")
                              (next-variable-length-pc-advance!))
                             (else
                              (next-pc-advance!))))
              (lp))
             (("kDataJumpExtraTag")
              (v8-constant-case (top-tag)
                (("kCodeWithIdTag")
                 (return 'code-target-with-id (next-int!)))
                (("kCommentTag")
                 (return 'comment (next-intptr!)))
                (("kStatementPositionTag")
                 (advance-last-position! (next-int!))
                 (return 'statement-position last-position))
                (("kNonstatementPositionTag")
                 (advance-last-position! (next-int!))
                 (return 'non-statement-position last-position))))
             (("kPoolExtraTag")
              (v8-constant-case (top-tag)
                (("kConstPoolTag") (return 'const-pool (next-int!)))
                (("kVeneerPoolTag") (return 'veneer-pool (next-int!)))))
             (else
              (return
               (v8-constant-case
                   (value-add (v8-constant "RelocInfo::LAST_COMPACT_ENUM")
                              (extra-tag))
                 (("RelocInfo::CONSTRUCT_CALL") 'construct-call)
                 (("RelocInfo::DEBUG_BREAK") 'debug-break)
                 (("RelocInfo::CELL") 'cell)
                 (("RelocInfo::RUNTIME_ENTRY") 'runtime-entry)
                 (("RelocInfo::JS_RETURN") 'js-return)
                 (("RelocInfo::DEBUG_BREAK_SLOT") 'debug-break-slot)
                 (("RelocInfo::EXTERNAL_REFERENCE") 'external-reference)
                 (("RelocInfo::INTERNAL_REFERENCE") 'internal-reference))
               #f))))))))))

(define (code-source-position code pc)
  (define (stream-fold2 f stream s0 s1)
    (cond
     ((stream-null? stream) (values s0 s1))
     (else
      (call-with-values (lambda () (f (stream-car stream) s0 s1))
        (lambda (s0 s1)
          (stream-fold2 f (stream-cdr stream) s0 s1))))))
  (define (valid-position? reloc-info)
    (and (memq (reloc-info-type reloc-info)
               '(statement-position non-statement-position))
         (value<? (reloc-info-pc reloc-info) pc)))
  (define (find-closest-position reloc-info position distance)
    (let* ((distance* (value-sub pc (reloc-info-pc reloc-info)))
           (position* (value->integer (reloc-info-data reloc-info))))
      (if (or (not distance)
              (value<? distance* distance)
              (and (value=? distance* distance) (> position* position)))
          (values position* distance*)
          (values position distance))))
  (let ((stream (stream-filter valid-position? (reloc-info-stream code))))
    (stream-fold2 find-closest-position stream #f #f)))

(define (shared-function-info-script shared)
  (let ((script (v8-pointer-field shared "SharedFunctionInfo::kScriptOffset"
                                  "Object")))
    (v8-constant-case (instance-type script)
      (("SCRIPT_TYPE") script)
      (else #f))))

(define (script-source script)
  (let ((source (v8-pointer-field script "Script::kSourceOffset" "Object")))
    (and (v8-string? source) (v8-string-value source))))

(define (script-line-number script pos)
  (let ((source (script-source script)))
    (and source
         (let lp ((line 0) (cur -1))
           (if (and cur (< cur pos))
               (lp (1+ line) (string-index source #\newline (1+ cur)))
               line)))))

(define (script-name script)
  (let ((name (v8-pointer-field script "Script::kNameOffset" "Object")))
    (and (v8-string? name) (v8-string-value name))))

(define* (v8-frame-function-name frame #:key zealous?)
  (case (v8-frame-type frame)
    ((javascript optimized)
     (let* ((function (js-frame-function frame))
            (shared (js-function-shared-function-info function)))
       (or (shared-function-info-name shared)
           (and zealous?
                (format #f "<anonymous function 0x~x>"
                        (value->integer function))))))
    (else
     (and zealous?
          (format #f "<~a frame; pc=0x~x>"
                  (v8-frame-type frame) (v8-frame-pc frame))))))

(define (v8-frame-filename frame)
  (case (v8-frame-type frame)
    ((javascript optimized)
     (let* ((function (js-frame-function frame))
            (shared (js-function-shared-function-info function))
            (script (shared-function-info-script shared)))
       (and=> script script-name)))
    (else #f)))

(define (v8-frame-line frame)
  (case (v8-frame-type frame)
    ((javascript optimized)
     (let* ((function (js-frame-function frame))
            (code (js-function-code function))
            (shared (js-function-shared-function-info function))
            (script (shared-function-info-script shared)))
       (and script
            (let ((pos (code-source-position code (v8-frame-pc frame))))
              (and pos (script-line-number script pos))))))
    (else #f)))

(define* (dump-v8-frame frame #:optional (port (current-output-port)))
  (format port "  type: ~a~%" (v8-frame-type frame))
  (format port "    sp: 0x~x~%" (value->integer (v8-frame-sp frame)))
  (format port "    fp: 0x~x~%" (value->integer (v8-frame-fp frame)))
  (let ((pc-address (v8-frame-pc-address frame)))
    (unless (value-null? pc-address)
      (let ((pc (value-dereference pc-address)))
        (format port "    pc: 0x~x~%" (value->integer pc))
        (case (v8-frame-type frame)
          ;; code offset (pc - code->instruction_start())
          ((javascript optimized)
           (let* ((function (js-frame-function frame))
                  (code (js-function-code function))
                  (shared (js-function-shared-function-info function))
                  (script (shared-function-info-script shared)))
             (format port "    name: ~a~a at ~a:~a~%"
                     (v8-frame-function-name frame #:zealous? #t)
                     (if (code-optimized? code) " (optimized)" "")
                     (or (and=> script script-name) "<unknown>")
                     (or (and script
                              (let ((pos (code-source-position code pc)))
                                (and pos (script-line-number script pos))))
                         "<unknown>"))))))))
  (values))

(define* (display-v8-frames #:optional (port (current-output-port)))
  "Display the VM frames on PORT."
  (stream-for-each (lambda (frame)
                     (dump-v8-frame frame port))
                   (v8-frames)))


;;;
;;; Frame filters.
;;;

(define-syntax compile-time-cond
  (lambda (x)
    (syntax-case x (else)
      ((_ (test body ...) clause ...)
       (if (eval (syntax->datum #'test) (current-module))
           #'(begin body ...)
           #'(compile-time-cond clause ...)))
      ((_ (else body ...))
       #'(begin body ...)))))

(compile-time-cond
 ((false-if-exception (resolve-interface '(gdb frames)))
  (use-modules (gdb frames))

  (define* (v8-frame-filter gdb-frames #:optional (v8-frames (v8-frames)))
    (define (synthesize-frame gdb-frame v8-frame)
      (reannotate-frame gdb-frame
                        #:function-name (v8-frame-function-name v8-frame)
                        #:address (value->integer (v8-frame-pc v8-frame))
                        #:filename (v8-frame-filename v8-frame)
                        #:line (v8-frame-line v8-frame)
                        #:arguments '()
                        #:locals '()
                        #:children '()))
    (cond
     ((stream-null? gdb-frames) gdb-frames)
     (else
      (let* ((gdb-frame (stream-car gdb-frames))
             (gdb-frames (stream-cdr gdb-frames))
             (inferior-frame (annotated-frame-frame gdb-frame)))
        (define (recur gdb-frame v8-frames)
          (stream-cons gdb-frame
                       (v8-frame-filter gdb-frames v8-frames)))
        (let lp ((children (reverse (annotated-frame-children gdb-frame)))
                 (v8-frames v8-frames))
          (define (finish reversed-children v8-frames)
            (let ((children (reverse reversed-children)))
              (recur (reannotate-frame gdb-frame #:children children)
                     v8-frames)))
          (cond
           ((stream-null? v8-frames)
            (finish children v8-frames))
           (else
            (let* ((v8-frame (stream-car v8-frames)))
              (if (value<=? (v8-frame-fp v8-frame)
                            (frame-read-register inferior-frame "fp"))
                  (lp (cons (synthesize-frame gdb-frame v8-frame) children)
                      (stream-cdr v8-frames))
                  (finish children v8-frames))))))))))

  (define (install-frame-filters)
    (add-frame-filter! "guile-v8-frame-filter" v8-frame-filter)))
 (else
  (define (install-frame-filters)
    (values))))

(install-pretty-printers)
(install-frame-filters)

-- 
-- 
v8-users mailing list
v8-users@googlegroups.com
http://groups.google.com/group/v8-users
--- 
You received this message because you are subscribed to the Google Groups 
"v8-users" group.
To unsubscribe from this group and stop receiving emails from it, send an email 
to v8-users+unsubscr...@googlegroups.com.
For more options, visit https://groups.google.com/d/optout.