diff options
Diffstat (limited to 'module/language/assembly')
-rw-r--r-- | module/language/assembly/compile-bytecode.scm | 5 | ||||
-rw-r--r-- | module/language/assembly/decompile-bytecode.scm | 6 | ||||
-rw-r--r-- | module/language/assembly/disassemble.scm | 40 |
3 files changed, 22 insertions, 29 deletions
diff --git a/module/language/assembly/compile-bytecode.scm b/module/language/assembly/compile-bytecode.scm index 4b9f7b701..0a1489845 100644 --- a/module/language/assembly/compile-bytecode.scm +++ b/module/language/assembly/compile-bytecode.scm @@ -89,12 +89,11 @@ (len (instruction-length inst))) (write-byte opcode) (pmatch asm - ((load-program ,nargs ,nrest ,nlocs ,nexts - ,labels ,length ,meta . ,code) + ((load-program ,nargs ,nrest ,nlocs ,labels ,length ,meta . ,code) (write-byte nargs) (write-byte nrest) (write-byte nlocs) - (write-byte nexts) + (write-byte 0) ;; what used to be nexts (write-uint32 length) (write-uint32 (if meta (1- (byte-length meta)) 0)) (letrec ((i 0) diff --git a/module/language/assembly/decompile-bytecode.scm b/module/language/assembly/decompile-bytecode.scm index fdf27ec62..56f58f750 100644 --- a/module/language/assembly/decompile-bytecode.scm +++ b/module/language/assembly/decompile-bytecode.scm @@ -1,6 +1,6 @@ ;;; Guile VM code converters -;; Copyright (C) 2001 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -49,7 +49,7 @@ (- x (ash 1 16))))) (define (decode-load-program pop) - (let* ((nargs (pop)) (nrest (pop)) (nlocs (pop)) (nexts (pop)) + (let* ((nargs (pop)) (nrest (pop)) (nlocs (pop)) (unused (pop)) (a (pop)) (b (pop)) (c (pop)) (d (pop)) (e (pop)) (f (pop)) (g (pop)) (h (pop)) (len (+ a (ash b 8) (ash c 16) (ash d 24))) @@ -74,7 +74,7 @@ (cond ((> i len) (error "error decoding program -- read too many bytes" out)) ((= i len) - `(load-program ,nargs ,nrest ,nlocs ,nexts + `(load-program ,nargs ,nrest ,nlocs ,(map (lambda (x) (cons (cdr x) (car x))) (reverse labels)) ,len diff --git a/module/language/assembly/disassemble.scm b/module/language/assembly/disassemble.scm index 0a35050b3..d41c8161d 100644 --- a/module/language/assembly/disassemble.scm +++ b/module/language/assembly/disassemble.scm @@ -1,6 +1,6 @@ ;;; Guile VM code converters -;; Copyright (C) 2001 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -35,12 +35,11 @@ (define (disassemble-load-program asm env) (pmatch asm - ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,code) + ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,code) (let ((objs (and env (assq-ref env 'objects))) + (free-vars (and env (assq-ref env 'free-vars))) (meta (and env (assq-ref env 'meta))) - (exts (and env (assq-ref env 'exts))) (blocs (and env (assq-ref env 'blocs))) - (bexts (and env (assq-ref env 'bexts))) (srcs (and env (assq-ref env 'sources)))) (let lp ((pos 0) (code code) (programs '())) (cond @@ -63,13 +62,13 @@ (acons sym asm programs)))) (else (print-info pos asm - (code-annotation end asm objs nargs blocs bexts + (code-annotation end asm objs nargs blocs labels) (and=> (and srcs (assq end srcs)) source->string)) (lp (+ pos (byte-length asm)) (cdr code) programs))))))) - (if (pair? exts) - (disassemble-externals exts)) + (if (pair? free-vars) + (disassemble-free-vars free-vars)) (if meta (disassemble-meta meta)) @@ -92,13 +91,12 @@ ((= n len) (newline)) (print-info n (vector-ref objs n) #f #f)))) -(define (disassemble-externals exts) - (display "Externals:\n\n") - (let ((len (length exts))) - (do ((n 0 (1+ n)) - (l exts (cdr l))) - ((null? l) (newline)) - (print-info n (car l) #f #f)))) +(define (disassemble-free-vars free-vars) + (display "Free variables:\n\n") + (let ((i 0)) + (cond ((< i (vector-length free-vars)) + (print-info i (vector-ref free-vars i) #f #f) + (lp (1+ i)))))) (define-macro (unless test . body) `(if (not ,test) (begin ,@body))) @@ -122,7 +120,7 @@ (define (make-int16 byte1 byte2) (+ (* byte1 256) byte2)) -(define (code-annotation end-addr code objs nargs blocs bexts labels) +(define (code-annotation end-addr code objs nargs blocs labels) (let* ((code (assembly-unpack code)) (inst (car code)) (args (cdr code))) @@ -133,7 +131,7 @@ (list "-> ~A" (assq-ref labels (car args)))) ((object-ref) (and objs (list "~s" (vector-ref objs (car args))))) - ((local-ref local-set) + ((local-ref local-boxed-ref local-set local-boxed-set) (and blocs (let lp ((bindings (list-ref blocs (car args)))) (and (pair? bindings) @@ -143,13 +141,9 @@ (list "`~a'~@[ (arg)~]" (binding:name b) (< (binding:index b) nargs)) (lp (cdr bindings)))))))) - ((external-ref external-set) - (and bexts - (if (< (car args) (length bexts)) - (let ((b (list-ref bexts (car args)))) - (list "`~a'~@[ (arg)~]" - (binding:name b) (< (binding:index b) nargs))) - (list "(closure variable)")))) + ((free-ref free-boxed-ref free-boxed-set) + ;; FIXME: we can do better than this + (list "(closure variable)")) ((toplevel-ref toplevel-set) (and objs (let ((v (vector-ref objs (car args)))) |