mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-18 17:50:29 +02:00
Code Activity

remove all mentions of "external" from the compiler and related code

Browse source 
With this, GHIL is effectively bitrotten. I need to port the ECMAScript
compiler to tree-il, then I'll remove it.

* module/language/assembly.scm (byte-length):
* module/language/assembly/compile-bytecode.scm (write-bytecode):
* module/language/assembly/decompile-bytecode.scm (decode-load-program):
* module/language/assembly/disassemble.scm (disassemble-load-program):
  (disassemble-free-vars, code-annotation):
* module/language/glil.scm (<glil-program>, <glil-local>)
  (<glil-exteral>, parse-glil, unparse-glil):
* module/language/glil/compile-assembly.scm (make-meta):
  (compile-assembly, glil->assembly):
* module/language/glil/decompile-assembly.scm (decompile-toplevel):
  (decompile-load-program):
* module/language/objcode/spec.scm (decompile-value):
* module/language/tree-il/compile-glil.scm (flatten-lambda):
* module/system/vm/frame.scm (frame-binding-ref):
  (frame-binding-set!):
* module/system/vm/program.scm (binding:boxed?):
* module/system/vm/trace.scm (trace-next):
* test-suite/tests/asm-to-bytecode.test ("compiler"):
* test-suite/tests/tree-il.test: Remove all mentions of "external", and
  of <glil-local>. Docs updates will come soon.
This commit is contained in:
Andy Wingo 2009-07-23 16:50:47 +02:00
parent 57ab0671d7
commit 476e357281
15 changed files with 196 additions and 269 deletions
Download patch file Download diff file Expand all files Collapse all files

4
module/language/assembly.scm
View file

@ -28,7 +28,7 @@
assembly-pack assembly-unpack assembly-pack assembly-unpack
object->assembly assembly->object)) 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)) (define *program-header-len* (+ 1 1 1 1 4 4))
;; lengths are encoded in 3 bytes ;; lengths are encoded in 3 bytes
@ -54,7 +54,7 @@
(+ 1 *len-len* (bytevector-length bv))) (+ 1 *len-len* (bytevector-length bv)))
((define ,str) ((define ,str)
(+ 1 *len-len* (string-length 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))) (+ 1 *program-header-len* len (if meta (1- (byte-length meta)) 0)))
((,inst . _) (guard (>= (instruction-length inst) 0)) ((,inst . _) (guard (>= (instruction-length inst) 0))
(+ 1 (instruction-length inst))) (+ 1 (instruction-length inst)))

5
module/language/assembly/compile-bytecode.scm
View file

@ -89,12 +89,11 @@
(len (instruction-length inst))) (len (instruction-length inst)))
(write-byte opcode) (write-byte opcode)
(pmatch asm (pmatch asm
((load-program ,nargs ,nrest ,nlocs ,nexts ((load-program ,nargs ,nrest ,nlocs ,labels ,length ,meta . ,code)
,labels ,length ,meta . ,code)
(write-byte nargs) (write-byte nargs)
(write-byte nrest) (write-byte nrest)
(write-byte nlocs) (write-byte nlocs)
(write-byte nexts) (write-byte 0) ;; what used to be nexts
(write-uint32 length) (write-uint32 length)
(write-uint32 (if meta (1- (byte-length meta)) 0)) (write-uint32 (if meta (1- (byte-length meta)) 0))
(letrec ((i 0) (letrec ((i 0)

6
module/language/assembly/decompile-bytecode.scm
View file

@ -1,6 +1,6 @@
;;; Guile VM code converters ;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -49,7 +49,7 @@
(- x (ash 1 16))))) (- x (ash 1 16)))))
(define (decode-load-program pop) (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)) (a (pop)) (b (pop)) (c (pop)) (d (pop))
(e (pop)) (f (pop)) (g (pop)) (h (pop)) (e (pop)) (f (pop)) (g (pop)) (h (pop))
(len (+ a (ash b 8) (ash c 16) (ash d 24))) (len (+ a (ash b 8) (ash c 16) (ash d 24)))
@ -74,7 +74,7 @@
(cond ((> i len) (cond ((> i len)
(error "error decoding program -- read too many bytes" out)) (error "error decoding program -- read too many bytes" out))
((= i len) ((= i len)
`(load-program ,nargs ,nrest ,nlocs ,nexts `(load-program ,nargs ,nrest ,nlocs
,(map (lambda (x) (cons (cdr x) (car x))) ,(map (lambda (x) (cons (cdr x) (car x)))
(reverse labels)) (reverse labels))
,len ,len

40
module/language/assembly/disassemble.scm
View file

@ -1,6 +1,6 @@
;;; Guile VM code converters ;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -35,12 +35,11 @@
(define (disassemble-load-program asm env) (define (disassemble-load-program asm env)
(pmatch asm (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))) (let ((objs (and env (assq-ref env 'objects)))
(free-vars (and env (assq-ref env 'free-vars)))
(meta (and env (assq-ref env 'meta))) (meta (and env (assq-ref env 'meta)))
(exts (and env (assq-ref env 'exts)))
(blocs (and env (assq-ref env 'blocs))) (blocs (and env (assq-ref env 'blocs)))
(bexts (and env (assq-ref env 'bexts)))
(srcs (and env (assq-ref env 'sources)))) (srcs (and env (assq-ref env 'sources))))
(let lp ((pos 0) (code code) (programs '())) (let lp ((pos 0) (code code) (programs '()))
(cond (cond
@ -63,13 +62,13 @@
(acons sym asm programs)))) (acons sym asm programs))))
(else (else
(print-info pos asm (print-info pos asm
(code-annotation end asm objs nargs blocs bexts (code-annotation end asm objs nargs blocs
labels) labels)
(and=> (and srcs (assq end srcs)) source->string)) (and=> (and srcs (assq end srcs)) source->string))
(lp (+ pos (byte-length asm)) (cdr code) programs))))))) (lp (+ pos (byte-length asm)) (cdr code) programs)))))))
(if (pair? exts) (if (pair? free-vars)
(disassemble-externals exts)) (disassemble-free-vars free-vars))
(if meta (if meta
(disassemble-meta meta)) (disassemble-meta meta))
@ -92,13 +91,12 @@
((= n len) (newline)) ((= n len) (newline))
(print-info n (vector-ref objs n) #f #f)))) (print-info n (vector-ref objs n) #f #f))))
(define (disassemble-externals exts) (define (disassemble-free-vars free-vars)
(display "Externals:\n\n") (display "Free variables:\n\n")
(let ((len (length exts))) (let ((i 0))
(do ((n 0 (1+ n)) (cond ((< i (vector-length free-vars))
(l exts (cdr l))) (print-info i (vector-ref free-vars i) #f #f)
((null? l) (newline)) (lp (1+ i))))))
(print-info n (car l) #f #f))))
(define-macro (unless test . body) (define-macro (unless test . body)
`(if (not ,test) (begin ,@body))) `(if (not ,test) (begin ,@body)))
@ -122,7 +120,7 @@
(define (make-int16 byte1 byte2) (define (make-int16 byte1 byte2)
(+ (* byte1 256) 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)) (let* ((code (assembly-unpack code))
(inst (car code)) (inst (car code))
(args (cdr code))) (args (cdr code)))
@ -133,7 +131,7 @@
(list "-> ~A" (assq-ref labels (car args)))) (list "-> ~A" (assq-ref labels (car args))))
((object-ref) ((object-ref)
(and objs (list "~s" (vector-ref objs (car args))))) (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 (and blocs
(let lp ((bindings (list-ref blocs (car args)))) (let lp ((bindings (list-ref blocs (car args))))
(and (pair? bindings) (and (pair? bindings)
@ -143,13 +141,9 @@
(list "`~a'~@[ (arg)~]" (list "`~a'~@[ (arg)~]"
(binding:name b) (< (binding:index b) nargs)) (binding:name b) (< (binding:index b) nargs))
(lp (cdr bindings)))))))) (lp (cdr bindings))))))))
((external-ref external-set) ((free-ref free-boxed-ref free-boxed-set)
(and bexts ;; FIXME: we can do better than this
(if (< (car args) (length bexts)) (list "(closure variable)"))
(let ((b (list-ref bexts (car args))))
(list "`~a'~@[ (arg)~]"
(binding:name b) (< (binding:index b) nargs)))
(list "(closure variable)"))))
((toplevel-ref toplevel-set) ((toplevel-ref toplevel-set)
(and objs (and objs
(let ((v (vector-ref objs (car args)))) (let ((v (vector-ref objs (car args))))

43
module/language/glil.scm
View file

@ -24,8 +24,8 @@
#:use-module ((srfi srfi-1) #:select (fold)) #:use-module ((srfi srfi-1) #:select (fold))
#:export #:export
(<glil-program> make-glil-program glil-program? (<glil-program> make-glil-program glil-program?
glil-program-nargs glil-program-nrest glil-program-nlocs glil-program-nexts glil-program-nargs glil-program-nrest glil-program-nlocs
glil-program-meta glil-program-body glil-program-closure-level glil-program-meta glil-program-body
<glil-bind> make-glil-bind glil-bind? <glil-bind> make-glil-bind glil-bind?
glil-bind-vars glil-bind-vars
@ -43,12 +43,6 @@
<glil-const> make-glil-const glil-const? <glil-const> make-glil-const glil-const?
glil-const-obj 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> make-glil-lexical glil-lexical?
glil-lexical-local? glil-lexical-boxed? glil-lexical-op glil-lexical-index glil-lexical-local? glil-lexical-boxed? glil-lexical-op glil-lexical-index
@ -77,7 +71,7 @@
(define-type (<glil> #:printer print-glil) (define-type (<glil> #:printer print-glil)
;; Meta operations ;; Meta operations
(<glil-program> nargs nrest nlocs nexts meta body (closure-level #f)) (<glil-program> nargs nrest nlocs meta body)
(<glil-bind> vars) (<glil-bind> vars)
(<glil-mv-bind> vars rest) (<glil-mv-bind> vars rest)
(<glil-unbind>) (<glil-unbind>)
@ -86,8 +80,6 @@
(<glil-void>) (<glil-void>)
(<glil-const> obj) (<glil-const> obj)
;; Variables ;; Variables
(<glil-local> op index)
(<glil-external> op depth index)
(<glil-lexical> local? boxed? op index) (<glil-lexical> local? boxed? op index)
(<glil-toplevel> op name) (<glil-toplevel> op name)
(<glil-module> op mod name public?) (<glil-module> op mod name public?)
@ -97,35 +89,18 @@
(<glil-call> inst nargs) (<glil-call> inst nargs)
(<glil-mv-call> nargs ra)) (<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) (define (parse-glil x)
(pmatch x (pmatch x
((program ,nargs ,nrest ,nlocs ,nexts ,meta . ,body) ((program ,nargs ,nrest ,nlocs ,meta . ,body)
(make-glil-program nargs nrest nlocs nexts meta (map parse-glil body))) (make-glil-program nargs nrest nlocs meta (map parse-glil body)))
((bind . ,vars) (make-glil-bind vars)) ((bind . ,vars) (make-glil-bind vars))
((mv-bind ,vars ,rest) (make-glil-mv-bind vars rest)) ((mv-bind ,vars ,rest) (make-glil-mv-bind vars rest))
((unbind) (make-glil-unbind)) ((unbind) (make-glil-unbind))
((source ,props) (make-glil-source props)) ((source ,props) (make-glil-source props))
((void) (make-glil-void)) ((void) (make-glil-void))
((const ,obj) (make-glil-const obj)) ((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)) ((lexical ,local? ,boxed? ,op ,index) (make-glil-lexical local? boxed? op index))
((toplevel ,op ,name) (make-glil-toplevel op name)) ((toplevel ,op ,name) (make-glil-toplevel op name))
((module public ,op ,mod ,name) (make-glil-module op mod name #t)) ((module public ,op ,mod ,name) (make-glil-module op mod name #t))
@ -139,8 +114,8 @@
(define (unparse-glil glil) (define (unparse-glil glil)
(record-case glil (record-case glil
;; meta ;; meta
((<glil-program> nargs nrest nlocs nexts meta body) ((<glil-program> nargs nrest nlocs meta body)
`(program ,nargs ,nrest ,nlocs ,nexts ,meta ,@(map unparse-glil body))) `(program ,nargs ,nrest ,nlocs ,meta ,@(map unparse-glil body)))
((<glil-bind> vars) `(bind ,@vars)) ((<glil-bind> vars) `(bind ,@vars))
((<glil-mv-bind> vars rest) `(mv-bind ,vars ,rest)) ((<glil-mv-bind> vars rest) `(mv-bind ,vars ,rest))
((<glil-unbind>) `(unbind)) ((<glil-unbind>) `(unbind))
@ -149,8 +124,6 @@
((<glil-void>) `(void)) ((<glil-void>) `(void))
((<glil-const> obj) `(const ,obj)) ((<glil-const> obj) `(const ,obj))
;; variables ;; variables
((<glil-external> op depth index)
`(external ,op ,depth ,index))
((<glil-lexical> local? boxed? op index) ((<glil-lexical> local? boxed? op index)
`(lexical ,local? ,boxed? ,op ,index)) `(lexical ,local? ,boxed? ,op ,index))
((<glil-toplevel> op name) ((<glil-toplevel> op name)

121
module/language/glil/compile-assembly.scm
View file

@ -72,7 +72,7 @@
(if (and (null? bindings) (null? sources) (null? tail)) (if (and (null? bindings) (null? sources) (null? tail))
#f #f
(compile-assembly (compile-assembly
(make-glil-program 0 0 0 0 '() (make-glil-program 0 0 0 '()
(list (list
(make-glil-const `(,bindings ,sources ,@tail)) (make-glil-const `(,bindings ,sources ,@tail))
(make-glil-call 'return 1)))))) (make-glil-call 'return 1))))))
@ -128,13 +128,13 @@
(define (compile-assembly glil) (define (compile-assembly glil)
(receive (code . _) (receive (code . _)
(glil->assembly glil '() '(()) '() '() #f -1) (glil->assembly glil #t '(()) '() '() #f -1)
(car code))) (car code)))
(define (make-object-table objects) (define (make-object-table objects)
(and (not (null? objects)) (and (not (null? objects))
(list->vector (cons #f 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) source-alist label-alist object-alist addr)
(define (emit-code x) (define (emit-code x)
(values (map assembly-pack x) bindings source-alist label-alist object-alist)) (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)) (values (map assembly-pack x) bindings source-alist label-alist object-alist))
(record-case glil (record-case glil
((<glil-program> nargs nrest nlocs nexts meta body closure-level) ((<glil-program> nargs nrest nlocs meta body)
(let ((toplevel? (null? nexts-stack))) (define (process-body)
(define (process-body) (let lp ((body body) (code '()) (bindings '(())) (source-alist '())
(let ((nexts-stack (cons nexts nexts-stack))) (label-alist '()) (object-alist (if toplevel? #f '())) (addr 0))
(let lp ((body body) (code '()) (bindings '(())) (source-alist '()) (cond
(label-alist '()) (object-alist (if toplevel? #f '())) (addr 0)) ((null? body)
(cond (values (reverse code)
((null? body) (close-all-bindings bindings addr)
(values (reverse code) (limn-sources (reverse! source-alist))
(close-all-bindings bindings addr) (reverse label-alist)
(limn-sources (reverse! source-alist)) (and object-alist (map car (reverse object-alist)))
(reverse label-alist) addr))
(and object-alist (map car (reverse object-alist))) (else
addr)) (receive (subcode bindings source-alist label-alist object-alist)
(else (glil->assembly (car body) #f bindings
(receive (subcode bindings source-alist label-alist object-alist) source-alist label-alist object-alist addr)
(glil->assembly (car body) nexts-stack bindings (lp (cdr body) (append (reverse subcode) code)
source-alist label-alist object-alist addr) bindings source-alist label-alist object-alist
(lp (cdr body) (append (reverse subcode) code) (addr+ addr subcode)))))))
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
(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
;; otherwise emit a load directly
(emit-code `(,@table ,@(align-program prog (addr+ addr table))))))))))))
(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)))))))))))
((<glil-bind> vars) ((<glil-bind> vars)
(values '() (values '()
@ -244,19 +240,6 @@
,(modulo i 256)))) ,(modulo i 256))))
object-alist))))) 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) ((<glil-lexical> local? boxed? op index)
(emit-code (emit-code
`((,(if local? `((,(if local?

20
module/language/glil/decompile-assembly.scm
View file

@ -1,6 +1,6 @@
;;; Guile VM code converters ;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -31,8 +31,8 @@
(define (decompile-toplevel x) (define (decompile-toplevel x)
(pmatch x (pmatch x
((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,body) ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,body)
(decompile-load-program nargs nrest nlocs nexts (decompile-load-program nargs nrest nlocs
(decompile-meta meta) (decompile-meta meta)
body labels #f)) body labels #f))
(else (else
@ -56,7 +56,7 @@
((glil-program? (car in)) (lp (cdr in) (cons (car in) out))) ((glil-program? (car in)) (lp (cdr in) (cons (car in) out)))
(else (lp (cdr in) (cons (make-glil-const (car l)) 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) objects)
(let ((glil-labels (sort (map (lambda (x) (let ((glil-labels (sort (map (lambda (x)
(cons (cdr x) (make-glil-label (car x)))) (cons (cdr x) (make-glil-label (car x))))
@ -100,19 +100,11 @@
(cond (cond
((null? in) ((null? in)
(or (null? stack) (error "leftover stack insts" stack body)) (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) ((pop-bindings! pos)
=> (lambda (bindings) => (lambda (bindings)
(lp in stack (lp in stack
(cons (make-glil-bind (cons (make-glil-bind bindings)
(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))
out) out)
pos))) pos)))
((pop-unbindings! pos) ((pop-unbindings! pos)

13
module/language/objcode/spec.scm
View file

@ -66,23 +66,16 @@
((program? x) ((program? x)
(let ((objs (program-objects x)) (let ((objs (program-objects x))
(meta (program-meta x)) (meta (program-meta x))
(exts (program-external x)) (free-vars (program-free-variables x))
(binds (program-bindings x)) (binds (program-bindings x))
(srcs (program-sources x)) (srcs (program-sources x))
(nargs (arity:nargs (program-arity x)))) (nargs (arity:nargs (program-arity x))))
(let ((blocs (and binds (let ((blocs (and binds (collapse-locals 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))))
(values (program-objcode x) (values (program-objcode x)
`((objects . ,objs) `((objects . ,objs)
(meta . ,(and meta (meta))) (meta . ,(and meta (meta)))
(exts . ,exts) (free-vars . ,free-vars)
(blocs . ,blocs) (blocs . ,blocs)
(bexts . ,bexts)
(sources . ,srcs)))))) (sources . ,srcs))))))
((objcode? x) ((objcode? x)
(values x #f)) (values x #f))

2
module/language/tree-il/compile-glil.scm
View file

@ -172,7 +172,7 @@
(1+ n) 1)))) (1+ n) 1))))
(let ((nlocs (car (hashq-ref allocation x)))) (let ((nlocs (car (hashq-ref allocation x))))
(make-glil-program (make-glil-program
nargs nrest nlocs 0 (lambda-meta x) nargs nrest nlocs (lambda-meta x)
(with-output-to-code (with-output-to-code
(lambda (emit-code) (lambda (emit-code)
;; write bindings and source debugging info ;; write bindings and source debugging info

1
module/system/repl/command.scm
View file

@ -386,7 +386,6 @@ Trace execution.
-s Display stack -s Display stack
-l Display local variables -l Display local variables
-e Display external variables
-b Bytecode level trace" -b Bytecode level trace"
(apply vm-trace (repl-vm repl) (apply vm-trace (repl-vm repl)
(repl-compile repl (repl-parse repl form)) (repl-compile repl (repl-parse repl form))

47
module/system/vm/frame.scm
View file

@ -1,6 +1,6 @@
;;; Guile VM frame functions ;;; 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> ;;; Copyright (C) 2005 Ludovic Courtès <ludovic.courtes@laas.fr>
;;; ;;;
;;; This program is free software; you can redistribute it and/or modify ;;; This program is free software; you can redistribute it and/or modify
@ -27,20 +27,20 @@
vm-frame-program vm-frame-program
vm-frame-local-ref vm-frame-local-set! vm-frame-local-ref vm-frame-local-set!
vm-frame-return-address vm-frame-mv-return-address 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-stack
vm-frame-number vm-frame-address vm-frame-number vm-frame-address
make-frame-chain make-frame-chain
print-frame print-frame-chain-as-backtrace print-frame print-frame-chain-as-backtrace
frame-arguments frame-local-variables frame-external-variables frame-arguments frame-local-variables
frame-environment frame-environment
frame-variable-exists? frame-variable-ref frame-variable-set! frame-variable-exists? frame-variable-ref frame-variable-set!
frame-object-name frame-object-name
frame-local-ref frame-external-link frame-local-set! frame-local-ref frame-local-set!
frame-return-address frame-program frame-return-address frame-program
frame-dynamic-link heap-frame?)) frame-dynamic-link heap-frame?))
(load-extension "libguile" "scm_init_frames") (load-extension "libguile" "scm_init_frames")
@ -158,24 +158,19 @@
(l '() (cons (frame-local-ref frame n) l))) (l '() (cons (frame-local-ref frame n) l)))
((< n 0) 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) (define (frame-binding-ref frame binding)
(if (binding:extp binding) (let ((x (frame-local-ref frame (binding:index binding))))
(frame-external-ref frame (binding:index binding)) (if (and (binding:boxed? binding) (variable? x))
(frame-local-ref frame (binding:index binding)))) (variable-ref x)
x)))
(define (frame-binding-set! frame binding val) (define (frame-binding-set! frame binding val)
(if (binding:extp binding) (if (binding:boxed? binding)
(frame-external-set! frame (binding:index binding) val) (let ((v (frame-local-ref frame binding)))
(frame-local-set! frame (binding:index binding) val))) (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 ;; FIXME handle #f program-bindings return
(define (frame-bindings frame addr) (define (frame-bindings frame addr)

10
module/system/vm/program.scm
View file

@ -21,9 +21,9 @@
(define-module (system vm program) (define-module (system vm program)
#:export (make-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 binding:start binding:end
source:addr source:line source:column source:file source:addr source:line source:column source:file
@ -41,10 +41,10 @@
(define arity:nrest cadr) (define arity:nrest cadr)
(define arity:nlocs caddr) (define arity:nlocs caddr)
(define (make-binding name extp index start end) (define (make-binding name boxed? index start end)
(list name extp index start end)) (list name boxed? index start end))
(define (binding:name b) (list-ref b 0)) (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:index b) (list-ref b 2))
(define (binding:start b) (list-ref b 3)) (define (binding:start b) (list-ref b 3))
(define (binding:end b) (list-ref b 4)) (define (binding:end b) (list-ref b 4))

5
module/system/vm/trace.scm
View file

@ -1,6 +1,6 @@
;;; Guile VM tracer ;;; 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 ;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public ;;; modify it under the terms of the GNU Lesser General Public
@ -54,8 +54,7 @@
((null? opts) (newline)) ((null? opts) (newline))
(case (car opts) (case (car opts)
((:s) (puts (truncate! (vm-fetch-stack vm) 3))) ((:s) (puts (truncate! (vm-fetch-stack vm) 3)))
((:l) (puts (vm-fetch-locals vm))) ((:l) (puts (vm-fetch-locals vm))))))
((:e) (puts (vm-fetch-externals vm))))))
(define (trace-apply vm) (define (trace-apply vm)
(if (vm-option vm 'trace-first) (if (vm-option vm 'trace-first)

12
test-suite/tests/asm-to-bytecode.test
View file

@ -85,28 +85,28 @@
(vector 'load-keyword 0 0 3 (char->integer #\q) (char->integer #\u) (vector 'load-keyword 0 0 3 (char->integer #\q) (char->integer #\u)
(char->integer #\x))) (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 (list->vector
`(load-program `(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) ;; len
,@(u32->u8-list 0) ;; metalen ,@(u32->u8-list 0) ;; metalen
make-int8 3 make-int8 3
return))) return)))
(comp-test '(load-program 3 2 1 0 () 3 (comp-test '(load-program 3 2 1 () 3
(load-program 3 2 1 0 () 3 (load-program 3 2 1 () 3
#f #f
(make-int8 3) (return)) (make-int8 3) (return))
(make-int8 3) (return)) (make-int8 3) (return))
(list->vector (list->vector
`(load-program `(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) ;; len
,@(u32->u8-list (+ 3 12)) ;; metalen ,@(u32->u8-list (+ 3 12)) ;; metalen
make-int8 3 make-int8 3
return 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 3) ;; len
,@(u32->u8-list 0) ;; metalen ,@(u32->u8-list 0) ;; metalen
make-int8 3 make-int8 3

134
test-suite/tests/tree-il.test
View file

@ -64,21 +64,21 @@
(with-test-prefix "void" (with-test-prefix "void"
(assert-tree-il->glil (assert-tree-il->glil
(void) (void)
(program 0 0 0 0 () (void) (call return 1))) (program 0 0 0 () (void) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(begin (void) (const 1)) (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 (assert-tree-il->glil
(apply (primitive +) (void) (const 1)) (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" (with-test-prefix "application"
(assert-tree-il->glil (assert-tree-il->glil
(apply (toplevel foo) (const 1)) (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 (assert-tree-il->glil/pmatch
(begin (apply (toplevel foo) (const 1)) (void)) (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) (call drop 1) (branch br ,l2)
(label ,l3) (mv-bind () #f) (unbind) (label ,l3) (mv-bind () #f) (unbind)
(label ,l4) (label ,l4)
@ -86,26 +86,26 @@
(and (eq? l1 l3) (eq? l2 l4))) (and (eq? l1 l3) (eq? l2 l4)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (toplevel foo) (apply (toplevel bar))) (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)))) (call goto/args 1))))
(with-test-prefix "conditional" (with-test-prefix "conditional"
(assert-tree-il->glil/pmatch (assert-tree-il->glil/pmatch
(if (const #t) (const 1) (const 2)) (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) (const 1) (call return 1)
(label ,l2) (const 2) (call return 1)) (label ,l2) (const 2) (call return 1))
(eq? l1 l2)) (eq? l1 l2))
(assert-tree-il->glil/pmatch (assert-tree-il->glil/pmatch
(begin (if (const #t) (const 1) (const 2)) (const #f)) (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)) (label ,l3) (label ,l4) (const #f) (call return 1))
(eq? l1 l3) (eq? l2 l4)) (eq? l1 l3) (eq? l2 l4))
(assert-tree-il->glil/pmatch (assert-tree-il->glil/pmatch
(apply (primitive null?) (if (const #t) (const 1) (const 2))) (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) (const 1) (branch br ,l2)
(label ,l3) (const 2) (label ,l4) (label ,l3) (const 2) (label ,l4)
(call null? 1) (call return 1)) (call null? 1) (call return 1))
@ -114,35 +114,35 @@
(with-test-prefix "primitive-ref" (with-test-prefix "primitive-ref"
(assert-tree-il->glil (assert-tree-il->glil
(primitive +) (primitive +)
(program 0 0 0 0 () (toplevel ref +) (call return 1))) (program 0 0 0 () (toplevel ref +) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(begin (primitive +) (const #f)) (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 (assert-tree-il->glil
(apply (primitive null?) (primitive +)) (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)))) (call return 1))))
(with-test-prefix "lexical refs" (with-test-prefix "lexical refs"
(assert-tree-il->glil (assert-tree-il->glil
(let (x) (y) ((const 1)) (lexical x y)) (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) (const 1) (bind (x #f 0)) (lexical #t #f set 0)
(lexical #t #f ref 0) (call return 1) (lexical #t #f ref 0) (call return 1)
(unbind))) (unbind)))
(assert-tree-il->glil (assert-tree-il->glil
(let (x) (y) ((const 1)) (begin (lexical x y) (const #f))) (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 1) (bind (x #f 0)) (lexical #t #f set 0)
(const #f) (call return 1) (const #f) (call return 1)
(unbind))) (unbind)))
(assert-tree-il->glil (assert-tree-il->glil
(let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y))) (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) (const 1) (bind (x #f 0)) (lexical #t #f set 0)
(lexical #t #f ref 0) (call null? 1) (call return 1) (lexical #t #f ref 0) (call null? 1) (call return 1)
(unbind)))) (unbind))))
@ -150,14 +150,14 @@
(with-test-prefix "lexical sets" (with-test-prefix "lexical sets"
(assert-tree-il->glil (assert-tree-il->glil
(let (x) (y) ((const 1)) (set! (lexical x y) (const 2))) (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 1) (bind (x #t 0)) (lexical #t #t box 0)
(const 2) (lexical #t #t set 0) (void) (call return 1) (const 2) (lexical #t #t set 0) (void) (call return 1)
(unbind))) (unbind)))
(assert-tree-il->glil (assert-tree-il->glil
(let (x) (y) ((const 1)) (begin (set! (lexical x y) (const 2)) (const #f))) (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 1) (bind (x #t 0)) (lexical #t #t box 0)
(const 2) (lexical #t #t set 0) (const #f) (call return 1) (const 2) (lexical #t #t set 0) (const #f) (call return 1)
(unbind))) (unbind)))
@ -165,7 +165,7 @@
(assert-tree-il->glil (assert-tree-il->glil
(let (x) (y) ((const 1)) (let (x) (y) ((const 1))
(apply (primitive null?) (set! (lexical x y) (const 2)))) (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 1) (bind (x #t 0)) (lexical #t #t box 0)
(const 2) (lexical #t #t set 0) (void) (call null? 1) (call return 1) (const 2) (lexical #t #t set 0) (void) (call null? 1) (call return 1)
(unbind)))) (unbind))))
@ -173,205 +173,205 @@
(with-test-prefix "module refs" (with-test-prefix "module refs"
(assert-tree-il->glil (assert-tree-il->glil
(@ (foo) bar) (@ (foo) bar)
(program 0 0 0 0 () (program 0 0 0 ()
(module public ref (foo) bar) (module public ref (foo) bar)
(call return 1))) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(begin (@ (foo) bar) (const #f)) (begin (@ (foo) bar) (const #f))
(program 0 0 0 0 () (program 0 0 0 ()
(module public ref (foo) bar) (call drop 1) (module public ref (foo) bar) (call drop 1)
(const #f) (call return 1))) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive null?) (@ (foo) bar)) (apply (primitive null?) (@ (foo) bar))
(program 0 0 0 0 () (program 0 0 0 ()
(module public ref (foo) bar) (module public ref (foo) bar)
(call null? 1) (call return 1))) (call null? 1) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(@@ (foo) bar) (@@ (foo) bar)
(program 0 0 0 0 () (program 0 0 0 ()
(module private ref (foo) bar) (module private ref (foo) bar)
(call return 1))) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(begin (@@ (foo) bar) (const #f)) (begin (@@ (foo) bar) (const #f))
(program 0 0 0 0 () (program 0 0 0 ()
(module private ref (foo) bar) (call drop 1) (module private ref (foo) bar) (call drop 1)
(const #f) (call return 1))) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive null?) (@@ (foo) bar)) (apply (primitive null?) (@@ (foo) bar))
(program 0 0 0 0 () (program 0 0 0 ()
(module private ref (foo) bar) (module private ref (foo) bar)
(call null? 1) (call return 1)))) (call null? 1) (call return 1))))
(with-test-prefix "module sets" (with-test-prefix "module sets"
(assert-tree-il->glil (assert-tree-il->glil
(set! (@ (foo) bar) (const 2)) (set! (@ (foo) bar) (const 2))
(program 0 0 0 0 () (program 0 0 0 ()
(const 2) (module public set (foo) bar) (const 2) (module public set (foo) bar)
(void) (call return 1))) (void) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(begin (set! (@ (foo) bar) (const 2)) (const #f)) (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 2) (module public set (foo) bar)
(const #f) (call return 1))) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive null?) (set! (@ (foo) bar) (const 2))) (apply (primitive null?) (set! (@ (foo) bar) (const 2)))
(program 0 0 0 0 () (program 0 0 0 ()
(const 2) (module public set (foo) bar) (const 2) (module public set (foo) bar)
(void) (call null? 1) (call return 1))) (void) (call null? 1) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(set! (@@ (foo) bar) (const 2)) (set! (@@ (foo) bar) (const 2))
(program 0 0 0 0 () (program 0 0 0 ()
(const 2) (module private set (foo) bar) (const 2) (module private set (foo) bar)
(void) (call return 1))) (void) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(begin (set! (@@ (foo) bar) (const 2)) (const #f)) (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 2) (module private set (foo) bar)
(const #f) (call return 1))) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive null?) (set! (@@ (foo) bar) (const 2))) (apply (primitive null?) (set! (@@ (foo) bar) (const 2)))
(program 0 0 0 0 () (program 0 0 0 ()
(const 2) (module private set (foo) bar) (const 2) (module private set (foo) bar)
(void) (call null? 1) (call return 1)))) (void) (call null? 1) (call return 1))))
(with-test-prefix "toplevel refs" (with-test-prefix "toplevel refs"
(assert-tree-il->glil (assert-tree-il->glil
(toplevel bar) (toplevel bar)
(program 0 0 0 0 () (program 0 0 0 ()
(toplevel ref bar) (toplevel ref bar)
(call return 1))) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(begin (toplevel bar) (const #f)) (begin (toplevel bar) (const #f))
(program 0 0 0 0 () (program 0 0 0 ()
(toplevel ref bar) (call drop 1) (toplevel ref bar) (call drop 1)
(const #f) (call return 1))) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive null?) (toplevel bar)) (apply (primitive null?) (toplevel bar))
(program 0 0 0 0 () (program 0 0 0 ()
(toplevel ref bar) (toplevel ref bar)
(call null? 1) (call return 1)))) (call null? 1) (call return 1))))
(with-test-prefix "toplevel sets" (with-test-prefix "toplevel sets"
(assert-tree-il->glil (assert-tree-il->glil
(set! (toplevel bar) (const 2)) (set! (toplevel bar) (const 2))
(program 0 0 0 0 () (program 0 0 0 ()
(const 2) (toplevel set bar) (const 2) (toplevel set bar)
(void) (call return 1))) (void) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(begin (set! (toplevel bar) (const 2)) (const #f)) (begin (set! (toplevel bar) (const 2)) (const #f))
(program 0 0 0 0 () (program 0 0 0 ()
(const 2) (toplevel set bar) (const 2) (toplevel set bar)
(const #f) (call return 1))) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive null?) (set! (toplevel bar) (const 2))) (apply (primitive null?) (set! (toplevel bar) (const 2)))
(program 0 0 0 0 () (program 0 0 0 ()
(const 2) (toplevel set bar) (const 2) (toplevel set bar)
(void) (call null? 1) (call return 1)))) (void) (call null? 1) (call return 1))))
(with-test-prefix "toplevel defines" (with-test-prefix "toplevel defines"
(assert-tree-il->glil (assert-tree-il->glil
(define bar (const 2)) (define bar (const 2))
(program 0 0 0 0 () (program 0 0 0 ()
(const 2) (toplevel define bar) (const 2) (toplevel define bar)
(void) (call return 1))) (void) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(begin (define bar (const 2)) (const #f)) (begin (define bar (const 2)) (const #f))
(program 0 0 0 0 () (program 0 0 0 ()
(const 2) (toplevel define bar) (const 2) (toplevel define bar)
(const #f) (call return 1))) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive null?) (define bar (const 2))) (apply (primitive null?) (define bar (const 2)))
(program 0 0 0 0 () (program 0 0 0 ()
(const 2) (toplevel define bar) (const 2) (toplevel define bar)
(void) (call null? 1) (call return 1)))) (void) (call null? 1) (call return 1))))
(with-test-prefix "constants" (with-test-prefix "constants"
(assert-tree-il->glil (assert-tree-il->glil
(const 2) (const 2)
(program 0 0 0 0 () (program 0 0 0 ()
(const 2) (call return 1))) (const 2) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(begin (const 2) (const #f)) (begin (const 2) (const #f))
(program 0 0 0 0 () (program 0 0 0 ()
(const #f) (call return 1))) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive null?) (const 2)) (apply (primitive null?) (const 2))
(program 0 0 0 0 () (program 0 0 0 ()
(const 2) (call null? 1) (call return 1)))) (const 2) (call null? 1) (call return 1))))
(with-test-prefix "lambda" (with-test-prefix "lambda"
(assert-tree-il->glil (assert-tree-il->glil
(lambda (x) (y) () (const 2)) (lambda (x) (y) () (const 2))
(program 0 0 0 0 () (program 0 0 0 ()
(program 1 0 0 0 () (program 1 0 0 ()
(bind (x #f 0)) (bind (x #f 0))
(const 2) (call return 1)) (const 2) (call return 1))
(call return 1))) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(lambda (x x1) (y y1) () (const 2)) (lambda (x x1) (y y1) () (const 2))
(program 0 0 0 0 () (program 0 0 0 ()
(program 2 0 0 0 () (program 2 0 0 ()
(bind (x #f 0) (x1 #f 1)) (bind (x #f 0) (x1 #f 1))
(const 2) (call return 1)) (const 2) (call return 1))
(call return 1))) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(lambda x y () (const 2)) (lambda x y () (const 2))
(program 0 0 0 0 () (program 0 0 0 ()
(program 1 1 0 0 () (program 1 1 0 ()
(bind (x #f 0)) (bind (x #f 0))
(const 2) (call return 1)) (const 2) (call return 1))
(call return 1))) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(lambda (x . x1) (y . y1) () (const 2)) (lambda (x . x1) (y . y1) () (const 2))
(program 0 0 0 0 () (program 0 0 0 ()
(program 2 1 0 0 () (program 2 1 0 ()
(bind (x #f 0) (x1 #f 1)) (bind (x #f 0) (x1 #f 1))
(const 2) (call return 1)) (const 2) (call return 1))
(call return 1))) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(lambda (x . x1) (y . y1) () (lexical x y)) (lambda (x . x1) (y . y1) () (lexical x y))
(program 0 0 0 0 () (program 0 0 0 ()
(program 2 1 0 0 () (program 2 1 0 ()
(bind (x #f 0) (x1 #f 1)) (bind (x #f 0) (x1 #f 1))
(lexical #t #f ref 0) (call return 1)) (lexical #t #f ref 0) (call return 1))
(call return 1))) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(lambda (x . x1) (y . y1) () (lexical x1 y1)) (lambda (x . x1) (y . y1) () (lexical x1 y1))
(program 0 0 0 0 () (program 0 0 0 ()
(program 2 1 0 0 () (program 2 1 0 ()
(bind (x #f 0) (x1 #f 1)) (bind (x #f 0) (x1 #f 1))
(lexical #t #f ref 1) (call return 1)) (lexical #t #f ref 1) (call return 1))
(call return 1))) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(lambda (x) (x1) () (lambda (y) (y1) () (lexical x x1))) (lambda (x) (x1) () (lambda (y) (y1) () (lexical x x1)))
(program 0 0 0 0 () (program 0 0 0 ()
(program 1 0 0 0 () (program 1 0 0 ()
(bind (x #f 0)) (bind (x #f 0))
(program 1 0 0 0 () (program 1 0 0 ()
(bind (y #f 0)) (bind (y #f 0))
(lexical #f #f ref 0) (call return 1)) (lexical #f #f ref 0) (call return 1))
(lexical #t #f ref 0) (lexical #t #f ref 0)
@ -383,12 +383,12 @@
(with-test-prefix "sequence" (with-test-prefix "sequence"
(assert-tree-il->glil (assert-tree-il->glil
(begin (begin (const 2) (const #f)) (const #t)) (begin (begin (const 2) (const #f)) (const #t))
(program 0 0 0 0 () (program 0 0 0 ()
(const #t) (call return 1))) (const #t) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive null?) (begin (const #f) (const 2))) (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)))) (const 2) (call null? 1) (call return 1))))
;; FIXME: binding info for or-hacked locals might bork the disassembler, ;; FIXME: binding info for or-hacked locals might bork the disassembler,
@ -400,7 +400,7 @@
(lexical x y) (lexical x y)
(let (a) (b) ((const 2)) (let (a) (b) ((const 2))
(lexical a b)))) (lexical a b))))
(program 0 0 1 0 () (program 0 0 1 ()
(const 1) (bind (x #f 0)) (lexical #t #f set 0) (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) (branch br-if-not ,l1)
(lexical #t #f ref 0) (call return 1) (lexical #t #f ref 0) (call return 1)
@ -417,7 +417,7 @@
(lexical x y) (lexical x y)
(let (a) (b) ((const 2)) (let (a) (b) ((const 2))
(lexical x y)))) (lexical x y))))
(program 0 0 2 0 () (program 0 0 2 ()
(const 1) (bind (x #f 0)) (lexical #t #f set 0) (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) (branch br-if-not ,l1)
(lexical #t #f ref 0) (call return 1) (lexical #t #f ref 0) (call return 1)
@ -431,10 +431,10 @@
(with-test-prefix "apply" (with-test-prefix "apply"
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive @apply) (toplevel foo) (toplevel bar)) (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 (assert-tree-il->glil/pmatch
(begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void)) (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) (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) (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
(label ,l4) (label ,l4)
@ -442,7 +442,7 @@
(and (eq? l1 l3) (eq? l2 l4))) (and (eq? l1 l3) (eq? l2 l4)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz))) (apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz)))
(program 0 0 0 0 () (program 0 0 0 ()
(toplevel ref foo) (toplevel ref foo)
(toplevel ref bar) (toplevel ref baz) (call apply 2) (toplevel ref bar) (toplevel ref baz) (call apply 2)
(call goto/args 1)))) (call goto/args 1))))
@ -450,10 +450,10 @@
(with-test-prefix "call/cc" (with-test-prefix "call/cc"
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive @call-with-current-continuation) (toplevel foo)) (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 (assert-tree-il->glil/pmatch
(begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void)) (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) (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) (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
(label ,l4) (label ,l4)
@ -462,7 +462,7 @@
(assert-tree-il->glil (assert-tree-il->glil
(apply (toplevel foo) (apply (toplevel foo)
(apply (toplevel @call-with-current-continuation) (toplevel bar))) (apply (toplevel @call-with-current-continuation) (toplevel bar)))
(program 0 0 0 0 () (program 0 0 0 ()
(toplevel ref foo) (toplevel ref foo)
(toplevel ref bar) (call call/cc 1) (toplevel ref bar) (call call/cc 1)
(call goto/args 1)))) (call goto/args 1))))