From c89fa72138946e5ec739ba79cb1261a74f1de0c3 Mon Sep 17 00:00:00 2001 From: Alex Wood Date: Fri, 6 Oct 2023 21:31:58 -0400 Subject: [PATCH] Improve trace output appearance --- README.md | 25 ++++++------- disassemble.lisp | 91 ++++++++++++++++++++++++++++-------------------- machine.lisp | 2 +- vm-cross.lisp | 21 +++++------ vm-native.lisp | 23 ++++++------ 5 files changed, 88 insertions(+), 74 deletions(-) diff --git a/README.md b/README.md index 7d5dae0..9b84a8d 100644 --- a/README.md +++ b/README.md @@ -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) #(#)) -((CALL COMMON-LISP:NIL (:OPERAND 1)) 4 8 #(3 5) #(# 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 #(#) + call 1 ; bp 1 sp 5 locals #(3 5) stack #(# 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) #(#)) -((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 '# ; bp 1 sp 5 locals #(3 5) stack #(5 3) + pop ; bp 1 sp 4 locals #(3 5) stack #(#) + return ; bp 1 sp 3 locals #(3 5) stack #() # ``` diff --git a/disassemble.lisp b/disassemble.lisp index 486503b..4a144a0 100644 --- a/disassemble.lisp +++ b/disassemble.lisp @@ -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)) @@ -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)) diff --git a/machine.lisp b/machine.lisp index 00a0e38..6f98569 100644 --- a/machine.lisp +++ b/machine.lisp @@ -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. diff --git a/vm-cross.lisp b/vm-cross.lisp index ae035a6..57ebdec 100644 --- a/vm-cross.lisp +++ b/vm-cross.lisp @@ -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) @@ -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 diff --git a/vm-native.lisp b/vm-native.lisp index cd66a48..aec8e88 100644 --- a/vm-native.lisp +++ b/vm-native.lisp @@ -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) @@ -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))