diff options
author | Andy Wingo <wingo@pobox.com> | 2008-10-12 22:49:24 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2008-10-12 22:49:24 +0200 |
commit | 02b1883e5661eb1a9bfb196e060a22c2c2cadc88 (patch) | |
tree | b92f9f4070f23647dd153f2c31fc9d1c8056bdf0 | |
parent | 95b6ad34c3eefeaf85723841dca92c7da8f1322a (diff) | |
download | guile-02b1883e5661eb1a9bfb196e060a22c2c2cadc88.tar.gz |
make disassembly better -- a more woven text.
* module/system/vm/assemble.scm (pop): Define a pop here too.
(codegen): Rework how bindings are represented in a program's
meta-info, so they declare their range in the binding list instead of
you having to figure out when they end.
* module/system/vm/conv.scm (make-byte-decoder): Return the end-address
as well; requires a change to callers.
* module/system/vm/disasm.scm (disassemble-objcode, disassemble-program)
(disassemble-bytecode, disassemble-objects, disassemble-externals)
(disassemble-meta, source->string, make-int16, code-annotation)
(print-info): Rework to display my domination of `format', and, more
seriously, start to integrate the "subsections" of the disassembly into
the main disassembly text.
* module/system/vm/program.scm (program-bindings-as-lambda-list): Update
for new bindings format; should be more correct.
-rw-r--r-- | module/system/vm/assemble.scm | 64 | ||||
-rw-r--r-- | module/system/vm/conv.scm | 4 | ||||
-rw-r--r-- | module/system/vm/disasm.scm | 130 | ||||
-rw-r--r-- | module/system/vm/program.scm | 6 |
4 files changed, 94 insertions, 110 deletions
diff --git a/module/system/vm/assemble.scm b/module/system/vm/assemble.scm index bbbee35cb..0da5fe071 100644 --- a/module/system/vm/assemble.scm +++ b/module/system/vm/assemble.scm @@ -74,6 +74,8 @@ (define-macro (push x loc) `(set! ,loc (cons ,x ,loc))) +(define-macro (pop loc) + `(let ((_x (car ,loc))) (set! ,loc (cdr ,loc)) _x)) ;; this is to avoid glil-const's desire to put constants in the object ;; array -- instead we explicitly want them in the code, because meta @@ -102,7 +104,8 @@ (record-case glil ((<vm-asm> venv glil body) (record-case glil ((<glil-asm> vars meta) ; body? (let ((stack '()) - (binding-alist '()) + (open-bindings '()) + (closed-bindings '()) (source-alist '()) (label-alist '()) (object-alist '())) @@ -120,6 +123,32 @@ (set! object-alist (acons x i object-alist)) i))))) (push-code! `(object-ref ,i)))))) + (define (munge-bindings bindings nargs) + (map + (lambda (v) + (let ((name (car v)) (type (cadr v)) (i (caddr v))) + (case type + ((argument) (make-binding name #f i)) + ((local) (make-binding name #f (+ nargs i))) + ((external) (make-binding name #t i)) + (else (error "unknown binding type" name type))))) + bindings)) + (define (push-bindings! bindings) + (push (cons (current-address) bindings) open-bindings)) + (define (close-binding!) + (let* ((bindings (pop open-bindings)) + (start (car bindings)) + (end (current-address))) + (for-each + (lambda (binding) + (push `(,start ,@binding ,start ,end) closed-bindings)) + (cdr bindings)))) + (define (finish-bindings!) + (while (not (null? open-bindings)) (close-binding!)) + (set! closed-bindings + (stable-sort! (reverse! closed-bindings) + (lambda (x y) (< (car x) (car y))))) + (set! closed-bindings (map cdr closed-bindings))) (define (current-address) (apply + (map byte-length stack))) (define (generate-code x) @@ -129,32 +158,14 @@ (if (venv-closure? venv) (push-code! `(make-closure)))) ((<glil-bind> (binds vars)) - (let ((bindings - (map (lambda (v) - (let ((name (car v)) (type (cadr v)) (i (caddr v))) - (case type - ((argument) (make-binding name #f i)) - ((local) (make-binding name #f (+ (glil-vars-nargs vars) i))) - ((external) (make-binding name #t i))))) - binds))) - (set! binding-alist - (acons (current-address) bindings binding-alist)))) + (push-bindings! (munge-bindings binds (glil-vars-nargs vars)))) ((<glil-mv-bind> (binds vars) rest) - (let ((bindings - (map (lambda (v) - (let ((name (car v)) (type (cadr v)) (i (caddr v))) - (case type - ((argument) (make-binding name #f i)) - ((local) (make-binding name #f (+ (glil-vars-nargs vars) i))) - ((external) (make-binding name #t i))))) - binds))) - (set! binding-alist - (acons (current-address) bindings binding-alist)) - (push-code! `(truncate-values ,(length binds) ,(if rest 1 0))))) + (push-bindings! (munge-bindings binds (glil-vars-nargs vars))) + (push-code! `(truncate-values ,(length binds) ,(if rest 1 0)))) ((<glil-unbind>) - (set! binding-alist (acons (current-address) #f binding-alist))) + (close-binding!)) ((<glil-source> loc) (set! source-alist (acons (current-address) loc source-alist))) @@ -255,14 +266,15 @@ ;; ;; main (for-each generate-code body) + (finish-bindings!) ; (format #t "codegen: stack = ~a~%" (reverse stack)) (let ((bytes (stack->bytes (reverse! stack) label-alist))) (if toplevel (bytecode->objcode bytes (glil-vars-nlocs vars) (glil-vars-nexts vars)) (make-bytespec #:vars vars #:bytes bytes - #:meta (make-meta (reverse! binding-alist) - (reverse! source-alist) - meta) + #:meta (make-meta closed-bindings + (reverse! source-alist) + meta) #:objs (let ((objs (map car (reverse! object-alist)))) (if (null? objs) #f (list->vector objs))) #:closure? (venv-closure? venv)))))))))) diff --git a/module/system/vm/conv.scm b/module/system/vm/conv.scm index 914044102..84bd28438 100644 --- a/module/system/vm/conv.scm +++ b/module/system/vm/conv.scm @@ -162,8 +162,8 @@ (do ((n n (1- n)) (l '() (cons (pop) l))) ((= n 0) (cons* inst (reverse! l))))))) - (values start code)) - (values #f #f))))) + (values start addr code)) + (values #f #f #f))))) ;;; diff --git a/module/system/vm/disasm.scm b/module/system/vm/disasm.scm index 7dea0a98b..8ba36675c 100644 --- a/module/system/vm/disasm.scm +++ b/module/system/vm/disasm.scm @@ -37,7 +37,7 @@ (bytes (program-bytecode prog))) (format #t "Disassembly of ~A:\n\n" objcode) (format #t "nlocs = ~A nexts = ~A\n\n" nlocs nexts) - (disassemble-bytecode bytes #f))) + (disassemble-bytecode bytes #f 0 #f #f '()))) (define (disassemble-program prog . opts) (let* ((arity (program-arity prog)) @@ -48,13 +48,19 @@ (bytes (program-bytecode prog)) (objs (program-objects prog)) (meta (program-meta prog)) - (exts (program-external prog))) + (exts (program-external prog)) + (binds (program-bindings prog)) + (blocs (and binds + (filter (lambda (x) (not (binding:extp x))) binds))) + (bexts (and binds + (filter binding:extp binds))) + (srcs (program-sources prog))) ;; Disassemble this bytecode (format #t "Disassembly of ~A:\n\n" prog) (format #t "nargs = ~A nrest = ~A nlocs = ~A nexts = ~A\n\n" nargs nrest nlocs nexts) (format #t "Bytecode:\n\n") - (disassemble-bytecode bytes objs) + (disassemble-bytecode bytes objs nargs blocs bexts srcs) (if (> (vector-length objs) 0) (disassemble-objects objs)) (if (pair? exts) @@ -69,24 +75,25 @@ (apply disassemble-program x opts)))) (vector->list objs)))) -(define (disassemble-bytecode bytes objs) +(define (disassemble-bytecode bytes objs nargs blocs bexts sources) (let ((decode (make-byte-decoder bytes)) (programs '())) - (define (lp addr code) + (define (lp start end code) (pmatch code (#f (newline)) ((load-program ,x) (let ((sym (gensym ""))) (set! programs (acons sym x programs)) - (print-info addr (format #f "(load-program #~A)" sym) #f))) + (print-info start `(load-program ,sym) #f #f))) (else - (print-info addr (list->info code) - (original-value addr code objs)))) + (print-info start code + (code-annotation end code objs nargs blocs bexts) + (and=> (assq end sources) source->string)))) (if code (call-with-values decode lp))) (call-with-values decode lp) (for-each (lambda (sym+bytes) (format #t "Bytecode #~A:\n\n" (car sym+bytes)) - (disassemble-bytecode (cdr sym+bytes) #f)) + (disassemble-bytecode (cdr sym+bytes) #f 0 #f #f '())) (reverse! programs)))) (define (disassemble-objects objs) @@ -94,8 +101,7 @@ (let ((len (vector-length objs))) (do ((n 0 (1+ n))) ((= n len) (newline)) - (let ((info (object->string (vector-ref objs n)))) - (print-info n info #f))))) + (print-info n (vector-ref objs n) #f #f)))) (define (disassemble-externals exts) (display "Externals:\n\n") @@ -103,94 +109,60 @@ (do ((n 0 (1+ n)) (l exts (cdr l))) ((null? l) (newline)) - (let ((info (object->string (car l)))) - (print-info n info #f))))) + (print-info n (car l) #f)))) (define-macro (unless test . body) `(if (not ,test) (begin ,@body))) -(define (disassemble-bindings prog bindings) - (let* ((nargs (arity:nargs (program-arity prog))) - (args (if (zero? nargs) '() (cdar bindings))) - (nonargs (if (zero? nargs) bindings (cdr bindings)))) - (unless (null? args) - (display "Arguments:\n\n") - (for-each (lambda (bind n) - (print-info n - (format #f "~a[~a]: ~a" - (if (cadr bind) 'external 'local) - (caddr bind) (car bind)) - #f)) - args - (iota nargs)) - (newline)) - (unless (null? nonargs) - (display "Bindings:\n\n") - (for-each (lambda (start binds end) - (for-each (lambda (bind) - (print-info (format #f "~a-~a" start end) - (format #f "~a[~a]: ~a" - (if (cadr bind) 'external 'local) - (caddr bind) (car bind)) - #f)) - binds)) - (map car (filter cdr nonargs)) - (map cdr (filter cdr nonargs)) - (map car (filter (lambda (x) (not (cdr x))) nonargs))) - (newline)))) +(define *uninteresting-props* '(name)) (define (disassemble-meta program meta) - (let ((bindings (car meta)) - (sources (cadr meta)) - (props (cddr meta))) - (unless (null? bindings) - (disassemble-bindings program bindings)) - (unless (null? sources) - (display "Sources:\n\n") - (for-each (lambda (x) - (print-info (car x) (list->info (cdr x)) #f)) - sources) - (newline)) + (let ((sources (cadr meta)) + (props (filter (lambda (x) + (not (memq (car x) *uninteresting-props*))) + (cddr meta)))) (unless (null? props) (display "Properties:\n\n") - (for-each (lambda (x) (print-info #f x #f)) props) + (for-each (lambda (x) (print-info #f x #f #f)) props) (newline)))) -(define (original-value addr code objs) +(define (source->string src) + (format #f "~a:~a:~a" (or (source:file src) "(unknown file)") + (source:line src) (source:column src))) + +(define (make-int16 byte1 byte2) + (+ (* byte1 256) byte2)) + +(define (code-annotation end-addr code objs nargs blocs bexts) (let* ((code (code-unpack code)) (inst (car code)) (args (cdr code))) (case inst ((list vector) - (let ((len (+ (* (cadr code) 256) (caddr code)))) - (format #f "~a element~a" len (if (> len 1) "s" "")))) + (list "~a element~:p" (apply make-int16 args))) ((br br-if br-if-eq br-if-not br-if-not-eq br-if-not-null br-if-null) - (let ((offset (+ (* (car args) 256) (cadr args)))) - (format #f "-> ~A" (+ addr offset 3)))) + (list "-> ~A" (+ end-addr (apply make-int16 args)))) ((object-ref) - (if objs (object->string (vector-ref objs (car args))) #f)) + (and objs (list "~s" (vector-ref objs (car args))))) + ((local-ref local-set) + (and blocs + (let ((b (list-ref blocs (car args)))) + (list "`~a'~@[ (arg)~]" + (binding:name b) (< (binding:index b) nargs))))) + ((external-ref external-set) + (and bexts + (let ((b (list-ref bexts (car args)))) + (list "`~a'~@[ (arg)~]" + (binding:name b) (< (binding:index b) nargs))))) ((mv-call) - (let ((offset (+ (* (caddr code) 256) (cadddr code)))) - (format #f "MV -> ~A" (+ addr offset 4)))) + (list "MV -> ~A" (+ end-addr (apply make-int16 args)))) (else - (and=> (code->object code) object->string))))) - -(define (list->info list) - (object->string list)) - -; (define (u8vector->string vec) -; (list->string (map integer->char (u8vector->list vec)))) - -; (case (car list) -; ((link) -; (object->string `(link ,(u8vector->string (cadr list))))) -; (else -; (object->string list)))) + (and=> (code->object code) + (lambda (obj) (list "~s" obj))))))) -(define (print-info addr info extra) - (if extra - (format #t "~4@A ~32A;; ~A\n" addr info extra) - (format #t "~4@A ~A\n" addr info))) +;; i am format's daddy. +(define (print-info addr info extra src) + (format #t "~4@S ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n" addr info extra src)) (define (simplify x) (cond ((string? x) diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm index f31d5bf31..b52f7f39c 100644 --- a/module/system/vm/program.scm +++ b/module/system/vm/program.scm @@ -84,10 +84,10 @@ (rest? (not (zero? (arity:nrest (program-arity prog)))))) (if (or (null? bindings) (not bindings)) (if rest? (cons (1- nargs) 1) (list nargs)) - (let ((arg-names (map binding:name (cdar bindings)))) + (let ((args (map binding:name (list-head bindings nargs)))) (if rest? - (apply cons* arg-names) - arg-names))))) + (apply cons* args) + args))))) (define (write-program prog port) (format port "#<program ~a ~a>" |