+(define* (vm-frame-older frame #:optional (backend %gdb-memory-backend))
+ (let ((ip (vm-frame-saved-ip frame))
+ (sp (value-sub (vm-frame-fp frame) 3))
+ (fp (vm-frame-saved-fp frame)))
+ (and (not (zero? (value->integer fp)))
+ (vm-frame ip sp fp backend))))
+
+(define (vm-frames)
+ "Return a SRFI-41 stream of the current VM frame stack."
+ (stream-unfold identity
+ vm-frame?
+ vm-frame-older
+ (newest-vm-frame)))
+
+(define (vm-frame-locals frame)
+ (let ((fp (vm-frame-fp frame))
+ (sp (vm-frame-sp frame)))
+ (let lp ((slot 0) (ptr fp))
+ (if (value<=? ptr sp)
+ (acons (string-append "v" (number->string slot))
+ (value-dereference ptr)
+ (lp (1+ slot) (value-add ptr 1)))
+ '()))))
+
+(define (lookup-symbol-or-false name)
+ (match (lookup-symbol name)
+ (#f #f)
+ ((sym _) sym)))
+
+(define (find-mapped-elf-image addr)
+ (let ((array (lookup-symbol-or-false "mapped_elf_images"))
+ (count (lookup-symbol-or-false "mapped_elf_images_count")))
+ (and array count
+ (let ((array (symbol-value array))
+ (count (value->integer (symbol-value count))))
+ (let lp ((start 0) (end count))
+ (if (< start end)
+ (let ((n (+ start (ash (- end start) -1))))
+ (if (value<? addr (value-field (value-add array n) "end"))
+ (lp start n)
+ (lp (1+ n) end)))
+ (let ((mei (value-add array start)))
+ (and (value<=? (value-field mei "start") addr)
+ mei))))))))
+
+(define (vm-frame-program-debug-info frame)
+ (let ((addr (vm-frame-ip frame)))
+ (and=> (find-mapped-elf-image addr)
+ (lambda (mei)
+ (let* ((start (value->integer (value-field mei "start")))
+ (size (- (value->integer (value-field mei "end"))
+ start))
+ (mem-port (open-memory #:start start #:size size))
+ (bv (get-bytevector-all mem-port))
+ (ctx (debug-context-from-image bv)))
+ ;; The image is in this process at "bv", but in the
+ ;; inferior at mei.start. Therefore we relocate addr
+ ;; before we look for the PDI.
+ (let ((addr (+ (value->integer addr)
+ (- (debug-context-base ctx) start))))
+ (find-program-debug-info addr ctx)))))))
+
+(define (vm-frame-function-name frame)
+ (define (default-name)
+ (format #f "0x~x" (value->integer (vm-frame-ip frame))))
+ (cond
+ ((vm-frame-program-debug-info frame)
+ => (lambda (pdi)
+ (or (and=> (program-debug-info-name pdi) symbol->string)
+ (default-name))))
+ (else
+ (let ((ip (vm-frame-ip frame)))
+ (define (ip-in-symbol? name)
+ (let ((sym (lookup-symbol-or-false name)))
+ (and sym
+ (let* ((val (symbol-value sym))
+ (size (type-sizeof (value-type val)))
+ (char* (type-pointer (arch-char-type (current-arch))))
+ (val-as-char* (value-cast val char*)))
+ (and (value<=? val-as-char* ip)
+ (value<? ip (value-add val-as-char* size)))))))
+ (cond
+ ((ip-in-symbol? "vm_boot_continuation_code") "[boot continuation]")
+ ;; FIXME: For subrs, read the name from slot 0 in the frame.
+ ((ip-in-symbol? "subr_stub_code") "[subr call]")
+ ((ip-in-symbol? "vm_builtin_apply_code") "apply")
+ ((ip-in-symbol? "vm_builtin_values_code") "values")
+ ((ip-in-symbol? "vm_builtin_abort_to_prompt_code") "abort-to-prompt")
+ ((ip-in-symbol? "vm_builtin_call_with_values_code") "call-with-values")
+ ((ip-in-symbol? "vm_builtin_call_with_current_continuation_code")
+ "call-with-current-continuation")
+ ((ip-in-symbol? "continuation_stub_code") "[continuation]")
+ ((ip-in-symbol? "compose_continuation_code") "[delimited continuation]")
+ ((ip-in-symbol? "foreign_stub_code") "[ffi call]")
+ (else (default-name)))))))
+
+(define* (dump-vm-frame frame #:optional (port (current-output-port)))
+ (format port " name: ~a~%" (vm-frame-function-name frame))
+ (format port " ip: 0x~x~%" (value->integer (vm-frame-ip frame)))
+ (format port " fp: 0x~x~%" (value->integer (vm-frame-fp frame)))
+ (for-each (match-lambda
+ ((name . val)
+ (let ((obj (scm->object (value->integer val) %gdb-memory-backend)))
+ (format port " ~a: ~a~%" name obj))))
+ (vm-frame-locals frame)))