diff options
-rw-r--r-- | module/language/assembly.scm | 4 | ||||
-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 | ||||
-rw-r--r-- | module/language/glil.scm | 45 | ||||
-rw-r--r-- | module/language/glil/compile-assembly.scm | 119 | ||||
-rw-r--r-- | module/language/glil/decompile-assembly.scm | 20 | ||||
-rw-r--r-- | module/language/objcode/spec.scm | 13 | ||||
-rw-r--r-- | module/language/tree-il/compile-glil.scm | 2 | ||||
-rw-r--r-- | module/system/repl/command.scm | 1 | ||||
-rw-r--r-- | module/system/vm/frame.scm | 47 | ||||
-rw-r--r-- | module/system/vm/program.scm | 10 | ||||
-rw-r--r-- | module/system/vm/trace.scm | 5 | ||||
-rw-r--r-- | test-suite/tests/asm-to-bytecode.test | 12 | ||||
-rw-r--r-- | test-suite/tests/tree-il.test | 134 |
15 files changed, 195 insertions, 268 deletions
diff --git a/module/language/assembly.scm b/module/language/assembly.scm index 3a0b3873e..0ad94be84 100644 --- a/module/language/assembly.scm +++ b/module/language/assembly.scm @@ -28,7 +28,7 @@ assembly-pack assembly-unpack object->assembly assembly->object)) -;; nargs, nrest, nlocs, nexts, len, metalen +;; nargs, nrest, nlocs, <unused>, len, metalen (define *program-header-len* (+ 1 1 1 1 4 4)) ;; lengths are encoded in 3 bytes @@ -54,7 +54,7 @@ (+ 1 *len-len* (bytevector-length bv))) ((define ,str) (+ 1 *len-len* (string-length str))) - ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,code) + ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,code) (+ 1 *program-header-len* len (if meta (1- (byte-length meta)) 0))) ((,inst . _) (guard (>= (instruction-length inst) 0)) (+ 1 (instruction-length inst))) 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)))) diff --git a/module/language/glil.scm b/module/language/glil.scm index 4dff8178b..0777073f6 100644 --- a/module/language/glil.scm +++ b/module/language/glil.scm @@ -24,9 +24,9 @@ #:use-module ((srfi srfi-1) #:select (fold)) #:export (<glil-program> make-glil-program glil-program? - glil-program-nargs glil-program-nrest glil-program-nlocs glil-program-nexts - glil-program-meta glil-program-body glil-program-closure-level - + glil-program-nargs glil-program-nrest glil-program-nlocs + glil-program-meta glil-program-body + <glil-bind> make-glil-bind glil-bind? glil-bind-vars @@ -43,12 +43,6 @@ <glil-const> make-glil-const glil-const? glil-const-obj - <glil-local> make-glil-local glil-local? - glil-local-op glil-local-index - - <glil-external> make-glil-external glil-external? - glil-external-op glil-external-depth glil-external-index - <glil-lexical> make-glil-lexical glil-lexical? glil-lexical-local? glil-lexical-boxed? glil-lexical-op glil-lexical-index @@ -77,7 +71,7 @@ (define-type (<glil> #:printer print-glil) ;; Meta operations - (<glil-program> nargs nrest nlocs nexts meta body (closure-level #f)) + (<glil-program> nargs nrest nlocs meta body) (<glil-bind> vars) (<glil-mv-bind> vars rest) (<glil-unbind>) @@ -86,8 +80,6 @@ (<glil-void>) (<glil-const> obj) ;; Variables - (<glil-local> op index) - (<glil-external> op depth index) (<glil-lexical> local? boxed? op index) (<glil-toplevel> op name) (<glil-module> op mod name public?) @@ -97,35 +89,18 @@ (<glil-call> inst nargs) (<glil-mv-call> nargs ra)) -(define (compute-closure-level body) - (fold (lambda (x ret) - (record-case x - ((<glil-program> closure-level) (max ret closure-level)) - ((<glil-external> depth) (max ret depth)) - (else ret))) - 0 body)) - -(define %make-glil-program make-glil-program) -(define (make-glil-program . args) - (let ((prog (apply %make-glil-program args))) - (if (not (glil-program-closure-level prog)) - (set! (glil-program-closure-level prog) - (compute-closure-level (glil-program-body prog)))) - prog)) - + (define (parse-glil x) (pmatch x - ((program ,nargs ,nrest ,nlocs ,nexts ,meta . ,body) - (make-glil-program nargs nrest nlocs nexts meta (map parse-glil body))) + ((program ,nargs ,nrest ,nlocs ,meta . ,body) + (make-glil-program nargs nrest nlocs meta (map parse-glil body))) ((bind . ,vars) (make-glil-bind vars)) ((mv-bind ,vars ,rest) (make-glil-mv-bind vars rest)) ((unbind) (make-glil-unbind)) ((source ,props) (make-glil-source props)) ((void) (make-glil-void)) ((const ,obj) (make-glil-const obj)) - ((local ,op ,index) (make-glil-local op index)) - ((external ,op ,depth ,index) (make-glil-external op depth index)) ((lexical ,local? ,boxed? ,op ,index) (make-glil-lexical local? boxed? op index)) ((toplevel ,op ,name) (make-glil-toplevel op name)) ((module public ,op ,mod ,name) (make-glil-module op mod name #t)) @@ -139,8 +114,8 @@ (define (unparse-glil glil) (record-case glil ;; meta - ((<glil-program> nargs nrest nlocs nexts meta body) - `(program ,nargs ,nrest ,nlocs ,nexts ,meta ,@(map unparse-glil body))) + ((<glil-program> nargs nrest nlocs meta body) + `(program ,nargs ,nrest ,nlocs ,meta ,@(map unparse-glil body))) ((<glil-bind> vars) `(bind ,@vars)) ((<glil-mv-bind> vars rest) `(mv-bind ,vars ,rest)) ((<glil-unbind>) `(unbind)) @@ -149,8 +124,6 @@ ((<glil-void>) `(void)) ((<glil-const> obj) `(const ,obj)) ;; variables - ((<glil-external> op depth index) - `(external ,op ,depth ,index)) ((<glil-lexical> local? boxed? op index) `(lexical ,local? ,boxed? ,op ,index)) ((<glil-toplevel> op name) diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm index cecfd86b4..c7e26a825 100644 --- a/module/language/glil/compile-assembly.scm +++ b/module/language/glil/compile-assembly.scm @@ -72,7 +72,7 @@ (if (and (null? bindings) (null? sources) (null? tail)) #f (compile-assembly - (make-glil-program 0 0 0 0 '() + (make-glil-program 0 0 0 '() (list (make-glil-const `(,bindings ,sources ,@tail)) (make-glil-call 'return 1)))))) @@ -128,13 +128,13 @@ (define (compile-assembly glil) (receive (code . _) - (glil->assembly glil '() '(()) '() '() #f -1) + (glil->assembly glil #t '(()) '() '() #f -1) (car code))) (define (make-object-table objects) (and (not (null? objects)) (list->vector (cons #f objects)))) -(define (glil->assembly glil nexts-stack bindings +(define (glil->assembly glil toplevel? bindings source-alist label-alist object-alist addr) (define (emit-code x) (values (map assembly-pack x) bindings source-alist label-alist object-alist)) @@ -142,60 +142,56 @@ (values (map assembly-pack x) bindings source-alist label-alist object-alist)) (record-case glil - ((<glil-program> nargs nrest nlocs nexts meta body closure-level) - (let ((toplevel? (null? nexts-stack))) - (define (process-body) - (let ((nexts-stack (cons nexts nexts-stack))) - (let lp ((body body) (code '()) (bindings '(())) (source-alist '()) - (label-alist '()) (object-alist (if toplevel? #f '())) (addr 0)) + ((<glil-program> nargs nrest nlocs meta body) + (define (process-body) + (let lp ((body body) (code '()) (bindings '(())) (source-alist '()) + (label-alist '()) (object-alist (if toplevel? #f '())) (addr 0)) + (cond + ((null? body) + (values (reverse code) + (close-all-bindings bindings addr) + (limn-sources (reverse! source-alist)) + (reverse label-alist) + (and object-alist (map car (reverse object-alist))) + addr)) + (else + (receive (subcode bindings source-alist label-alist object-alist) + (glil->assembly (car body) #f bindings + source-alist label-alist object-alist addr) + (lp (cdr body) (append (reverse subcode) code) + bindings source-alist label-alist object-alist + (addr+ addr subcode))))))) + + (receive (code bindings sources labels objects len) + (process-body) + (let ((prog `(load-program ,nargs ,nrest ,nlocs ,labels + ,len + ,(make-meta bindings sources meta) + . ,code))) + (cond + (toplevel? + ;; toplevel bytecode isn't loaded by the vm, no way to do + ;; object table or closure capture (not in the bytecode, + ;; anyway) + (emit-code (align-program prog addr))) + (else + (let ((table (dump-object (make-object-table objects) addr))) (cond - ((null? body) - (values (reverse code) - (close-all-bindings bindings addr) - (limn-sources (reverse! source-alist)) - (reverse label-alist) - (and object-alist (map car (reverse object-alist))) - addr)) + (object-alist + ;; if we are being compiled from something with an object + ;; table, cache the program there + (receive (i object-alist) + (object-index-and-alist (make-subprogram table prog) + object-alist) + (emit-code/object `(,(if (< i 256) + `(object-ref ,i) + `(long-object-ref ,(quotient i 256) + ,(modulo i 256)))) + object-alist))) (else - (receive (subcode bindings source-alist label-alist object-alist) - (glil->assembly (car body) nexts-stack bindings - source-alist label-alist object-alist addr) - (lp (cdr body) (append (reverse subcode) code) - bindings source-alist label-alist object-alist - (addr+ addr subcode)))))))) - - (receive (code bindings sources labels objects len) - (process-body) - (let ((prog `(load-program ,nargs ,nrest ,nlocs ,nexts ,labels - ,len - ,(make-meta bindings sources meta) - . ,code))) - (cond - (toplevel? - ;; toplevel bytecode isn't loaded by the vm, no way to do - ;; object table or closure capture (not in the bytecode, - ;; anyway) - (emit-code (align-program prog addr))) - (else - (let ((table (dump-object (make-object-table objects) addr)) - (closure '())) - (cond - (object-alist - ;; if we are being compiled from something with an object - ;; table, cache the program there - (receive (i object-alist) - (object-index-and-alist (make-subprogram table prog) - object-alist) - (emit-code/object `(,(if (< i 256) - `(object-ref ,i) - `(long-object-ref ,(quotient i 256) - ,(modulo i 256))) - ,@closure) - object-alist))) - (else - ;; otherwise emit a load directly - (emit-code `(,@table ,@(align-program prog (addr+ addr table)) - ,@closure))))))))))) + ;; otherwise emit a load directly + (emit-code `(,@table ,@(align-program prog (addr+ addr table)))))))))))) + ((<glil-bind> vars) (values '() @@ -244,19 +240,6 @@ ,(modulo i 256)))) object-alist))))) - ((<glil-local> op index) - (emit-code (if (eq? op 'ref) - `((local-ref ,index)) - `((local-set ,index))))) - - ((<glil-external> op depth index) - (emit-code (let lp ((d depth) (n 0) (stack nexts-stack)) - (if (> d 0) - (lp (1- d) (+ n (car stack)) (cdr stack)) - (if (eq? op 'ref) - `((external-ref ,(+ n index))) - `((external-set ,(+ n index)))))))) - ((<glil-lexical> local? boxed? op index) (emit-code `((,(if local? diff --git a/module/language/glil/decompile-assembly.scm b/module/language/glil/decompile-assembly.scm index 502ef8034..3cb887d44 100644 --- a/module/language/glil/decompile-assembly.scm +++ b/module/language/glil/decompile-assembly.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 @@ -31,8 +31,8 @@ (define (decompile-toplevel x) (pmatch x - ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,body) - (decompile-load-program nargs nrest nlocs nexts + ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,body) + (decompile-load-program nargs nrest nlocs (decompile-meta meta) body labels #f)) (else @@ -56,7 +56,7 @@ ((glil-program? (car in)) (lp (cdr in) (cons (car in) out))) (else (lp (cdr in) (cons (make-glil-const (car l)) out)))))) -(define (decompile-load-program nargs nrest nlocs nexts meta body labels +(define (decompile-load-program nargs nrest nlocs meta body labels objects) (let ((glil-labels (sort (map (lambda (x) (cons (cdr x) (make-glil-label (car x)))) @@ -100,19 +100,11 @@ (cond ((null? in) (or (null? stack) (error "leftover stack insts" stack body)) - (make-glil-program nargs nrest nlocs nexts props (reverse out) #f)) + (make-glil-program nargs nrest nlocs props (reverse out) #f)) ((pop-bindings! pos) => (lambda (bindings) (lp in stack - (cons (make-glil-bind - (map (lambda (x) - (let ((name (binding:name x)) - (i (binding:index x))) - (cond - ((binding:extp x) `(,name external ,i)) - ((< i nargs) `(,name argument ,i)) - (else `(,name local ,(- i nargs)))))) - bindings)) + (cons (make-glil-bind bindings) out) pos))) ((pop-unbindings! pos) diff --git a/module/language/objcode/spec.scm b/module/language/objcode/spec.scm index a783a4e5e..4cb600f1d 100644 --- a/module/language/objcode/spec.scm +++ b/module/language/objcode/spec.scm @@ -66,23 +66,16 @@ ((program? x) (let ((objs (program-objects x)) (meta (program-meta x)) - (exts (program-external x)) + (free-vars (program-free-variables x)) (binds (program-bindings x)) (srcs (program-sources x)) (nargs (arity:nargs (program-arity x)))) - (let ((blocs (and binds - (collapse-locals - (append (list-head binds nargs) - (filter (lambda (x) (not (binding:extp x))) - (list-tail binds nargs)))))) - (bexts (and binds - (filter binding:extp binds)))) + (let ((blocs (and binds (collapse-locals binds)))) (values (program-objcode x) `((objects . ,objs) (meta . ,(and meta (meta))) - (exts . ,exts) + (free-vars . ,free-vars) (blocs . ,blocs) - (bexts . ,bexts) (sources . ,srcs)))))) ((objcode? x) (values x #f)) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index f8410a51d..f1d86e3f9 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -172,7 +172,7 @@ (1+ n) 1)))) (let ((nlocs (car (hashq-ref allocation x)))) (make-glil-program - nargs nrest nlocs 0 (lambda-meta x) + nargs nrest nlocs (lambda-meta x) (with-output-to-code (lambda (emit-code) ;; write bindings and source debugging info diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm index 6f45bd7f6..a99e1bae9 100644 --- a/module/system/repl/command.scm +++ b/module/system/repl/command.scm @@ -386,7 +386,6 @@ Trace execution. -s Display stack -l Display local variables - -e Display external variables -b Bytecode level trace" (apply vm-trace (repl-vm repl) (repl-compile repl (repl-parse repl form)) diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm index 33a1e1b60..332cd6172 100644 --- a/module/system/vm/frame.scm +++ b/module/system/vm/frame.scm @@ -1,6 +1,6 @@ ;;; Guile VM frame functions -;;; Copyright (C) 2001 Free Software Foundation, Inc. +;;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. ;;; Copyright (C) 2005 Ludovic Courtès <ludovic.courtes@laas.fr> ;;; ;;; This program is free software; you can redistribute it and/or modify @@ -27,20 +27,20 @@ vm-frame-program vm-frame-local-ref vm-frame-local-set! vm-frame-return-address vm-frame-mv-return-address - vm-frame-dynamic-link vm-frame-external-link + vm-frame-dynamic-link vm-frame-stack vm-frame-number vm-frame-address - make-frame-chain - print-frame print-frame-chain-as-backtrace - frame-arguments frame-local-variables frame-external-variables - frame-environment - frame-variable-exists? frame-variable-ref frame-variable-set! - frame-object-name - frame-local-ref frame-external-link frame-local-set! - frame-return-address frame-program - frame-dynamic-link heap-frame?)) + make-frame-chain + print-frame print-frame-chain-as-backtrace + frame-arguments frame-local-variables + frame-environment + frame-variable-exists? frame-variable-ref frame-variable-set! + frame-object-name + frame-local-ref frame-local-set! + frame-return-address frame-program + frame-dynamic-link heap-frame?)) (load-extension "libguile" "scm_init_frames") @@ -158,24 +158,19 @@ (l '() (cons (frame-local-ref frame n) l))) ((< n 0) l)))) -(define (frame-external-variables frame) - (frame-external-link frame)) - -(define (frame-external-ref frame index) - (list-ref (frame-external-link frame) index)) - -(define (frame-external-set! frame index val) - (list-set! (frame-external-link frame) index val)) - (define (frame-binding-ref frame binding) - (if (binding:extp binding) - (frame-external-ref frame (binding:index binding)) - (frame-local-ref frame (binding:index binding)))) + (let ((x (frame-local-ref frame (binding:index binding)))) + (if (and (binding:boxed? binding) (variable? x)) + (variable-ref x) + x))) (define (frame-binding-set! frame binding val) - (if (binding:extp binding) - (frame-external-set! frame (binding:index binding) val) - (frame-local-set! frame (binding:index binding) val))) + (if (binding:boxed? binding) + (let ((v (frame-local-ref frame binding))) + (if (variable? v) + (variable-set! v val) + (frame-local-set! frame binding (make-variable val)))) + (frame-local-set! frame binding val))) ;; FIXME handle #f program-bindings return (define (frame-bindings frame addr) diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm index 5fd81b4a6..755c606e2 100644 --- a/module/system/vm/program.scm +++ b/module/system/vm/program.scm @@ -21,9 +21,9 @@ (define-module (system vm program) #:export (make-program - arity:nargs arity:nrest arity:nlocs arity:nexts + arity:nargs arity:nrest arity:nlocs - make-binding binding:name binding:extp binding:index + make-binding binding:name binding:boxed? binding:index binding:start binding:end source:addr source:line source:column source:file @@ -41,10 +41,10 @@ (define arity:nrest cadr) (define arity:nlocs caddr) -(define (make-binding name extp index start end) - (list name extp index start end)) +(define (make-binding name boxed? index start end) + (list name boxed? index start end)) (define (binding:name b) (list-ref b 0)) -(define (binding:extp b) (list-ref b 1)) +(define (binding:boxed? b) (list-ref b 1)) (define (binding:index b) (list-ref b 2)) (define (binding:start b) (list-ref b 3)) (define (binding:end b) (list-ref b 4)) diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm index 6ff09a779..d8165f202 100644 --- a/module/system/vm/trace.scm +++ b/module/system/vm/trace.scm @@ -1,6 +1,6 @@ ;;; Guile VM tracer -;; 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 @@ -54,8 +54,7 @@ ((null? opts) (newline)) (case (car opts) ((:s) (puts (truncate! (vm-fetch-stack vm) 3))) - ((:l) (puts (vm-fetch-locals vm))) - ((:e) (puts (vm-fetch-externals vm)))))) + ((:l) (puts (vm-fetch-locals vm)))))) (define (trace-apply vm) (if (vm-option vm 'trace-first) diff --git a/test-suite/tests/asm-to-bytecode.test b/test-suite/tests/asm-to-bytecode.test index 01ba84687..d819a3b1b 100644 --- a/test-suite/tests/asm-to-bytecode.test +++ b/test-suite/tests/asm-to-bytecode.test @@ -85,28 +85,28 @@ (vector 'load-keyword 0 0 3 (char->integer #\q) (char->integer #\u) (char->integer #\x))) - (comp-test '(load-program 3 2 1 0 () 3 #f (make-int8 3) (return)) + (comp-test '(load-program 3 2 1 () 3 #f (make-int8 3) (return)) (list->vector `(load-program - 3 2 1 0 ;; nargs, nrest, nlocs, nexts + 3 2 1 0 ;; nargs, nrest, nlocs, unused ,@(u32->u8-list 3) ;; len ,@(u32->u8-list 0) ;; metalen make-int8 3 return))) - (comp-test '(load-program 3 2 1 0 () 3 - (load-program 3 2 1 0 () 3 + (comp-test '(load-program 3 2 1 () 3 + (load-program 3 2 1 () 3 #f (make-int8 3) (return)) (make-int8 3) (return)) (list->vector `(load-program - 3 2 1 0 ;; nargs, nrest, nlocs, nexts + 3 2 1 0 ;; nargs, nrest, nlocs, unused ,@(u32->u8-list 3) ;; len ,@(u32->u8-list (+ 3 12)) ;; metalen make-int8 3 return - 3 2 1 0 ;; nargs, nrest, nlocs, nexts + 3 2 1 0 ;; nargs, nrest, nlocs, unused ,@(u32->u8-list 3) ;; len ,@(u32->u8-list 0) ;; metalen make-int8 3 diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index e4979c15d..6634dcdd7 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -64,21 +64,21 @@ (with-test-prefix "void" (assert-tree-il->glil (void) - (program 0 0 0 0 () (void) (call return 1))) + (program 0 0 0 () (void) (call return 1))) (assert-tree-il->glil (begin (void) (const 1)) - (program 0 0 0 0 () (const 1) (call return 1))) + (program 0 0 0 () (const 1) (call return 1))) (assert-tree-il->glil (apply (primitive +) (void) (const 1)) - (program 0 0 0 0 () (void) (const 1) (call add 2) (call return 1)))) + (program 0 0 0 () (void) (const 1) (call add 2) (call return 1)))) (with-test-prefix "application" (assert-tree-il->glil (apply (toplevel foo) (const 1)) - (program 0 0 0 0 () (toplevel ref foo) (const 1) (call goto/args 1))) + (program 0 0 0 () (toplevel ref foo) (const 1) (call goto/args 1))) (assert-tree-il->glil/pmatch (begin (apply (toplevel foo) (const 1)) (void)) - (program 0 0 0 0 () (toplevel ref foo) (const 1) (mv-call 1 ,l1) + (program 0 0 0 () (toplevel ref foo) (const 1) (mv-call 1 ,l1) (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind) (label ,l4) @@ -86,26 +86,26 @@ (and (eq? l1 l3) (eq? l2 l4))) (assert-tree-il->glil (apply (toplevel foo) (apply (toplevel bar))) - (program 0 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call call 0) + (program 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call call 0) (call goto/args 1)))) (with-test-prefix "conditional" (assert-tree-il->glil/pmatch (if (const #t) (const 1) (const 2)) - (program 0 0 0 0 () (const #t) (branch br-if-not ,l1) + (program 0 0 0 () (const #t) (branch br-if-not ,l1) (const 1) (call return 1) (label ,l2) (const 2) (call return 1)) (eq? l1 l2)) (assert-tree-il->glil/pmatch (begin (if (const #t) (const 1) (const 2)) (const #f)) - (program 0 0 0 0 () (const #t) (branch br-if-not ,l1) (branch br ,l2) + (program 0 0 0 () (const #t) (branch br-if-not ,l1) (branch br ,l2) (label ,l3) (label ,l4) (const #f) (call return 1)) (eq? l1 l3) (eq? l2 l4)) (assert-tree-il->glil/pmatch (apply (primitive null?) (if (const #t) (const 1) (const 2))) - (program 0 0 0 0 () (const #t) (branch br-if-not ,l1) + (program 0 0 0 () (const #t) (branch br-if-not ,l1) (const 1) (branch br ,l2) (label ,l3) (const 2) (label ,l4) (call null? 1) (call return 1)) @@ -114,35 +114,35 @@ (with-test-prefix "primitive-ref" (assert-tree-il->glil (primitive +) - (program 0 0 0 0 () (toplevel ref +) (call return 1))) + (program 0 0 0 () (toplevel ref +) (call return 1))) (assert-tree-il->glil (begin (primitive +) (const #f)) - (program 0 0 0 0 () (const #f) (call return 1))) + (program 0 0 0 () (const #f) (call return 1))) (assert-tree-il->glil (apply (primitive null?) (primitive +)) - (program 0 0 0 0 () (toplevel ref +) (call null? 1) + (program 0 0 0 () (toplevel ref +) (call null? 1) (call return 1)))) (with-test-prefix "lexical refs" (assert-tree-il->glil (let (x) (y) ((const 1)) (lexical x y)) - (program 0 0 1 0 () + (program 0 0 1 () (const 1) (bind (x #f 0)) (lexical #t #f set 0) (lexical #t #f ref 0) (call return 1) (unbind))) (assert-tree-il->glil (let (x) (y) ((const 1)) (begin (lexical x y) (const #f))) - (program 0 0 1 0 () + (program 0 0 1 () (const 1) (bind (x #f 0)) (lexical #t #f set 0) (const #f) (call return 1) (unbind))) (assert-tree-il->glil (let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y))) - (program 0 0 1 0 () + (program 0 0 1 () (const 1) (bind (x #f 0)) (lexical #t #f set 0) (lexical #t #f ref 0) (call null? 1) (call return 1) (unbind)))) @@ -150,14 +150,14 @@ (with-test-prefix "lexical sets" (assert-tree-il->glil (let (x) (y) ((const 1)) (set! (lexical x y) (const 2))) - (program 0 0 1 0 () + (program 0 0 1 () (const 1) (bind (x #t 0)) (lexical #t #t box 0) (const 2) (lexical #t #t set 0) (void) (call return 1) (unbind))) (assert-tree-il->glil (let (x) (y) ((const 1)) (begin (set! (lexical x y) (const 2)) (const #f))) - (program 0 0 1 0 () + (program 0 0 1 () (const 1) (bind (x #t 0)) (lexical #t #t box 0) (const 2) (lexical #t #t set 0) (const #f) (call return 1) (unbind))) @@ -165,7 +165,7 @@ (assert-tree-il->glil (let (x) (y) ((const 1)) (apply (primitive null?) (set! (lexical x y) (const 2)))) - (program 0 0 1 0 () + (program 0 0 1 () (const 1) (bind (x #t 0)) (lexical #t #t box 0) (const 2) (lexical #t #t set 0) (void) (call null? 1) (call return 1) (unbind)))) @@ -173,205 +173,205 @@ (with-test-prefix "module refs" (assert-tree-il->glil (@ (foo) bar) - (program 0 0 0 0 () + (program 0 0 0 () (module public ref (foo) bar) (call return 1))) (assert-tree-il->glil (begin (@ (foo) bar) (const #f)) - (program 0 0 0 0 () + (program 0 0 0 () (module public ref (foo) bar) (call drop 1) (const #f) (call return 1))) (assert-tree-il->glil (apply (primitive null?) (@ (foo) bar)) - (program 0 0 0 0 () + (program 0 0 0 () (module public ref (foo) bar) (call null? 1) (call return 1))) (assert-tree-il->glil (@@ (foo) bar) - (program 0 0 0 0 () + (program 0 0 0 () (module private ref (foo) bar) (call return 1))) (assert-tree-il->glil (begin (@@ (foo) bar) (const #f)) - (program 0 0 0 0 () + (program 0 0 0 () (module private ref (foo) bar) (call drop 1) (const #f) (call return 1))) (assert-tree-il->glil (apply (primitive null?) (@@ (foo) bar)) - (program 0 0 0 0 () + (program 0 0 0 () (module private ref (foo) bar) (call null? 1) (call return 1)))) (with-test-prefix "module sets" (assert-tree-il->glil (set! (@ (foo) bar) (const 2)) - (program 0 0 0 0 () + (program 0 0 0 () (const 2) (module public set (foo) bar) (void) (call return 1))) (assert-tree-il->glil (begin (set! (@ (foo) bar) (const 2)) (const #f)) - (program 0 0 0 0 () + (program 0 0 0 () (const 2) (module public set (foo) bar) (const #f) (call return 1))) (assert-tree-il->glil (apply (primitive null?) (set! (@ (foo) bar) (const 2))) - (program 0 0 0 0 () + (program 0 0 0 () (const 2) (module public set (foo) bar) (void) (call null? 1) (call return 1))) (assert-tree-il->glil (set! (@@ (foo) bar) (const 2)) - (program 0 0 0 0 () + (program 0 0 0 () (const 2) (module private set (foo) bar) (void) (call return 1))) (assert-tree-il->glil (begin (set! (@@ (foo) bar) (const 2)) (const #f)) - (program 0 0 0 0 () + (program 0 0 0 () (const 2) (module private set (foo) bar) (const #f) (call return 1))) (assert-tree-il->glil (apply (primitive null?) (set! (@@ (foo) bar) (const 2))) - (program 0 0 0 0 () + (program 0 0 0 () (const 2) (module private set (foo) bar) (void) (call null? 1) (call return 1)))) (with-test-prefix "toplevel refs" (assert-tree-il->glil (toplevel bar) - (program 0 0 0 0 () + (program 0 0 0 () (toplevel ref bar) (call return 1))) (assert-tree-il->glil (begin (toplevel bar) (const #f)) - (program 0 0 0 0 () + (program 0 0 0 () (toplevel ref bar) (call drop 1) (const #f) (call return 1))) (assert-tree-il->glil (apply (primitive null?) (toplevel bar)) - (program 0 0 0 0 () + (program 0 0 0 () (toplevel ref bar) (call null? 1) (call return 1)))) (with-test-prefix "toplevel sets" (assert-tree-il->glil (set! (toplevel bar) (const 2)) - (program 0 0 0 0 () + (program 0 0 0 () (const 2) (toplevel set bar) (void) (call return 1))) (assert-tree-il->glil (begin (set! (toplevel bar) (const 2)) (const #f)) - (program 0 0 0 0 () + (program 0 0 0 () (const 2) (toplevel set bar) (const #f) (call return 1))) (assert-tree-il->glil (apply (primitive null?) (set! (toplevel bar) (const 2))) - (program 0 0 0 0 () + (program 0 0 0 () (const 2) (toplevel set bar) (void) (call null? 1) (call return 1)))) (with-test-prefix "toplevel defines" (assert-tree-il->glil (define bar (const 2)) - (program 0 0 0 0 () + (program 0 0 0 () (const 2) (toplevel define bar) (void) (call return 1))) (assert-tree-il->glil (begin (define bar (const 2)) (const #f)) - (program 0 0 0 0 () + (program 0 0 0 () (const 2) (toplevel define bar) (const #f) (call return 1))) (assert-tree-il->glil (apply (primitive null?) (define bar (const 2))) - (program 0 0 0 0 () + (program 0 0 0 () (const 2) (toplevel define bar) (void) (call null? 1) (call return 1)))) (with-test-prefix "constants" (assert-tree-il->glil (const 2) - (program 0 0 0 0 () + (program 0 0 0 () (const 2) (call return 1))) (assert-tree-il->glil (begin (const 2) (const #f)) - (program 0 0 0 0 () + (program 0 0 0 () (const #f) (call return 1))) (assert-tree-il->glil (apply (primitive null?) (const 2)) - (program 0 0 0 0 () + (program 0 0 0 () (const 2) (call null? 1) (call return 1)))) (with-test-prefix "lambda" (assert-tree-il->glil (lambda (x) (y) () (const 2)) - (program 0 0 0 0 () - (program 1 0 0 0 () + (program 0 0 0 () + (program 1 0 0 () (bind (x #f 0)) (const 2) (call return 1)) (call return 1))) (assert-tree-il->glil (lambda (x x1) (y y1) () (const 2)) - (program 0 0 0 0 () - (program 2 0 0 0 () + (program 0 0 0 () + (program 2 0 0 () (bind (x #f 0) (x1 #f 1)) (const 2) (call return 1)) (call return 1))) (assert-tree-il->glil (lambda x y () (const 2)) - (program 0 0 0 0 () - (program 1 1 0 0 () + (program 0 0 0 () + (program 1 1 0 () (bind (x #f 0)) (const 2) (call return 1)) (call return 1))) (assert-tree-il->glil (lambda (x . x1) (y . y1) () (const 2)) - (program 0 0 0 0 () - (program 2 1 0 0 () + (program 0 0 0 () + (program 2 1 0 () (bind (x #f 0) (x1 #f 1)) (const 2) (call return 1)) (call return 1))) (assert-tree-il->glil (lambda (x . x1) (y . y1) () (lexical x y)) - (program 0 0 0 0 () - (program 2 1 0 0 () + (program 0 0 0 () + (program 2 1 0 () (bind (x #f 0) (x1 #f 1)) (lexical #t #f ref 0) (call return 1)) (call return 1))) (assert-tree-il->glil (lambda (x . x1) (y . y1) () (lexical x1 y1)) - (program 0 0 0 0 () - (program 2 1 0 0 () + (program 0 0 0 () + (program 2 1 0 () (bind (x #f 0) (x1 #f 1)) (lexical #t #f ref 1) (call return 1)) (call return 1))) (assert-tree-il->glil (lambda (x) (x1) () (lambda (y) (y1) () (lexical x x1))) - (program 0 0 0 0 () - (program 1 0 0 0 () + (program 0 0 0 () + (program 1 0 0 () (bind (x #f 0)) - (program 1 0 0 0 () + (program 1 0 0 () (bind (y #f 0)) (lexical #f #f ref 0) (call return 1)) (lexical #t #f ref 0) @@ -383,12 +383,12 @@ (with-test-prefix "sequence" (assert-tree-il->glil (begin (begin (const 2) (const #f)) (const #t)) - (program 0 0 0 0 () + (program 0 0 0 () (const #t) (call return 1))) (assert-tree-il->glil (apply (primitive null?) (begin (const #f) (const 2))) - (program 0 0 0 0 () + (program 0 0 0 () (const 2) (call null? 1) (call return 1)))) ;; FIXME: binding info for or-hacked locals might bork the disassembler, @@ -400,7 +400,7 @@ (lexical x y) (let (a) (b) ((const 2)) (lexical a b)))) - (program 0 0 1 0 () + (program 0 0 1 () (const 1) (bind (x #f 0)) (lexical #t #f set 0) (lexical #t #f ref 0) (branch br-if-not ,l1) (lexical #t #f ref 0) (call return 1) @@ -417,7 +417,7 @@ (lexical x y) (let (a) (b) ((const 2)) (lexical x y)))) - (program 0 0 2 0 () + (program 0 0 2 () (const 1) (bind (x #f 0)) (lexical #t #f set 0) (lexical #t #f ref 0) (branch br-if-not ,l1) (lexical #t #f ref 0) (call return 1) @@ -431,10 +431,10 @@ (with-test-prefix "apply" (assert-tree-il->glil (apply (primitive @apply) (toplevel foo) (toplevel bar)) - (program 0 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call goto/apply 2))) + (program 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call goto/apply 2))) (assert-tree-il->glil/pmatch (begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void)) - (program 0 0 0 0 () + (program 0 0 0 () (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1) (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind) (label ,l4) @@ -442,7 +442,7 @@ (and (eq? l1 l3) (eq? l2 l4))) (assert-tree-il->glil (apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz))) - (program 0 0 0 0 () + (program 0 0 0 () (toplevel ref foo) (toplevel ref bar) (toplevel ref baz) (call apply 2) (call goto/args 1)))) @@ -450,10 +450,10 @@ (with-test-prefix "call/cc" (assert-tree-il->glil (apply (primitive @call-with-current-continuation) (toplevel foo)) - (program 0 0 0 0 () (toplevel ref foo) (call goto/cc 1))) + (program 0 0 0 () (toplevel ref foo) (call goto/cc 1))) (assert-tree-il->glil/pmatch (begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void)) - (program 0 0 0 0 () + (program 0 0 0 () (toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1) (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind) (label ,l4) @@ -462,7 +462,7 @@ (assert-tree-il->glil (apply (toplevel foo) (apply (toplevel @call-with-current-continuation) (toplevel bar))) - (program 0 0 0 0 () + (program 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call call/cc 1) (call goto/args 1)))) |