Skip to content

Commit

Permalink
Improve trace output appearance
Browse files Browse the repository at this point in the history
  • Loading branch information
@Bike
Bike committed Oct 7, 2023
1 parent ccd0639 commit c89fa72
Show file tree
Hide file tree
Showing 5 changed files with 88 additions and 74 deletions.
25 changes: 13 additions & 12 deletions README.md
View file
Original file line number Diff line number Diff line change
Expand Up @@ -52,19 +52,20 @@ You can get a running trace of the machine state by binding `cvm.vm-native:*trac
```lisp
(let ((cvm.vm-native:*trace* t)) (funcall *f* 3)) ; =>
((CHECK-ARG-COUNT-= COMMON-LISP:NIL (:OPERAND 1)) 4 6 #(5 0) #())
((BIND-REQUIRED-ARGS COMMON-LISP:NIL (:OPERAND 1)) 4 6 #(5 0) #())
((CONST COMMON-LISP:NIL (:CONSTANT 0)) 4 6 #(3 0) #())
((SET COMMON-LISP:NIL (:OPERAND 1)) 4 7 #(3 0) #(5))
((FDEFINITION COMMON-LISP:NIL (:CONSTANT 1)) 4 6 #(3 5) #())
((REF COMMON-LISP:NIL (:OPERAND 1)) 4 7 #(3 5) #(#<FUNCTION PRINT>))
((CALL COMMON-LISP:NIL (:OPERAND 1)) 4 8 #(3 5) #(#<FUNCTION PRINT> 5))
check-arg-count-= 1 ; bp 1 sp 3 locals #(0 0) stack #()
bind-required-args 1 ; bp 1 sp 3 locals #(0 0) stack #()
const '5 ; bp 1 sp 3 locals #(3 0) stack #()
set 1 ; bp 1 sp 4 locals #(3 0) stack #(5)
fdefinition 'PRINT ; bp 1 sp 3 locals #(3 5) stack #()
ref 1 ; bp 1 sp 4 locals #(3 5) stack #(#<FUNCTION PRINT>)
call 1 ; bp 1 sp 5 locals #(3 5) stack #(#<FUNCTION PRINT> 5)
5
((REF COMMON-LISP:NIL (:OPERAND 1)) 4 6 #(3 5) #())
((REF COMMON-LISP:NIL (:OPERAND 0)) 4 7 #(3 5) #(5))
((MAKE-CLOSURE COMMON-LISP:NIL (:CONSTANT 3)) 4 8 #(3 5) #(5 3))
((POP COMMON-LISP:NIL) 4 7 #(3 5) #(#<BYTECODE-CLOSURE {1002F681CB}>))
((RETURN COMMON-LISP:NIL) 4 6 #(3 5) #())
ref 1 ; bp 1 sp 3 locals #(3 5) stack #()
ref 0 ; bp 1 sp 4 locals #(3 5) stack #(5)
make-closure '#<CVM.MACHINE:BYTECODE-FUNCTION NIL> ; bp 1 sp 5 locals #(3 5) stack #(5 3)
pop ; bp 1 sp 4 locals #(3 5) stack #(#<CVM.MACHINE:BYTECODE-CLOSURE NIL>)
return ; bp 1 sp 3 locals #(3 5) stack #()
#<CVM.MACHINE:BYTECODE-CLOSURE {100C2D80CB}>
```
Expand Down
91 changes: 53 additions & 38 deletions disassemble.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -68,6 +68,46 @@
do (incf ip nbytes)
finally (cl:return (values (list* (first desc) longp args) ip)))))

(defun %display-instruction (name longp args textify-operand)
(if (string= name "parse-key-args")
;; We special case this despite the keys-arg thing because it's
;; just pretty weird all around.
(let* ((more-start (second (first args)))
(kci (second (second args)))
(aokp (logbitp (if longp 15 7) kci))
(key-count (logand kci (if longp #x7fff #x7f)))
(keys (third args))
(framestart (second (fourth args))))
;; Print
(format t "~& ~:[~;long ~]~(~a~)~:[~;-aok~] ~d ~d '~s ~d"
longp name aokp more-start key-count
(funcall textify-operand keys key-count) framestart))
;; Normal case
(format t "~& ~:[~;long ~]~(~a~)~{ ~a~}"
longp name (mapcar textify-operand args))))

(defun operand-textifier (literals)
(flet ((textify-operand (thing &optional key-count)
(destructuring-bind (kind value) thing
(cond ((cl:eq kind :constant)
(format () "'~s" (aref literals value)))
((cl:eq kind :label) (format () "L~a" value))
((cl:eq kind :operand) (format () "~d" value))
((cl:eq kind :keys)
(let ((keys cl:nil) (keystart value))
(do ((i 0 (1+ i)))
((= i key-count) (setq keys (nreverse keys)))
(cl:push (aref literals (+ keystart i)) keys))
(format () "'~s" keys)))
(t (error "Illegal kind ~a" kind))))))
#'textify-operand))

;;; Used externally by tracers.
(defun display-instruction (bytecode literals ip)
(destructuring-bind (name longp . args)
(disassemble-instruction bytecode ip)
(%display-instruction name longp args (operand-textifier literals))))

(defun %disassemble-bytecode (bytecode start end)
(let* ((labels (gather-labels bytecode start end))
(ip start))
Expand All @@ -84,44 +124,19 @@

(defun disassemble-bytecode (bytecode literals
&key (start 0) (end (length bytecode)))
(let ((dis (%disassemble-bytecode bytecode start end)))
(flet ((textify-operand (thing)
(destructuring-bind (kind value) thing
(cond ((cl:eq kind :constant) (format () "'~s" (aref literals value)))
((cl:eq kind :label) (format () "L~a" value))
((cl:eq kind :operand) (format () "~d" value))
;; :keys special cased below
(t (error "Illegal kind ~a" kind))))))
(format t "~&---module---~%")
(dolist (item dis)
(cond
((consp item)
;; instruction
(destructuring-bind (name longp . args) item
(if (string= name "parse-key-args")
;; We special case this despite the keys-arg thing because it's
;; just pretty weird all around.
(let* ((more-start (second (first args)))
(kci (second (second args)))
(aokp (logbitp (if longp 15 7) kci))
(key-count (logand kci (if longp #x7fff #x7f)))
(keystart (second (third args)))
(keys cl:nil)
(framestart (second (fourth args))))
;; Gather the keys
(do ((i 0 (1+ i)))
((= i key-count) (setq keys (nreverse keys)))
(cl:push (aref literals (+ keystart i)) keys))
;; Print
(format t "~& ~:[~;long ~]~(~a~)~:[~;-aok~] ~d ~d '~s ~d"
longp name aokp more-start key-count keys framestart))
;; Normal case
(format t "~& ~:[~;long ~]~(~a~)~{ ~a~}~%"
longp name (mapcar #'textify-operand args)))))
((or (stringp item) (symbolp item))
;; label
(format t "~&L~a:~%" item))
(t (error "Illegal item ~a" item))))))
(let ((dis (%disassemble-bytecode bytecode start end))
(textify-operand (operand-textifier literals)))
(format t "~&---module---~%")
(dolist (item dis)
(cond
((consp item)
;; instruction
(destructuring-bind (name longp . args) item
(%display-instruction name longp args textify-operand)))
((or (stringp item) (symbolp item))
;; label
(format t "~&L~a:~%" item))
(t (error "Illegal item ~a" item)))))
(values))

(defgeneric disassemble (object))
Expand Down
2 changes: 1 addition & 1 deletion machine.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -19,7 +19,7 @@
(:export #:link-function #:link-variable #:link-environment)
(:export #:boundp #:makunbound #:symbol-value #:call-with-progv #:progv
#:fdefinition #:fmakunbound #:fboundp)
(:export #:disassemble #:disassemble-instruction))
(:export #:disassemble #:display-instruction))

;;;; Definition of the virtual machine, used by both the compiler and the VM.

Expand Down
21 changes: 9 additions & 12 deletions vm-cross.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -236,18 +236,15 @@
(dest (catch-dynenv-dest de)))
(unwind-to vm rtag dest (rest catch-de-stack))))))

(defun instruction-trace (bytecode stack ip bp sp frame-size)
(defun instruction-trace (bytecode literals stack ip bp sp frame-size)
(fresh-line *trace-output*)
(let ((frame-end (+ bp frame-size))
;; skip package prefixes on inst names.
(*package* (find-package "CVM.MACHINE")))
(prin1 (list (m:disassemble-instruction bytecode ip)
bp
sp
(subseq stack bp frame-end)
;; We take the max for partial frames.
(subseq stack frame-end (max sp frame-end)))
*trace-output*)))
(let ((*standard-output* *trace-output*))
(cvm.machine:display-instruction bytecode literals ip))
(let ((frame-end (+ bp frame-size)))
(format *trace-output* " ; bp ~d sp ~d locals ~s stack ~s~%"
bp sp (subseq stack bp frame-end)
;; We take the max for partial frames.
(subseq stack frame-end (max sp frame-end)))))

(defun vm (bytecode closure constants frame-size)
(declare (type (simple-array (unsigned-byte 8) (*)) bytecode)
Expand Down Expand Up @@ -322,7 +319,7 @@
(when (>= ip end)
(error "Invalid bytecode: Reached end"))
(when trace
(instruction-trace bytecode stack ip bp sp frame-size))
(instruction-trace bytecode constants stack ip bp sp frame-size))
;; The catch is for NLX. Without NLX, a (go loop) at the
;; bottom skips back up to the loop without setting IP.
;; When something NLXs to this frame, we throw the new IP
Expand Down
23 changes: 12 additions & 11 deletions vm-native.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -75,6 +75,16 @@
(defstruct (sbind-dynenv (:include dynenv)
(:constructor make-sbind-dynenv ())))

(defun instruction-trace (bytecode literals stack ip bp sp frame-size)
(fresh-line *trace-output*)
(let ((*standard-output* *trace-output*))
(cvm.machine:display-instruction bytecode literals ip))
(let ((frame-end (+ bp frame-size)))
(format *trace-output* " ; bp ~d sp ~d locals ~s stack ~s~%"
bp sp (subseq stack bp frame-end)
;; We take the max for partial frames.
(subseq stack frame-end (max sp frame-end)))))

(defun vm (bytecode closure constants frame-size)
(declare (type (simple-array (unsigned-byte 8) (*)) bytecode)
(type (simple-array t (*)) closure constants)
Expand Down Expand Up @@ -144,17 +154,8 @@
with trace = *trace*
until (eql ip end)
when trace
do (fresh-line *trace-output*)
(let ((frame-end (+ bp frame-size))
; skip package prefixes on inst names.
(*package* (find-package "CVM.MACHINE")))
(prin1 (list (m:disassemble-instruction bytecode ip)
bp
sp
(subseq stack bp frame-end)
;; We take the max for partial frames.
(subseq stack frame-end (max sp frame-end)))
*trace-output*))
do (instruction-trace bytecode constants stack
ip bp sp frame-size)
do (case (code)
((#.m:ref) (spush (local (next-code))) (incf ip))
((#.m:const) (spush (constant (next-code))) (incf ip))
Expand Down

0 comments on commit c89fa72

Please sign in to comment.