Guile-hoot/module/hoot/repl.scm

;;; REPL commands
;;; Copyright (C) 2023 David Thompson <dave@spritely.institute>
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;    http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

;;; Commentary:
;;;
;;; Handy REPL commands for development.
;;;
;;; Code:

(define-module (hoot repl)
  #:use-module (hoot reflect)
  #:use-module (ice-9 control)
  #:use-module (ice-9 match)
  #:use-module (ice-9 pretty-print)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (system repl command)
  #:use-module (system repl common)
  #:use-module (system repl debug)
  #:use-module (system repl repl)
  #:use-module (wasm dump)
  #:use-module (wasm resolve)
  #:use-module (wasm types)
  #:use-module (wasm vm)
  #:use-module (wasm wat))

(define (make-id prefix idx)
  (string->symbol
   (string-append "$" prefix (number->string idx))))

(define (name-ref name-map idx)
  (and name-map (assq-ref name-map idx)))

(define (indirect-name-ref iname-map parent-idx idx)
  (and iname-map (name-ref (assq-ref iname-map parent-idx) idx)))

(define-syntax-rule (define-name-ref name getter prefix)
  (define (name names idx)
    (or (and names (name-ref (getter names) idx))
        (make-id prefix idx))))

(define-syntax-rule (define-indirect-name-ref name getter prefix)
  (define (name names parent-idx idx)
    (or (and names (indirect-name-ref (getter names) parent-idx idx))
        (make-id prefix idx))))

(define-name-ref func-name names-func "func")
(define-indirect-name-ref local-name names-local "var")
(define-name-ref type-name names-type "type")
(define-name-ref table-name names-table "table")
(define-name-ref memory-name names-memory "memory")
(define-name-ref global-name names-global "global")
(define-name-ref elem-name names-elem "elem")
(define-name-ref data-name names-data "data")
(define-indirect-name-ref field-name names-field "field")
(define-name-ref tag-name names-tag "tag")

(define (heap-type-repr names ht)
  (match ht
    ((or 'func 'extern
         'any 'eq 'i31 'noextern 'nofunc 'struct 'array 'none
         'string 'stringview_wtf8 'stringview_wtf16 'stringview_iter)
     ht)
    (_ (type-name names ht))))

(define (ref-type-repr names rt)
  (match rt
    (($ <ref-type> nullable? ht)
     `(ref ,@(if nullable? '(null) '()) ,(heap-type-repr names ht)))))

(define (val-type-repr names vt)
  (match vt
    ((or 'i32 'i64 'f32 'f64 'v128
         'funcref 'externref 'anyref 'eqref 'i31ref
         'nullexternref 'nullfuncref
         'structref 'arrayref 'nullref
         'stringref
         'stringview_wtf8ref 'stringview_wtf16ref 'stringview_iterref)
     vt)
    ((? ref-type? rt)
     (ref-type-repr names rt))))

(define (memarg-repr names memarg)
  (define (make-prefix-arg prefix x)
    (if (zero? x)
        '()
        (list (string->symbol (string-append prefix (number->string x))))))
  (match memarg
    (($ <mem-arg> memory offset align)
     `(,(memory-name names memory)
       ,@(make-prefix-arg "offset=" offset)
       ,@(make-prefix-arg "align=" align)))))

(define (block-type-repr names bt)
  (match bt
    (#f
     '())
    ((? symbol?)
     `(,bt))
    (($ <type-use> _ ($ <func-sig> params results))
     (append (map (match-lambda
                    (($ <param> _ type)
                     `(param ,(val-type-repr names type))))
                  params)
             (map (lambda (vt)
                    `(result ,(val-type-repr names vt)))
                  results)))
    ((? ref-type? rt)
     `(,(ref-type-repr names rt)))))

;; TODO: Label names.  We don't have control stack info here.
(define (instruction-repr instr names strings func-idx)
  (match instr
    (((and op (or 'local.get 'local.set 'local.tee)) local)
     `(,op ,(local-name names func-idx local)))
    (((and op (or 'global.get 'global.set)) global)
     `(,op ,(global-name names global)))
    (((and inst (or 'throw 'rethrow)) tag)
     `(,inst ,(tag-name names tag)))
    (((and inst (or 'call 'return_call)) func)
     `(,inst ,(func-name names func)))
    (('call_indirect table ($ <type-use> type))
     `(call_indirect ,(table-name names table) ,(type-name names type)))
    (((and inst (or 'call_ref 'return_call_ref)) type)
     `(,inst ,(type-name names type)))
    (('select types) `(select ,(map val-type-repr types)))
    (('ref.null ht) `(ref.null ,(heap-type-repr names ht)))
    (('ref.func f) `(ref.func ,(func-name names f)))
    ;; Memories
    (((and op (or 'i32.load 'i32.load16_s 'i32.load16_u 'i32.load8_s
                  'i32.load8_u 'i32.store 'i32.store16 'i32.store8
                  'i64.load 'i64.load32_s 'i64.load32_u 'i64.load16_s
                  'i64.load16_u 'i64.load8_s 'i64.load8_u 'f32.load
                  'f64.load 'i64.store 'i64.store32 'i64.store16
                  'i64.store8 'f32.store 'f64.store))
      memarg)
     `(,op ,@(memarg-repr names memarg)))
    (((and inst (or 'memory.size 'memory.grow)) mem)
     `(,inst ,(memory-name names mem)))
    (('memory.init data mem)
     `(memory.init ,(data-name names data) ,(memory-name names mem)))
    (('memory.copy dst src)
     `(memory.copy ,(memory-name names dst) ,(memory-name names src)))
    (('memory.fill mem)
     `(memory.fill ,(memory-name names mem)))
    (('data.drop data)
     `(data.drop ,(data-name names data)))
    ;; Tables
    (((and op (or 'table.get 'table.set 'table.grow 'table.size 'table.fill)) table)
     `(,op ,(table-name names table)))
    (('table.init table elem)
     `(table.init ,(table-name names table) ,(elem-name names elem)))
    (('table.copy dst src)
     `(table.copy ,(table-name names dst) ,(table-name names src)))
    (('elem.drop elem)
     `(elem.drop ,(elem-name names elem)))
    ;; GC
    (((and op (or 'ref.test 'ref.cast)) rt)
     `(,op ,@(ref-type-repr names rt)))
    (((and op (or 'br_on_cast 'br_on_cast_fail)) label rt1 rt2)
     `(,op ,label ,@(ref-type-repr names rt1) ,@(ref-type-repr names rt2)))
    (((and op (or 'struct.get 'struct.get_s 'struct.get_u 'struct.set)) type field)
     `(,op ,(type-name names type) ,(field-name names type field)))
    (((and op (or 'struct.new 'struct.new_default)) type)
     `(,op ,(type-name names type)))
    (((and op (or 'array.get 'array.get_s 'array.get_u 'array.set)) type)
     `(,op ,(type-name names type)))
    (('array.new_fixed type len)
     `(array.new_fixed ,(type-name names type) ,len))
    (((and op (or 'array.new 'array.new_default)) type)
     `(,op ,(type-name names type)))
    (((and op (or 'array.new_data 'array.init_data)) type data)
     `(,op ,(type-name names type) ,(data-name names data)))
    (((and op (or 'array.new_elem 'array.init_elem)) type elem)
     `(,op ,(type-name names type) ,(elem-name names elem)))
    (('array.fill type)
     `(array.fill ,(type-name names type)))
    (('array.copy dst src)
     `(array.copy ,(type-name names dst) ,(type-name names src)))
    ;; Stringref
    (('string.const idx)
     `(string.const (list-ref strings idx)))
    (((and op (or 'string.new_utf8 'string.new_lossy_utf8 'string.new_wtf8
                  'string.new_wtf16
                  'string.encode_utf8 'string.encode_lossy_utf8
                  'string.encode_wtf8 'string.encode_wtf16
                  'stringview_wtf8.encode_utf8
                  'stringview_wtf8.encode_lossy_utf8
                  'stringview_wtf8.encode_wtf8
                  'stringview_wtf16.encode))
      mem)
     `(,op ,@(memarg-repr names mem)))
    (_ instr)))

(define (for-each/index proc lst)
  (let loop ((lst lst) (i 0))
    (match lst
      (() *unspecified*)
      ((x . rest)
       (proc i x)
       (loop rest (+ i 1))))))

(define (print-list proc title items)
  (format #t "~a:\n" title)
  (for-each/index (lambda (i item)
                    (format #t "  ~a:\t" i)
                    (proc item))
                  items))

(define (print-stack stack)
  (match (wasm-stack-items stack)
    (() (display "Empty stack.\n"))
    (items
     (print-list (lambda (x) (format #t "~s\n" x))
                 "Value stack"
                 items))))

(define (print-locals locals)
  (if (zero? (vector-length locals))
      (display "No locals.\n")
      (print-list (lambda (x) (format #t "~s\n" x))
                  "Locals"
                  (vector->list locals))))

(define (print-runtime-error e)
  (print-exception (current-output-port) #f
                   (exception-kind e)
                   (exception-args e))
  (newline)
  (print-stack (wasm-runtime-error-stack e))
  (newline)
  (print-locals (wasm-runtime-error-locals e))
  (newline)
  (print-location (validated-wasm-ref
                   (wasm-instance-module
                    (wasm-runtime-error-instance e)))
                  (wasm-runtime-error-position e)))

(define-syntax-rule (with-exception-handling body ...)
  (with-exception-handler (lambda (e) (print-runtime-error e))
    (lambda () body ...)
    #:unwind? #t
    #:unwind-for-type &wasm-runtime-error))

(define (print-location wasm path)
  (define invalid-path '(-1))
  (define (path-remainder path i)
    (match path
      ((idx . rest)
       (if (and (= idx i) (not (null? rest))) rest invalid-path))))
  (define (here? path i)
    (match path
      ((idx) (= i idx))
      (_ #f)))
  (define (indent level)
    (unless (= level 0)
      (display "  ")
      (indent (- level 1))))
  (define (print-block-type type)
    (for-each (lambda (x)
                (format #t " ~s" x))
              (block-type-repr #f type)))
  (define (print-instr level instr path)
    (match instr
      (((and op (or 'block 'loop)) _ (or ($ <type-use> _ sig) sig) body)
       (format #t "(~a" op)
       (print-block-type sig)
       (newline)
       (print-instrs (+ level 1) body path)
       (display ")"))
      (('if _ (or ($ <type-use> _ sig) sig) consequent alternate)
       (display "(if")
       (print-block-type sig)
       (unless (null? consequent)
         (newline)
         (indent (+ level 1))
         (display "(then\n")
         (print-instrs (+ level 2) consequent
                       (path-remainder path 0))
         (display ")"))
       (unless (null? alternate)
         (newline)
         (indent (+ level 1))
         (display "(else\n")
         (print-instrs (+ level 2) alternate
                       (path-remainder path 1))
         (display ")"))
       (display ")"))
      (_
       (write instr))))
  (define (print-instrs level instrs path)
    (indent level)
    (let loop ((instrs instrs)
               (i 0))
      (match instrs
        (() #t)
        ((instr . rest)
         (if (here? path i)
             (begin
               (display "<<< ")
               (print-instr level instr (path-remainder path i))
               (display " >>>"))
             (print-instr level instr (path-remainder path i)))
         (unless (null? rest)
           (newline)
           (indent level)
           (loop rest (+ i 1)))))))
  (define (count-imports kind)
    (fold (lambda (i sum)
            (match i
              (($ <import> _ _ k)
               (if (eq? kind k) (+ sum 1) sum))))
          0 (wasm-imports wasm)))
  (match path
    (('func idx . path*)
     (match (list-ref (wasm-funcs wasm) (- idx (count-imports 'func)))
       (($ <func> id ($ <type-use> _ sig) locals body)
        (format #t "(func ~a" idx)
        (print-block-type sig)
        (newline)
        (print-instrs 1 body path*)
        (display ")"))))
    (('global idx . path*)
     (match (list-ref (wasm-globals wasm) (- idx (count-imports 'global)))
       (($ <global> id ($ <global-type> mutable? type) init)
        (let ((t (val-type-repr #f type)))
          (format #t "(global ~a " idx)
          (write (if mutable? `(mut ,t) t))
          (newline)
          (print-instrs 1 init path*)
          (display ")")))))
    (('data idx . path*)
     (match (list-ref (wasm-datas wasm) idx)
       (($ <data> id mode mem offset init)
        (format #t "(data ~a ~a ~a ~a\n" idx mode mem offset)
        (print-instrs 1 init path*)
        (display ")"))))
    (('elem idx j . path*)
     (match (list-ref (wasm-elems wasm) idx)
       (($ <elem> id mode table type offset inits)
        (let ((t (val-type-repr #f type)))
          (format #t "(elem ~a ~a ~a ~a" idx mode table t)
          (when offset
            (newline)
            (print-instrs 1 offset (if (= j 0) path* invalid-path)))
          (let loop ((inits inits) (i 1))
            (match inits
              (() #t)
              ((init . rest)
               (newline)
               (print-instrs 1 init (if (= j 1) path* invalid-path))
               (loop rest (+ i 1)))))
          (display ")"))))))
  (newline))

(define (wasm-trace path instr instance stack blocks locals)
  (define (obj-abbrev obj)
    (match obj
      ((? wasm-func?) 'func)
      ((? wasm-null?) 'null)
      ((? wasm-struct?) 'struct)
      ((? wasm-array?) 'array)
      (_ obj)))
  (let* ((wasm (validated-wasm-ref (wasm-instance-module instance)))
         (names (find names? (wasm-custom wasm)))
         (strings (wasm-strings wasm))
         (path (reverse path))
         (where (match path
                  (('func idx . _)
                   (func-name names idx))
                  (('global idx . _)
                   (global-name names idx))
                  (('data idx . _)
                   (data-name names idx))
                  (('elem idx . _)
                   (elem-name names idx))))
         (func-idx (match path
                     (('func idx . _) idx)
                     (_ #f)))
         (instr (match instr
                  ;; Abbreviate blocks.
                  (((and (or 'block 'loop) op) label type body)
                   `(,op ,@(block-type-repr names type) ...))
                  (('if label type consequent alternate)
                   `(if ,@(block-type-repr names type) ...))
                  (('try label type body catches catch-all)
                   `(try ,@(block-type-repr names type) ...))
                  (('try_delegate label type body handler)
                   `(try_delegate ,@(block-type-repr names type) ...))
                  (_ (instruction-repr instr names strings func-idx)))))
    (format #t "⌄ instr:  ~a\n" instr)
    (format #t "  where:  ~a @ ~a\n" instance where)
    (format #t "  stack:  ~s\n" (map obj-abbrev (wasm-stack-items stack)))
    (format #t "  locals: ~a\n" (map obj-abbrev (vector->list locals)))))

(define (->wasm x)
  (match x
    ((? wasm? wasm) wasm)
    ((? validated-wasm? mod) (validated-wasm-ref mod))
    ((? wasm-instance? instance)
     (validated-wasm-ref (wasm-instance-module instance)))
    ((? hoot-module? mod)
     (validated-wasm-ref
      (wasm-instance-module
       (hoot-module-instance mod))))))

(define-record-type <wasm-debug>
  (make-wasm-debug position instruction instance stack blocks locals)
  wasm-debug?
  (position wasm-debug-position)
  (instruction wasm-debug-instruction)
  (instance wasm-debug-instance)
  (stack wasm-debug-stack)
  (blocks wasm-debug-blocks)
  (locals wasm-debug-locals)
  (continue? wasm-debug-continue? set-wasm-debug-continue!))

(define current-wasm-debug (make-parameter #f))

(define-syntax-rule (when-debugging body ...)
  (if (current-wasm-debug)
      (begin body ...)
      (error "not in a WASM debugger")))

;; This code is based on error-string in (system repl
;; exception-handling) and adapted to work with Guile's new exception
;; objects.
(define (error-message exn stack)
  (let ((key (exception-kind exn))
        (args (exception-args exn)))
    (call-with-output-string
      (lambda (port)
        (let ((frame (and (< 0 (vector-length stack)) (vector-ref stack 0))))
          (print-exception port frame key args))))))

(define (enter-wasm-debugger exn)
  (let* ((tag (and (pair? (fluid-ref %stacks))
                   (cdr (fluid-ref %stacks))))
         (stack (stack->vector (make-stack #t 3 tag 0 1)))
         (msg (error-message exn stack))
         (wasm-debug (make-wasm-debug (wasm-runtime-error-position exn)
                                      (wasm-runtime-error-instruction exn)
                                      (wasm-runtime-error-instance exn)
                                      (wasm-runtime-error-stack exn)
                                      (wasm-runtime-error-blocks exn)
                                      (wasm-runtime-error-locals exn))))
    (parameterize ((current-wasm-debug wasm-debug))
      (format #t "~a\n" msg)
      (format #t "Entering WASM debug prompt. ")
      (format #t "Type `,help wasm' for info or `,q' to continue.\n")
      (start-repl #:debug (make-debug stack 0 msg))
      (wasm-debug-continue? wasm-debug))))

(define (wasm-step position instruction instance stack blocks locals)
  (let ((wasm-debug (make-wasm-debug (reverse position) instruction instance stack
                                     blocks locals)))
    (parameterize ((current-wasm-debug wasm-debug))
      (format #t "Instruction: ~a\n" instruction)
      (format #t "Location: ~a\n" (reverse position))
      (start-repl))))

(define (reset-instruction-listener)
  (current-instruction-listener
   (lambda (position instr instance stack blocks locals) #t)))

(define (continue)
  (set-wasm-debug-continue! (current-wasm-debug) #t)
  (throw 'quit))

(define-meta-command ((wasm-dump wasm) repl #:optional exp)
  "wasm-dump [WASM]
Display information about WASM, or the current WASM instance when debugging."
  (dump-wasm (->wasm
              (cond
               (exp (repl-eval repl exp))
               ((current-wasm-debug) => wasm-debug-instance)
               (else (error "no WASM object specified"))))
             #:dump-func-defs? #f))

(define-meta-command ((wasm-disassemble wasm) repl #:optional exp)
  "wasm-disassemble [WASM]
Display the disassembly of WASM, or the current WASM instance when debugging."
  (pretty-print
   (wasm->wat
    (unresolve-wasm
     (->wasm
      (cond
       (exp (repl-eval repl exp))
       ((current-wasm-debug) => wasm-debug-instance)
       (else (error "no WASM object specified"))))))))

(define-meta-command ((wasm-trace wasm) repl exp)
  "wasm-trace EXP
Evaluate EXP with verbose WASM tracing enabled."
  (with-exception-handling
   (parameterize ((current-instruction-listener wasm-trace))
     (call-with-values (lambda () (repl-eval repl exp))
       (lambda vals
         (for-each (lambda (v) (repl-print repl v)) vals))))))

(define-meta-command ((wasm-freq wasm) repl exp)
  "wasm-freq EXP
Evaluate EXP and count how many times each WASM instruction is evaluated."
  (let ((count 0)
        (histogram (make-hash-table)))
    (define (wasm-stats path instr instance stack blocks locals)
      (set! count (+ count 1))
      (match instr
        ((op . _)
         (hashq-set! histogram op (+ (hashq-ref histogram op 0) 1)))))
    (with-exception-handling
     (parameterize ((current-instruction-listener wasm-stats))
       (call-with-values (lambda () (repl-eval repl exp))
         (lambda vals
           (display "op\tcount\n")
           (display "--\t-----\n")
           (for-each (match-lambda
                       ((op . k)
                        (format #t "~a\t~a\n" op k)))
                     (sort (hash-fold alist-cons '() histogram)
                           (lambda (a b) (< (cdr a) (cdr b)))))
           (format #t "\n~a instructions total\n\n" count)
           (for-each (lambda (v) (repl-print repl v)) vals)))))))

(define-meta-command ((wasm-catch wasm) repl exp)
  "wasm-catch EXP
Catch and debug WASM runtime errors that are raised by evaluating EXP."
  (let ((thunk (repl-prepare-eval-thunk repl exp)))
    (call/ec
     (lambda (return)
       (with-exception-handler (lambda (exn)
                                 (if (wasm-runtime-error? exn)
                                     (unless (enter-wasm-debugger exn)
                                       (reset-instruction-listener)
                                       (return))
                                     (raise-exception exn)))
         (lambda ()
           (call-with-values (lambda () (%start-stack #t thunk))
             (lambda vals
               (reset-instruction-listener)
               (for-each (lambda (v) (repl-print repl v)) vals)))))))))

(define-meta-command ((wasm-stack wasm) repl)
  "wasm-stack
Print the state of the WASM stack in the current context."
  (when-debugging
   (print-stack (wasm-debug-stack (current-wasm-debug)))))

(define-meta-command ((wasm-locals wasm) repl)
  "wasm-locals
Print the state of the WASM locals in the current context."
  (when-debugging
   (print-locals (wasm-debug-locals (current-wasm-debug)))))

(define-meta-command ((wasm-pos wasm) repl)
  "wasm-pos
Highlight the instruction where WASM execution has paused."
  (when-debugging
   (let ((debug (current-wasm-debug)))
     (print-location (->wasm (wasm-debug-instance debug)) (wasm-debug-position debug)))))

(define-meta-command ((wasm-eval wasm) repl instr)
  "wasm-eval INSTR
Evaluate the WASM instruction INSTR in the current debug context."
  (when-debugging
   (let ((execute (@@ (wasm vm) execute)))
     (match (current-wasm-debug)
       (($ <wasm-debug> position _ instance stack blocks locals)
        (execute (repl-eval repl instr) position instance stack blocks locals))))))

(define-meta-command ((wasm-continue wasm) repl)
  "wasm-continue
Set WASM execution to continue without interruption until the next error."
  (when-debugging
   (reset-instruction-listener)
   (when (current-wasm-debug)
     (continue))))

(define-meta-command ((wasm-step wasm) repl)
  "wasm-step
Set WASM execution to pause before each instruction."
  (when-debugging
   (current-instruction-listener wasm-step)
   (when (current-wasm-debug)
     (continue))))