summaryrefslogtreecommitdiff
path: root/module/language/assembly
diff options
context:
space:
mode:
Diffstat (limited to 'module/language/assembly')
-rw-r--r--module/language/assembly/compile-bytecode.scm5
-rw-r--r--module/language/assembly/decompile-bytecode.scm6
-rw-r--r--module/language/assembly/disassemble.scm40
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))))