[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-376-g84680d2
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-376-g84680d2 |
|
Date: |
Fri, 08 Nov 2013 16:44:57 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=84680d238299c3b2c8be42b16a8be0ff6e02ba5c
The branch, master has been updated
via 84680d238299c3b2c8be42b16a8be0ff6e02ba5c (commit)
via 741073719e657c8d7103287e942a72a6aedcce88 (commit)
via 70974fd21329896f4d6fdca0147c46f723233d9d (commit)
via 4dfae1bf50912af2e47afe343e44aea1916ccd3e (commit)
via b77a5215c7dbee6c88ab9614942c9b0866c3ab0b (commit)
via e391f179e47bf36ce34c7e880250e3f2f383773f (commit)
via 0d4bcc71d2e2d19098fb940fd58e2e4727e9eb0c (commit)
via ad9b491fa72ea5bac2d463ba383aa812c644c5dd (commit)
via f3c0b533468990a59f3495bdbde5c73b6a9bf8a6 (commit)
via f7f5f49a6bc8f26031e73b6632f3dd86c755c179 (commit)
via 147f9978bad51368d4283c8ed5ca54e0afc0a205 (commit)
via 850e80dacc6bb7a4e91fcd4e665fe1f5518556c8 (commit)
via 5af36584d86791dd7267c27fc05384a5453d2c24 (commit)
via ac023564b2b46414e6803040564322f3bcca3725 (commit)
via 0afb26cc71109fd7068a8048980443848fcbad15 (commit)
via 4b98c7411e5ff17fdfdf7c1afeb6c4f1a03bb77f (commit)
via 539eeee6ae87291dd666c0f6ff3b467f77be776a (commit)
via 5d53070040f3e6f1d10874eebe27b8a2f215e167 (commit)
from 873422952847a458f5a236ee8d73e17963f0d58e (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 84680d238299c3b2c8be42b16a8be0ff6e02ba5c
Author: Andy Wingo <address@hidden>
Date: Fri Nov 8 17:42:54 2013 +0100
Miscellaneous fixups related to objcode removal.
* module/scripts/compile.scm: Fix --help message.
* module/system/repl/command.scm (disassemble): Fix error message.
* module/system/vm/frame.scm: Remove objcode import.
* module/system/vm/objcode.scm: Remove some exports related to the
objcode type.
commit 741073719e657c8d7103287e942a72a6aedcce88
Author: Andy Wingo <address@hidden>
Date: Fri Nov 8 17:41:31 2013 +0100
Remove program-sources-pre-retire case for stack programs.
* module/system/vm/program.scm (program-sources-pre-retire): Remove
stack program case.
commit 70974fd21329896f4d6fdca0147c46f723233d9d
Author: Andy Wingo <address@hidden>
Date: Fri Nov 8 17:40:46 2013 +0100
Remove (language objcode)
* module/language/objcode.scm: Remove. Seems to have been unused.
commit 4dfae1bf50912af2e47afe343e44aea1916ccd3e
Author: Andy Wingo <address@hidden>
Date: Fri Nov 8 17:36:45 2013 +0100
Move assemble-program to test cases.
* module/system/vm/assembler.scm (assemble-program): Remove.
* test-suite/tests/rtl.test (assemble-program): Move here.
commit b77a5215c7dbee6c88ab9614942c9b0866c3ab0b
Author: Andy Wingo <address@hidden>
Date: Fri Nov 8 17:32:41 2013 +0100
Per-instruction tracing doesn't try to disassemble stack VM code
* module/system/vm/trace.scm (trace-instructions-in-procedure): Don't
try to disassemble the procedure, for now.
commit e391f179e47bf36ce34c7e880250e3f2f383773f
Author: Andy Wingo <address@hidden>
Date: Fri Nov 8 17:31:51 2013 +0100
(system vm traps) support for rtl programs
* module/system/vm/debug.scm: Export program-debug-info-size.
* module/system/vm/traps.scm (frame-matcher): Remove stack program
case. Use absolute frame-instruction-procedure to match if
match-code?.
(program-last-ip): Use (system vm debug) interfaces.
(program-sources-by-line): Use program-sources, as
program-sources-pre-retire will go away soon. Return absolute
addresses.
commit 0d4bcc71d2e2d19098fb940fd58e2e4727e9eb0c
Author: Andy Wingo <address@hidden>
Date: Fri Nov 8 16:51:44 2013 +0100
Remove objcode language.
* module/language/objcode/elf.scm:
* module/language/objcode/spec.scm: Remove objcode language.
* module/Makefile.am: Adapt.
commit ad9b491fa72ea5bac2d463ba383aa812c644c5dd
Author: Andy Wingo <address@hidden>
Date: Fri Nov 8 16:49:04 2013 +0100
Remove bytecode language.
* module/language/bytecode/spec.scm: Remove.
* module/Makefile.am: Adapt.
commit f3c0b533468990a59f3495bdbde5c73b6a9bf8a6
Author: Andy Wingo <address@hidden>
Date: Fri Nov 8 16:45:10 2013 +0100
Remove assembly language.
* module/system/repl/command.scm: Remove disassembly cases for stack
procedures.
* module/system/vm/inspect.scm: Adapt to disassemble RTL programs.
* module/language/assembly.scm:
* module/language/assembly/compile-bytecode.scm:
* module/language/assembly/decompile-bytecode.scm:
* module/language/assembly/disassemble.scm:
* module/language/assembly/spec.scm: Remove assembly language.
* module/Makefile.am: Adapt.
commit f7f5f49a6bc8f26031e73b6632f3dd86c755c179
Author: Andy Wingo <address@hidden>
Date: Fri Nov 8 16:40:27 2013 +0100
Decompile goes from tree-il to scheme by default.
* module/system/base/compile.scm (decompile): By default, go from
tree-il to Scheme, now that the assembly language is going away.
commit 147f9978bad51368d4283c8ed5ca54e0afc0a205
Author: Andy Wingo <address@hidden>
Date: Fri Nov 8 16:31:29 2013 +0100
Rewrite (system xref) to work with RTL programs
* module/system/xref.scm (nested-procedures): New helper.
(program-callee-rev-vars): Rewrite using fold-program-code and
nested-procedures.
(add-sources, forget-sources): Use match instead of pmatch. Use
nested-procedures.
commit 850e80dacc6bb7a4e91fcd4e665fe1f5518556c8
Author: Andy Wingo <address@hidden>
Date: Fri Nov 8 15:58:27 2013 +0100
Add fold-program-code to (system vm disassembler)
* module/system/vm/disassembler.scm (fold-code-range): New helper.
(fold-program-code): New interface.
commit 5af36584d86791dd7267c27fc05384a5453d2c24
Author: Andy Wingo <address@hidden>
Date: Fri Nov 8 14:58:40 2013 +0100
Remove GLIL language
* module/Makefile.am:
* module/language/glil.scm:
* module/language/glil/compile-assembly.scm:
* module/language/glil/spec.scm: Remove.
commit ac023564b2b46414e6803040564322f3bcca3725
Author: Andy Wingo <address@hidden>
Date: Fri Nov 8 14:57:43 2013 +0100
Remove tree-il->glil compiler
* module/Makefile.am:
* module/language/tree-il/compile-glil.scm: Remove.
* module/language/tree-il/spec.scm: Remove tree-il->glil link.
commit 0afb26cc71109fd7068a8048980443848fcbad15
Author: Andy Wingo <address@hidden>
Date: Fri Nov 8 14:54:38 2013 +0100
Move useful parts of asm-to-bytecode.test to cross-compilation.test
* test-suite/tests/cross-compilation.test: Rename from asm-to-bytecode,
and remove the bits testing assembly->bytecode but keep the
cross-compilation things.
* test-suite/Makefile.am: Adapt.
commit 4b98c7411e5ff17fdfdf7c1afeb6c4f1a03bb77f
Author: Andy Wingo <address@hidden>
Date: Fri Nov 8 14:45:01 2013 +0100
Tree-IL warnings tests compile to CPS instead of "assembly"
* test-suite/tests/tree-il.test ("warnings"): Change warnings test to
compile to CPS instead of assembly.
commit 539eeee6ae87291dd666c0f6ff3b467f77be776a
Author: Andy Wingo <address@hidden>
Date: Fri Nov 8 14:41:22 2013 +0100
Remove tree-il->glil test cases
* test-suite/tests/tree-il.test: Remove GLIL test cases. They have
never been helpful to me in the 2.0 series, so there is no loss.
commit 5d53070040f3e6f1d10874eebe27b8a2f215e167
Author: Andy Wingo <address@hidden>
Date: Fri Nov 8 14:27:13 2013 +0100
Remove a couple of uses of GLIL from the test suite.
* test-suite/tests/cse.test ("cse"):
* test-suite/tests/peval.test: Remove uses of GLIL.
-----------------------------------------------------------------------
Summary of changes:
module/Makefile.am | 23 -
module/language/assembly.scm | 165 ----
module/language/assembly/compile-bytecode.scm | 178 ----
module/language/assembly/decompile-bytecode.scm | 144 ---
module/language/assembly/disassemble.scm | 171 ----
module/language/assembly/spec.scm | 35 -
module/language/bytecode/spec.scm | 40 -
module/language/glil.scm | 170 ----
module/language/glil/compile-assembly.scm | 952 --------------------
module/language/glil/spec.scm | 40 -
module/language/objcode.scm | 51 --
module/language/objcode/elf.scm | 92 --
module/language/objcode/spec.scm | 84 --
module/language/tree-il/compile-glil.scm | 1052 -----------------------
module/language/tree-il/spec.scm | 5 +-
module/scripts/compile.scm | 2 +-
module/system/base/compile.scm | 4 +-
module/system/repl/command.scm | 9 +-
module/system/vm/assembler.scm | 12 +-
module/system/vm/debug.scm | 1 +
module/system/vm/disassembler.scm | 66 ++
module/system/vm/frame.scm | 1 -
module/system/vm/inspect.scm | 9 +-
module/system/vm/objcode.scm | 6 +-
module/system/vm/program.scm | 35 +-
module/system/vm/trace.scm | 12 +-
module/system/vm/traps.scm | 102 ++--
module/system/xref.scm | 143 ++--
test-suite/Makefile.am | 2 +-
test-suite/tests/asm-to-bytecode.test | 217 -----
test-suite/tests/cross-compilation.test | 90 ++
test-suite/tests/cse.test | 8 +-
test-suite/tests/peval.test | 1 -
test-suite/tests/rtl.test | 10 +
test-suite/tests/tree-il.test | 786 +++---------------
35 files changed, 416 insertions(+), 4302 deletions(-)
delete mode 100644 module/language/assembly.scm
delete mode 100644 module/language/assembly/compile-bytecode.scm
delete mode 100644 module/language/assembly/decompile-bytecode.scm
delete mode 100644 module/language/assembly/disassemble.scm
delete mode 100644 module/language/assembly/spec.scm
delete mode 100644 module/language/bytecode/spec.scm
delete mode 100644 module/language/glil.scm
delete mode 100644 module/language/glil/compile-assembly.scm
delete mode 100644 module/language/glil/spec.scm
delete mode 100644 module/language/objcode.scm
delete mode 100644 module/language/objcode/elf.scm
delete mode 100644 module/language/objcode/spec.scm
delete mode 100644 module/language/tree-il/compile-glil.scm
delete mode 100644 test-suite/tests/asm-to-bytecode.test
create mode 100644 test-suite/tests/cross-compilation.test
diff --git a/module/Makefile.am b/module/Makefile.am
index 7b740b8..32baacb 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -50,15 +50,9 @@ SOURCES = \
language/tree-il/cse.scm \
\
language/tree-il.scm \
- language/glil.scm \
- language/assembly.scm \
$(TREE_IL_LANG_SOURCES) \
$(CPS_LANG_SOURCES) \
$(RTL_LANG_SOURCES) \
- $(GLIL_LANG_SOURCES) \
- $(ASSEMBLY_LANG_SOURCES) \
- $(BYTECODE_LANG_SOURCES) \
- $(OBJCODE_LANG_SOURCES) \
$(VALUE_LANG_SOURCES) \
$(SCHEME_LANG_SOURCES) \
$(SYSTEM_BASE_SOURCES) \
@@ -114,7 +108,6 @@ TREE_IL_LANG_SOURCES =
\
language/tree-il/analyze.scm \
language/tree-il/inline.scm \
language/tree-il/compile-cps.scm \
- language/tree-il/compile-glil.scm \
language/tree-il/debug.scm \
language/tree-il/spec.scm
@@ -137,22 +130,6 @@ RTL_LANG_SOURCES =
\
language/rtl.scm \
language/rtl/spec.scm
-GLIL_LANG_SOURCES = \
- language/glil/spec.scm language/glil/compile-assembly.scm
-
-ASSEMBLY_LANG_SOURCES = \
- language/assembly/spec.scm \
- language/assembly/compile-bytecode.scm \
- language/assembly/decompile-bytecode.scm \
- language/assembly/disassemble.scm
-
-BYTECODE_LANG_SOURCES = \
- language/bytecode/spec.scm
-
-OBJCODE_LANG_SOURCES = \
- language/objcode/spec.scm \
- language/objcode/elf.scm
-
VALUE_LANG_SOURCES = \
language/value/spec.scm
diff --git a/module/language/assembly.scm b/module/language/assembly.scm
deleted file mode 100644
index ad8dead..0000000
--- a/module/language/assembly.scm
+++ /dev/null
@@ -1,165 +0,0 @@
-;;; Guile Virtual Machine Assembly
-
-;; Copyright (C) 2001, 2009, 2010, 2011 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
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Code:
-
-(define-module (language assembly)
- #:use-module (rnrs bytevectors)
- #:use-module (system base pmatch)
- #:use-module (system vm instruction)
- #:use-module ((srfi srfi-1) #:select (fold))
- #:export (byte-length
- addr+ align-program align-code align-block
- assembly-pack assembly-unpack
- object->assembly assembly->object))
-
-;; len, metalen
-(define *program-header-len* (+ 4 4))
-
-;; lengths are encoded in 3 bytes
-(define *len-len* 3)
-
-
-(define (byte-length assembly)
- (pmatch assembly
- ((,inst . _) (guard (>= (instruction-length inst) 0))
- (+ 1 (instruction-length inst)))
- ((load-number ,str)
- (+ 1 *len-len* (string-length str)))
- ((load-string ,str)
- (+ 1 *len-len* (string-length str)))
- ((load-wide-string ,str)
- (+ 1 *len-len* (* 4 (string-length str))))
- ((load-symbol ,str)
- (+ 1 *len-len* (string-length str)))
- ((load-array ,bv)
- (+ 1 *len-len* (bytevector-length bv)))
- ((load-program ,labels ,len ,meta . ,code)
- (+ 1 *program-header-len* len (if meta (1- (byte-length meta)) 0)))
- (,label (guard (not (pair? label)))
- 0)
- (else (error "unknown instruction" assembly))))
-
-
-(define *program-alignment* 8)
-
-(define (addr+ addr code)
- (fold (lambda (x len) (+ (byte-length x) len))
- addr
- code))
-
-(define (code-alignment addr alignment header-len)
- (make-list (modulo (- alignment
- (modulo (+ addr header-len) alignment))
- alignment)
- '(nop)))
-
-(define (align-block addr)
- '())
-
-(define (align-code code addr alignment header-len)
- `(,@(code-alignment addr alignment header-len)
- ,code))
-
-(define (align-program prog addr)
- (align-code prog addr *program-alignment* 1))
-
-;;;
-;;; Code compress/decompression
-;;;
-
-(define *abbreviations*
- '(((make-int8 0) . (make-int8:0))
- ((make-int8 1) . (make-int8:1))))
-
-(define *expansions*
- (map (lambda (x) (cons (cdr x) (car x))) *abbreviations*))
-
-(define (assembly-pack code)
- (or (assoc-ref *abbreviations* code)
- code))
-
-(define (assembly-unpack code)
- (or (assoc-ref *expansions* code)
- code))
-
-
-;;;
-;;; Encoder/decoder
-;;;
-
-(define (object->assembly x)
- (cond ((eq? x #t) `(make-true))
- ((eq? x #f) `(make-false))
- ((eq? x #nil) `(make-nil))
- ((null? x) `(make-eol))
- ((and (integer? x) (exact? x))
- (cond ((and (<= -128 x) (< x 128))
- (assembly-pack `(make-int8 ,(modulo x 256))))
- ((and (<= -32768 x) (< x 32768))
- (let ((n (if (< x 0) (+ x 65536) x)))
- `(make-int16 ,(quotient n 256) ,(modulo n 256))))
- ((and (<= 0 x #xffffffffffffffff))
- `(make-uint64 ,@(bytevector->u8-list
- (let ((bv (make-bytevector 8)))
- (bytevector-u64-set! bv 0 x (endianness
big))
- bv))))
- ((and (<= 0 (+ x #x8000000000000000) #x7fffffffffffffff))
- `(make-int64 ,@(bytevector->u8-list
- (let ((bv (make-bytevector 8)))
- (bytevector-s64-set! bv 0 x (endianness big))
- bv))))
- (else #f)))
- ((char? x)
- (cond ((<= (char->integer x) #xff)
- `(make-char8 ,(char->integer x)))
- (else
- `(make-char32 ,(char->integer x)))))
- (else #f)))
-
-(define (assembly->object code)
- (pmatch code
- ((make-true) #t)
- ((make-false) #f) ;; FIXME: Same as the `else' case!
- ((make-nil) #nil)
- ((make-eol) '())
- ((make-int8 ,n)
- (if (< n 128) n (- n 256)))
- ((make-int16 ,n1 ,n2)
- (let ((n (+ (* n1 256) n2)))
- (if (< n 32768) n (- n 65536))))
- ((make-uint64 ,n1 ,n2 ,n3 ,n4 ,n5 ,n6 ,n7 ,n8)
- (bytevector-u64-ref
- (u8-list->bytevector (list n1 n2 n3 n4 n5 n6 n7 n8))
- 0
- (endianness big)))
- ((make-int64 ,n1 ,n2 ,n3 ,n4 ,n5 ,n6 ,n7 ,n8)
- (bytevector-s64-ref
- (u8-list->bytevector (list n1 n2 n3 n4 n5 n6 n7 n8))
- 0
- (endianness big)))
- ((make-char8 ,n)
- (integer->char n))
- ((make-char32 ,n1 ,n2 ,n3 ,n4)
- (integer->char (+ (* n1 #x1000000)
- (* n2 #x10000)
- (* n3 #x100)
- n4)))
- ((load-string ,s) s)
- ((load-symbol ,s) (string->symbol s))
- (else #f)))
diff --git a/module/language/assembly/compile-bytecode.scm
b/module/language/assembly/compile-bytecode.scm
deleted file mode 100644
index d54186e..0000000
--- a/module/language/assembly/compile-bytecode.scm
+++ /dev/null
@@ -1,178 +0,0 @@
-;;; Guile VM assembler
-
-;; Copyright (C) 2001, 2009, 2010, 2011, 2013 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
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Code:
-
-(define-module (language assembly compile-bytecode)
- #:use-module (system base pmatch)
- #:use-module (system base target)
- #:use-module (language assembly)
- #:use-module (system vm instruction)
- #:use-module (rnrs bytevectors)
- #:use-module ((srfi srfi-1) #:select (fold))
- #:export (compile-bytecode))
-
-(define (compile-bytecode assembly env . opts)
- (define-syntax-rule (define-inline1 (proc arg) body body* ...)
- (define-syntax proc
- (syntax-rules ()
- ((_ (arg-expr (... ...)))
- (let ((x (arg-expr (... ...))))
- (proc x)))
- ((_ arg)
- (begin body body* ...)))))
-
- (define (fill-bytecode bv target-endianness)
- (let ((pos 0))
- (define-inline1 (write-byte b)
- (bytevector-u8-set! bv pos b)
- (set! pos (1+ pos)))
- (define u32-bv (make-bytevector 4))
- (define-inline1 (write-int24-be x)
- (bytevector-s32-set! u32-bv 0 x (endianness big))
- (bytevector-u8-set! bv pos (bytevector-u8-ref u32-bv 1))
- (bytevector-u8-set! bv (+ pos 1) (bytevector-u8-ref u32-bv 2))
- (bytevector-u8-set! bv (+ pos 2) (bytevector-u8-ref u32-bv 3))
- (set! pos (+ pos 3)))
- (define-inline1 (write-uint32-be x)
- (bytevector-u32-set! bv pos x (endianness big))
- (set! pos (+ pos 4)))
- (define-inline1 (write-uint32 x)
- (bytevector-u32-set! bv pos x target-endianness)
- (set! pos (+ pos 4)))
- (define-inline1 (write-loader-len len)
- (bytevector-u8-set! bv pos (ash len -16))
- (bytevector-u8-set! bv (+ pos 1) (logand (ash len -8) 255))
- (bytevector-u8-set! bv (+ pos 2) (logand len 255))
- (set! pos (+ pos 3)))
- (define-inline1 (write-latin1-string s)
- (let ((len (string-length s)))
- (write-loader-len len)
- (let lp ((i 0))
- (if (< i len)
- (begin
- (bytevector-u8-set! bv (+ pos i)
- (char->integer (string-ref s i)))
- (lp (1+ i)))))
- (set! pos (+ pos len))))
- (define-inline1 (write-bytevector bv*)
- (let ((len (bytevector-length bv*)))
- (write-loader-len len)
- (bytevector-copy! bv* 0 bv pos len)
- (set! pos (+ pos len))))
- (define-inline1 (write-wide-string s)
- (write-bytevector (string->utf32 s target-endianness)))
- (define-inline1 (write-break label)
- (let ((offset (- (assq-ref labels label) (+ (get-addr) 3))))
- (cond ((>= offset (ash 1 23)) (error "jump too far forward" offset))
- ((< offset (- (ash 1 23))) (error "jump too far backwards"
offset))
- (else (write-int24-be offset)))))
-
- (define (write-bytecode asm labels address emit-opcode?)
- ;; Write ASM's bytecode to BV. If EMIT-OPCODE? is false, don't
- ;; emit bytecode for the first opcode encountered. Assume code
- ;; starts at ADDRESS (an integer). LABELS is assumed to be an
- ;; alist mapping labels to addresses.
- (define get-addr
- (let ((start pos))
- (lambda ()
- (+ address (- pos start)))))
- (define (write-break label)
- (let ((offset (- (assq-ref labels label) (+ (get-addr) 3))))
- (cond ((>= offset (ash 1 23)) (error "jump too far forward"
offset))
- ((< offset (- (ash 1 23))) (error "jump too far backwards"
offset))
- (else (write-int24-be offset)))))
-
- (let ((inst (car asm))
- (args (cdr asm)))
- (let ((opcode (instruction->opcode inst))
- (len (instruction-length inst)))
- (if emit-opcode?
- (write-byte opcode))
- (pmatch asm
- ((load-program ,labels ,length ,meta . ,code)
- (write-uint32 length)
- (write-uint32 (if meta (1- (byte-length meta)) 0))
- (fold (lambda (asm address)
- (let ((start pos))
- (write-bytecode asm labels address #t)
- (+ address (- pos start))))
- 0
- code)
- (if meta
- ;; Don't emit the `load-program' byte for metadata. Note
that
- ;; META's bytecode meets the alignment requirements of
- ;; `scm_objcode', thanks to the alignment computed in
`(language
- ;; assembly)'.
- (write-bytecode meta '() 0 #f)))
- ((make-char32 ,x) (write-uint32-be x))
- ((load-number ,str) (write-latin1-string str))
- ((load-string ,str) (write-latin1-string str))
- ((load-wide-string ,str) (write-wide-string str))
- ((load-symbol ,str) (write-latin1-string str))
- ((load-array ,bv) (write-bytevector bv))
- ((br ,l) (write-break l))
- ((br-if ,l) (write-break l))
- ((br-if-not ,l) (write-break l))
- ((br-if-eq ,l) (write-break l))
- ((br-if-not-eq ,l) (write-break l))
- ((br-if-null ,l) (write-break l))
- ((br-if-not-null ,l) (write-break l))
- ((br-if-nil ,l) (write-break l))
- ((br-if-not-nil ,l) (write-break l))
- ((br-if-nargs-ne ,hi ,lo ,l) (write-byte hi) (write-byte lo)
(write-break l))
- ((br-if-nargs-lt ,hi ,lo ,l) (write-byte hi) (write-byte lo)
(write-break l))
- ((br-if-nargs-gt ,hi ,lo ,l) (write-byte hi) (write-byte lo)
(write-break l))
- ((bind-optionals/shuffle-or-br ,nreq-hi ,nreq-lo
- ,nreq-and-nopt-hi
,nreq-and-nopt-lo
- ,ntotal-hi ,ntotal-lo
- ,l)
- (write-byte nreq-hi)
- (write-byte nreq-lo)
- (write-byte nreq-and-nopt-hi)
- (write-byte nreq-and-nopt-lo)
- (write-byte ntotal-hi)
- (write-byte ntotal-lo)
- (write-break l))
- ((mv-call ,n ,l) (write-byte n) (write-break l))
- ((prompt ,escape-only? ,l) (write-byte escape-only?)
(write-break l))
- (else
- (cond
- ((< len 0)
- (error "unhanded variable-length instruction" asm))
- ((not (= (length args) len))
- (error "bad number of args to instruction" asm len))
- (else
- (for-each (lambda (x) (write-byte x)) args))))))))
-
- ;; Don't emit the `load-program' byte.
- (write-bytecode assembly '() 0 #f)
- (if (= pos (bytevector-length bv))
- (values bv env env)
- (error "failed to fill bytevector" bv pos
- (bytevector-length bv)))))
-
- (pmatch assembly
- ((load-program ,labels ,length ,meta . ,code)
- (fill-bytecode (make-bytevector (+ 4 4 length
- (if meta
- (1- (byte-length meta))
- 0)))
- (target-endianness)))
-
- (else (error "bad assembly" assembly))))
diff --git a/module/language/assembly/decompile-bytecode.scm
b/module/language/assembly/decompile-bytecode.scm
deleted file mode 100644
index c3469bd..0000000
--- a/module/language/assembly/decompile-bytecode.scm
+++ /dev/null
@@ -1,144 +0,0 @@
-;;; Guile VM code converters
-
-;; Copyright (C) 2001, 2009, 2010, 2013 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
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Code:
-
-(define-module (language assembly decompile-bytecode)
- #:use-module (system vm instruction)
- #:use-module (system base pmatch)
- #:use-module (srfi srfi-4)
- #:use-module (rnrs bytevectors)
- #:use-module (language assembly)
- #:use-module ((system vm objcode) #:select (byte-order))
- #:export (decompile-bytecode))
-
-(define (decompile-bytecode x env opts)
- (let ((i 0) (size (u8vector-length x)))
- (define (pop)
- (let ((b (cond ((< i size) (u8vector-ref x i))
- ((= i size) #f)
- (else (error "tried to decode too many bytes")))))
- (if b (set! i (1+ i)))
- b))
- (let ((ret (decode-load-program pop)))
- (if (= i size)
- (values ret env)
- (error "bad bytecode: only decoded ~a out of ~a bytes" i size)))))
-
-(define (br-instruction? x)
- (memq x '(br br-if br-if-not br-if-eq br-if-not-eq br-if-null
br-if-not-null)))
-(define (br-nargs-instruction? x)
- (memq x '(br-if-nargs-ne br-if-nargs-lt br-if-nargs-gt
br-if-nargs-lt/non-kw)))
-
-(define (bytes->s24 a b c)
- (let ((x (+ (ash a 16) (ash b 8) c)))
- (if (zero? (logand (ash 1 23) x))
- x
- (- x (ash 1 24)))))
-
-;; FIXME: this is a little-endian disassembly!!!
-(define (decode-load-program pop)
- (let* ((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)))
- (metalen (+ e (ash f 8) (ash g 16) (ash h 24)))
- (labels '())
- (i 0))
- (define (ensure-label rel1 rel2 rel3)
- (let ((where (+ i (bytes->s24 rel1 rel2 rel3))))
- (or (assv-ref labels where)
- (begin
- (let ((l (gensym ":L")))
- (set! labels (acons where l labels))
- l)))))
- (define (sub-pop) ;; ...records. ha. ha.
- (let ((b (cond ((< i len) (pop))
- ((= i len) #f)
- (else (error "tried to decode too many bytes")))))
- (if b (set! i (1+ i)))
- b))
- (let lp ((out '()))
- (cond ((> i len)
- (error "error decoding program -- read too many bytes" out))
- ((= i len)
- `(load-program ,(map (lambda (x) (cons (cdr x) (car x)))
- (reverse labels))
- ,len
- ,(if (zero? metalen) #f (decode-load-program pop))
- ,@(reverse! out)))
- (else
- (let ((exp (decode-bytecode sub-pop)))
- (pmatch exp
- ((,br ,rel1 ,rel2 ,rel3) (guard (br-instruction? br))
- (lp (cons `(,br ,(ensure-label rel1 rel2 rel3)) out)))
- ((,br ,hi ,lo ,rel1 ,rel2 ,rel3) (guard
(br-nargs-instruction? br))
- (lp (cons `(,br ,hi ,lo ,(ensure-label rel1 rel2 rel3))
out)))
- ((bind-optionals/shuffle-or-br ,nreq-hi ,nreq-lo
- ,nreq-and-nopt-hi
,nreq-and-nopt-lo
- ,ntotal-hi ,ntotal-lo
- ,rel1 ,rel2 ,rel3)
- (lp (cons `(bind-optionals/shuffle-or-br
- ,nreq-hi ,nreq-lo
- ,nreq-and-nopt-hi ,nreq-and-nopt-lo
- ,ntotal-hi ,ntotal-lo
- ,(ensure-label rel1 rel2 rel3))
- out)))
- ((mv-call ,n ,rel1 ,rel2 ,rel3)
- (lp (cons `(mv-call ,n ,(ensure-label rel1 rel2 rel3)) out)))
- ((prompt ,n0 ,rel1 ,rel2 ,rel3)
- (lp (cons `(prompt ,n0 ,(ensure-label rel1 rel2 rel3)) out)))
- (else
- (lp (cons exp out))))))))))
-
-(define (decode-bytecode pop)
- (and=> (pop)
- (lambda (opcode)
- (let ((inst (opcode->instruction opcode)))
- (cond
- ((eq? inst 'load-program)
- (decode-load-program pop))
-
- ((< (instruction-length inst) 0)
- ;; the negative length indicates a variable length
- ;; instruction
- (let* ((make-sequence
- (if (or (memq inst '(load-array load-wide-string)))
- make-bytevector
- make-string))
- (sequence-set!
- (if (or (memq inst '(load-array load-wide-string)))
- bytevector-u8-set!
- (lambda (str pos value)
- (string-set! str pos (integer->char value)))))
- (len (let* ((a (pop)) (b (pop)) (c (pop)))
- (+ (ash a 16) (ash b 8) c)))
- (seq (make-sequence len)))
- (let lp ((i 0))
- (if (= i len)
- `(,inst ,(if (eq? inst 'load-wide-string)
- (utf32->string seq (native-endianness))
- seq))
- (begin
- (sequence-set! seq i (pop))
- (lp (1+ i)))))))
- (else
- ;; fixed length
- (let lp ((n (instruction-length inst)) (out (list inst)))
- (if (zero? n)
- (reverse! out)
- (lp (1- n) (cons (pop) out))))))))))
diff --git a/module/language/assembly/disassemble.scm
b/module/language/assembly/disassemble.scm
deleted file mode 100644
index dcdd780..0000000
--- a/module/language/assembly/disassemble.scm
+++ /dev/null
@@ -1,171 +0,0 @@
-;;; Guile VM code converters
-
-;; Copyright (C) 2001, 2009, 2010, 2012, 2013 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
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Code:
-
-(define-module (language assembly disassemble)
- #:use-module (ice-9 format)
- #:use-module (srfi srfi-1)
- #:use-module (system vm instruction)
- #:use-module (system vm program)
- #:use-module (system base pmatch)
- #:use-module (language assembly)
- #:use-module (system base compile)
- #:export (disassemble))
-
-(define (disassemble x)
- (format #t "Disassembly of ~A:\n\n" x)
- (call-with-values
- (lambda () (decompile x #:from 'value #:to 'assembly))
- disassemble-load-program))
-
-(define (disassemble-load-program asm env)
- (pmatch asm
- ((load-program ,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)))
- (blocs (and env (assq-ref env 'blocs)))
- (srcs (and env (assq-ref env 'sources))))
- (let lp ((pos 0) (code code) (programs '()))
- (cond
- ((null? code)
- (newline)
- (for-each
- (lambda (sym+asm)
- (format #t "Embedded program ~A:\n\n" (car sym+asm))
- (disassemble-load-program (cdr sym+asm) '()))
- (reverse! programs)))
- (else
- (let* ((asm (car code))
- (len (byte-length asm))
- (end (+ pos len)))
- (pmatch asm
- ((load-program . _)
- (let ((sym (gensym "")))
- (print-info pos `(load-program ,sym) #f #f)
- (lp (+ pos (byte-length asm)) (cdr code)
- (acons sym asm programs))))
- ((nop)
- (lp (+ pos (byte-length asm)) (cdr code) programs))
- (else
- (print-info pos asm
- ;; FIXME: code-annotation for whether it's
- ;; an arg or not, currently passing nargs=-1
- (code-annotation end asm objs -1 blocs
- labels)
- (and=> (and srcs (assq end srcs)) source->string))
- (lp (+ pos (byte-length asm)) (cdr code) programs)))))))
-
- (if (pair? free-vars)
- (disassemble-free-vars free-vars))
- (if meta
- (disassemble-meta meta))
-
- ;; Disassemble other bytecode in it
- ;; FIXME: something about the module.
- (if objs
- (for-each
- (lambda (x)
- (if (program? x)
- (begin (display "----------------------------------------\n")
- (disassemble x))))
- (cdr (vector->list objs))))))
- (else
- (error "bad load-program form" asm))))
-
-(define (disassemble-free-vars free-vars)
- (display "Free variables:\n\n")
- (fold (lambda (free-var i)
- (print-info i free-var #f #f)
- (+ 1 i))
- 0
- free-vars))
-
-(define-macro (unless test . body)
- `(if (not ,test) (begin ,@body)))
-
-(define *uninteresting-props* '(name))
-
-(define (disassemble-meta meta)
- (let ((props (filter (lambda (x)
- (not (memq (car x) *uninteresting-props*)))
- (cdddr meta))))
- (unless (null? props)
- (display "Properties:\n\n")
- (for-each (lambda (x) (print-info #f x #f #f)) props)
- (newline))))
-
-(define (source->string src)
- (format #f "~a:~a:~a" (or (source:file src) "(unknown file)")
- (source:line-for-user src) (source:column src)))
-
-(define (make-int16 byte1 byte2)
- (+ (* byte1 256) byte2))
-
-(define (code-annotation end-addr code objs nargs blocs labels)
- (let* ((code (assembly-unpack code))
- (inst (car code))
- (args (cdr code)))
- (case inst
- ((list vector)
- (list "~a element~:p" (apply make-int16 args)))
- ((br
- br-if br-if-eq br-if-not br-if-not-eq br-if-not-null br-if-null
- br-if-nil br-if-not-nil)
- (list "-> ~A" (assq-ref labels (car args))))
- ((br-if-nargs-ne br-if-nargs-lt br-if-nargs-gt)
- (list "-> ~A" (assq-ref labels (caddr args))))
- ((bind-optionals/shuffle-or-br)
- (list "-> ~A" (assq-ref labels (car (last-pair args)))))
- ((object-ref)
- (and objs (list "~s" (vector-ref objs (car args)))))
- ((local-ref local-boxed-ref local-set local-boxed-set)
- (and blocs
- (let lp ((bindings (list-ref blocs (car args))))
- (and (pair? bindings)
- (let ((b (car bindings)))
- (if (and (< (binding:start (car bindings)) end-addr)
- (>= (binding:end (car bindings)) end-addr))
- (list "`~a'address@hidden (arg)~]"
- (binding:name b) (< (binding:index b) nargs))
- (lp (cdr bindings))))))))
- ((assert-nargs-ee/locals assert-nargs-ge/locals)
- (list "~a arg~:p, ~a local~:p"
- (logand (car args) #x7) (ash (car args) -3)))
- ((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))))
- (if (and (variable? v) (variable-bound? v))
- (list "~s" (variable-ref v))
- (list "`~s'" v)))))
- ((mv-call)
- (list "MV -> ~A" (assq-ref labels (cadr args))))
- ((prompt)
- ;; the H is for handler
- (list "H -> ~A" (assq-ref labels (cadr args))))
- (else
- (and=> (assembly->object code)
- (lambda (obj) (list "~s" obj)))))))
-
-;; i am format's daddy.
-(define (print-info addr info extra src)
- (format #t "address@hidden address@hidden;; address@hidden@[~61t at
~a~]\n" addr info extra src))
diff --git a/module/language/assembly/spec.scm
b/module/language/assembly/spec.scm
deleted file mode 100644
index 0a497e4..0000000
--- a/module/language/assembly/spec.scm
+++ /dev/null
@@ -1,35 +0,0 @@
-;;; Guile Virtual Machine Assembly
-
-;; Copyright (C) 2001, 2009, 2010, 2013 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
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Code:
-
-(define-module (language assembly spec)
- #:use-module (system base language)
- #:use-module (language assembly compile-bytecode)
- #:use-module (language assembly decompile-bytecode)
- #:export (assembly))
-
-(define-language assembly
- #:title "Guile Virtual Machine Assembly Language"
- #:reader (lambda (port env) (read port))
- #:printer write
- #:parser read ;; fixme: make a verifier?
- #:compilers `((bytecode . ,compile-bytecode))
- #:decompilers `((bytecode . ,decompile-bytecode))
- #:for-humans? #f
- )
diff --git a/module/language/bytecode/spec.scm
b/module/language/bytecode/spec.scm
deleted file mode 100644
index ca703c3..0000000
--- a/module/language/bytecode/spec.scm
+++ /dev/null
@@ -1,40 +0,0 @@
-;;; Guile Lowlevel Intermediate Language
-
-;; Copyright (C) 2001, 2009, 2010, 2012, 2013 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
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Code:
-
-(define-module (language bytecode spec)
- #:use-module (system base language)
- #:use-module (system base target)
- #:use-module (system vm objcode)
- #:export (bytecode))
-
-(define (compile-objcode x e opts)
- (values (bytecode->objcode x (target-endianness)) e e))
-
-(define (decompile-objcode x e opts)
- (values (objcode->bytecode x (target-endianness)) e))
-
-(define-language bytecode
- #:title "Guile Bytecode Vectors"
- #:reader (lambda (port env) (read port))
- #:printer write
- #:compilers `((objcode . ,compile-objcode))
- #:decompilers `((objcode . ,decompile-objcode))
- #:for-humans? #f
- )
diff --git a/module/language/glil.scm b/module/language/glil.scm
deleted file mode 100644
index 9c23854..0000000
--- a/module/language/glil.scm
+++ /dev/null
@@ -1,170 +0,0 @@
-;;; Guile Low Intermediate Language
-
-;; Copyright (C) 2001, 2009, 2010 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
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Code:
-
-(define-module (language glil)
- #:use-module (system base syntax)
- #:use-module (system base pmatch)
- #:use-module ((srfi srfi-1) #:select (fold))
- #:export
- (<glil-program> make-glil-program glil-program?
- glil-program-meta glil-program-body
-
- <glil-std-prelude> make-glil-std-prelude glil-std-prelude?
- glil-std-prelude-nreq glil-std-prelude-nlocs glil-std-prelude-else-label
-
- <glil-opt-prelude> make-glil-opt-prelude glil-opt-prelude?
- glil-opt-prelude-nreq glil-opt-prelude-nopt glil-opt-prelude-rest
- glil-opt-prelude-nlocs glil-opt-prelude-else-label
-
- <glil-kw-prelude> make-glil-kw-prelude glil-kw-prelude?
- glil-kw-prelude-nreq glil-kw-prelude-nopt glil-kw-prelude-kw
- glil-kw-prelude-allow-other-keys? glil-kw-prelude-rest
- glil-kw-prelude-nlocs glil-kw-prelude-else-label
-
- <glil-bind> make-glil-bind glil-bind?
- glil-bind-vars
-
- <glil-mv-bind> make-glil-mv-bind glil-mv-bind?
- glil-mv-bind-vars glil-mv-bind-rest
-
- <glil-unbind> make-glil-unbind glil-unbind?
-
- <glil-source> make-glil-source glil-source?
- glil-source-props
-
- <glil-void> make-glil-void glil-void?
-
- <glil-const> make-glil-const glil-const?
- glil-const-obj
-
- <glil-lexical> make-glil-lexical glil-lexical?
- glil-lexical-local? glil-lexical-boxed? glil-lexical-op glil-lexical-index
-
- <glil-toplevel> make-glil-toplevel glil-toplevel?
- glil-toplevel-op glil-toplevel-name
-
- <glil-module> make-glil-module glil-module?
- glil-module-op glil-module-mod glil-module-name glil-module-public?
-
- <glil-label> make-glil-label glil-label?
- glil-label-label
-
- <glil-branch> make-glil-branch glil-branch?
- glil-branch-inst glil-branch-label
-
- <glil-call> make-glil-call glil-call?
- glil-call-inst glil-call-nargs
-
- <glil-mv-call> make-glil-mv-call glil-mv-call?
- glil-mv-call-nargs glil-mv-call-ra
-
- <glil-prompt> make-glil-prompt glil-prompt? glil-prompt-label
glil-prompt-escape-only?
-
- parse-glil unparse-glil))
-
-(define (print-glil x port)
- (format port "#<glil ~s>" (unparse-glil x)))
-
-(define-type (<glil> #:printer print-glil)
- ;; Meta operations
- (<glil-program> meta body)
- (<glil-std-prelude> nreq nlocs else-label)
- (<glil-opt-prelude> nreq nopt rest nlocs else-label)
- (<glil-kw-prelude> nreq nopt rest kw allow-other-keys? nlocs else-label)
- (<glil-bind> vars)
- (<glil-mv-bind> vars rest)
- (<glil-unbind>)
- (<glil-source> props)
- ;; Objects
- (<glil-void>)
- (<glil-const> obj)
- ;; Variables
- (<glil-lexical> local? boxed? op index)
- (<glil-toplevel> op name)
- (<glil-module> op mod name public?)
- ;; Controls
- (<glil-label> label)
- (<glil-branch> inst label)
- (<glil-call> inst nargs)
- (<glil-mv-call> nargs ra)
- (<glil-prompt> label escape-only?))
-
-
-
-(define (parse-glil x)
- (pmatch x
- ((program ,meta . ,body)
- (make-glil-program meta (map parse-glil body)))
- ((std-prelude ,nreq ,nlocs ,else-label)
- (make-glil-std-prelude nreq nlocs else-label))
- ((opt-prelude ,nreq ,nopt ,rest ,nlocs ,else-label)
- (make-glil-opt-prelude nreq nopt rest nlocs else-label))
- ((kw-prelude ,nreq ,nopt ,rest ,kw ,allow-other-keys? ,nlocs ,else-label)
- (make-glil-kw-prelude nreq nopt rest kw allow-other-keys? nlocs
else-label))
- ((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))
- ((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))
- ((module private ,op ,mod ,name) (make-glil-module op mod name #f))
- ((label ,label) (make-glil-label label))
- ((branch ,inst ,label) (make-glil-branch inst label))
- ((call ,inst ,nargs) (make-glil-call inst nargs))
- ((mv-call ,nargs ,ra) (make-glil-mv-call nargs ra))
- ((prompt ,label ,escape-only?)
- (make-glil-prompt label escape-only?))
- (else (error "invalid glil" x))))
-
-(define (unparse-glil glil)
- (record-case glil
- ;; meta
- ((<glil-program> meta body)
- `(program ,meta ,@(map unparse-glil body)))
- ((<glil-std-prelude> nreq nlocs else-label)
- `(std-prelude ,nreq ,nlocs ,else-label))
- ((<glil-opt-prelude> nreq nopt rest nlocs else-label)
- `(opt-prelude ,nreq ,nopt ,rest ,nlocs ,else-label))
- ((<glil-kw-prelude> nreq nopt rest kw allow-other-keys? nlocs else-label)
- `(kw-prelude ,nreq ,nopt ,rest ,kw ,allow-other-keys? ,nlocs ,else-label))
- ((<glil-bind> vars) `(bind ,@vars))
- ((<glil-mv-bind> vars rest) `(mv-bind ,vars ,rest))
- ((<glil-unbind>) `(unbind))
- ((<glil-source> props) `(source ,props))
- ;; constants
- ((<glil-void>) `(void))
- ((<glil-const> obj) `(const ,obj))
- ;; variables
- ((<glil-lexical> local? boxed? op index)
- `(lexical ,local? ,boxed? ,op ,index))
- ((<glil-toplevel> op name)
- `(toplevel ,op ,name))
- ((<glil-module> op mod name public?)
- `(module ,(if public? 'public 'private) ,op ,mod ,name))
- ;; controls
- ((<glil-label> label) `(label ,label))
- ((<glil-branch> inst label) `(branch ,inst ,label))
- ((<glil-call> inst nargs) `(call ,inst ,nargs))
- ((<glil-mv-call> nargs ra) `(mv-call ,nargs ,ra))
- ((<glil-prompt> label escape-only?)
- `(prompt ,label escape-only?))))
diff --git a/module/language/glil/compile-assembly.scm
b/module/language/glil/compile-assembly.scm
deleted file mode 100644
index 4633485..0000000
--- a/module/language/glil/compile-assembly.scm
+++ /dev/null
@@ -1,952 +0,0 @@
-;;; Guile VM assembler
-
-;; Copyright (C) 2001, 2009, 2010, 2011, 2013 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
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Code:
-
-(define-module (language glil compile-assembly)
- #:use-module (system base syntax)
- #:use-module (system base pmatch)
- #:use-module (language glil)
- #:use-module (language assembly)
- #:use-module (system vm instruction)
- #:use-module ((system vm program) #:select (make-binding))
- #:use-module (ice-9 receive)
- #:use-module (ice-9 vlist)
- #:use-module ((srfi srfi-1) #:select (fold))
- #:use-module (rnrs bytevectors)
- #:export (compile-assembly))
-
-;; Traversal helpers
-;;
-(define (vhash-fold-right2 proc vhash s0 s1)
- (let lp ((i (vlist-length vhash)) (s0 s0) (s1 s1))
- (if (zero? i)
- (values s0 s1)
- (receive (s0 s1) (let ((pair (vlist-ref vhash (1- i))))
- (proc (car pair) (cdr pair) s0 s1))
- (lp (1- i) s0 s1)))))
-
-(define (fold2 proc ls s0 s1)
- (let lp ((ls ls) (s0 s0) (s1 s1))
- (if (null? ls)
- (values s0 s1)
- (receive (s0 s1) (proc (car ls) s0 s1)
- (lp (cdr ls) s0 s1)))))
-
-(define (vector-fold2 proc vect s0 s1)
- (let ((len (vector-length vect)))
- (let lp ((i 0) (s0 s0) (s1 s1))
- (if (< i len)
- (receive (s0 s1) (proc (vector-ref vect i) s0 s1)
- (lp (1+ i) s0 s1))
- (values s0 s1)))))
-
-;; Variable cache cells go in the object table, and serialize as their
-;; keys. The reason we wrap the keys in these records is so they don't
-;; compare as `equal?' to other objects in the object table.
-;;
-;; `key' is either a symbol or the list (MODNAME SYM PUBLIC?)
-
-(define-record <variable-cache-cell> key)
-
-(define (limn-sources sources)
- (let lp ((in sources) (out '()) (filename #f))
- (if (null? in)
- (reverse! out)
- (let ((addr (caar in))
- (new-filename (assq-ref (cdar in ) 'filename))
- (line (assq-ref (cdar in) 'line))
- (column (assq-ref (cdar in) 'column)))
- (cond
- ((not (equal? new-filename filename))
- (lp (cdr in)
- `((,addr . (,line . ,column))
- (filename . ,new-filename)
- . ,out)
- new-filename))
- ((or (null? out) (not (equal? (cdar out) `(,line . ,column))))
- (lp (cdr in)
- `((,addr . (,line . ,column))
- . ,out)
- filename))
- (else
- (lp (cdr in) out filename)))))))
-
-
-;; Avoid going through the compiler so as to avoid adding to the
-;; constant store.
-(define (make-meta bindings sources arities tail)
- (let ((body `(,@(dump-object `(,bindings ,sources ,arities ,@tail) 0)
- (return))))
- `(load-program ()
- ,(addr+ 0 body)
- #f
- ,@body)))
-
-;; If this is true, the object doesn't need to go in a constant table.
-;;
-(define (immediate? x)
- (object->assembly x))
-
-;; This tests for a proper scheme list whose last cdr is '(), not #nil.
-;;
-(define (scheme-list? x)
- (and (list? x)
- (or (eq? x '())
- (let ((p (last-pair x)))
- (and (pair? p)
- (eq? (cdr p) '()))))))
-
-;; Note: in all of these procedures that build up constant tables, the
-;; first (zeroth) index is reserved. At runtime it is replaced with the
-;; procedure's module. Hence all of this 1+ length business.
-
-;; Build up a vhash of constant -> index, allowing us to build up a
-;; constant table for a whole compilation unit.
-;;
-(define (build-constant-store x)
- (define (add-to-store store x)
- (define (add-to-end store x)
- (vhash-cons x (1+ (vlist-length store)) store))
- (cond
- ((vhash-assoc x store)
- ;; Already in the store.
- store)
- ((immediate? x)
- ;; Immediates don't need to go in the constant table.
- store)
- ((or (number? x)
- (string? x)
- (symbol? x)
- (keyword? x))
- ;; Atoms.
- (add-to-end store x))
- ((variable-cache-cell? x)
- ;; Variable cache cells (see below).
- (add-to-end (add-to-store store (variable-cache-cell-key x))
- x))
- ((list? x)
- ;; Add the elements to the store, then the list itself. We could
- ;; try hashing the cdrs as well, but that seems a bit overkill, and
- ;; this way we do compress the bytecode a bit by allowing the use of
- ;; the `list' opcode.
- (let ((store (fold (lambda (x store)
- (add-to-store store x))
- store
- x)))
- (add-to-end store x)))
- ((pair? x)
- ;; Non-lists get caching on both fields.
- (let ((store (add-to-store (add-to-store store (car x))
- (cdr x))))
- (add-to-end store x)))
- ((and (vector? x)
- (equal? (array-shape x) (list (list 0 (1- (vector-length x))))))
- ;; Likewise, add the elements to the store, then the vector itself.
- ;; Important for the vectors produced by the psyntax expansion
- ;; process.
- (let ((store (fold (lambda (x store)
- (add-to-store store x))
- store
- (vector->list x))))
- (add-to-end store x)))
- ((array? x)
- ;; Naive assumption that if folks are using arrays, that perhaps
- ;; there's not much more duplication.
- (add-to-end store x))
- (else
- (error "build-constant-store: unrecognized object" x))))
-
- (let walk ((x x) (store vlist-null))
- (record-case x
- ((<glil-program> meta body)
- (fold walk store body))
- ((<glil-const> obj)
- (add-to-store store obj))
- ((<glil-kw-prelude> kw)
- (add-to-store store kw))
- ((<glil-toplevel> op name)
- ;; We don't add toplevel variable cache cells to the global
- ;; constant table, because they are sensitive to changes in
- ;; modules as the toplevel expressions are evaluated. So we just
- ;; add the name.
- (add-to-store store name))
- ((<glil-module> op mod name public?)
- ;; However, it is fine add module variable cache cells to the
- ;; global table, as their bindings are not dependent on the
- ;; current module.
- (add-to-store store
- (make-variable-cache-cell (list mod name public?))))
- (else store))))
-
-;; Analyze one <glil-program> to determine its object table. Produces a
-;; vhash of constant to index.
-;;
-(define (build-object-table x)
- (define (add store x)
- (if (vhash-assoc x store)
- store
- (vhash-cons x (1+ (vlist-length store)) store)))
- (record-case x
- ((<glil-program> meta body)
- (fold (lambda (x table)
- (record-case x
- ((<glil-program> meta body)
- ;; Add the GLIL itself to the table.
- (add table x))
- ((<glil-const> obj)
- (if (immediate? obj)
- table
- (add table obj)))
- ((<glil-kw-prelude> kw)
- (add table kw))
- ((<glil-toplevel> op name)
- (add table (make-variable-cache-cell name)))
- ((<glil-module> op mod name public?)
- (add table (make-variable-cache-cell (list mod name public?))))
- (else table)))
- vlist-null
- body))))
-
-;; A functional stack of names of live variables.
-(define (make-open-binding name boxed? index)
- (list name boxed? index))
-(define (make-closed-binding open-binding start end)
- (make-binding (car open-binding) (cadr open-binding)
- (caddr open-binding) start end))
-(define (open-binding bindings vars start)
- (cons
- (acons start
- (map
- (lambda (v)
- (pmatch v
- ((,name ,boxed? ,i)
- (make-open-binding name boxed? i))
- (else (error "unknown binding type" v))))
- vars)
- (car bindings))
- (cdr bindings)))
-(define (close-binding bindings end)
- (pmatch bindings
- ((((,start . ,closing) . ,open) . ,closed)
- (cons open
- (fold (lambda (o tail)
- ;; the cons is for dsu sort
- (acons start (make-closed-binding o start end)
- tail))
- closed
- closing)))
- (else (error "broken bindings" bindings))))
-(define (close-all-bindings bindings end)
- (if (null? (car bindings))
- (map cdr
- (stable-sort (reverse (cdr bindings))
- (lambda (x y) (< (car x) (car y)))))
- (close-all-bindings (close-binding bindings end) end)))
-
-
-;; A functional arities thingamajiggy.
-;; arities := ((ip nreq [[nopt] [[rest] [kw]]]]) ...)
-(define (open-arity addr nreq nopt rest kw arities)
- (cons
- (cond
- (kw (list addr nreq nopt rest kw))
- (rest (list addr nreq nopt rest))
- (nopt (list addr nreq nopt))
- (nreq (list addr nreq))
- (else (list addr)))
- arities))
-(define (close-arity addr arities)
- (pmatch arities
- (() '())
- (((,start . ,tail) . ,rest)
- `((,start ,addr . ,tail) . ,rest))
- (else (error "bad arities" arities))))
-(define (begin-arity end start nreq nopt rest kw arities)
- (open-arity start nreq nopt rest kw (close-arity end arities)))
-
-(define (compile-assembly glil)
- (let* ((all-constants (build-constant-store glil))
- (prog (compile-program glil all-constants))
- (len (byte-length prog)))
- ;; The top objcode thunk. We're going to wrap this thunk in
- ;; a thunk -- yo dawgs -- with the goal being to lift all
- ;; constants up to the top level. The store forms a DAG, so
- ;; we can actually build up later elements in terms of
- ;; earlier ones.
- ;;
- (cond
- ((vlist-null? all-constants)
- ;; No constants: just emit the inner thunk.
- prog)
- (else
- ;; We have an object store, so write it out, attach it
- ;; to the inner thunk, and tail call.
- (receive (tablecode addr) (dump-constants all-constants)
- (let ((prog (align-program prog addr)))
- ;; Outer thunk.
- `(load-program ()
- ,(+ (addr+ addr prog)
- 2 ; for (tail-call 0)
- )
- #f
- ;; Load the table, build the inner
- ;; thunk, then tail call.
- ,@tablecode
- ,@prog
- (tail-call 0))))))))
-
-(define (compile-program glil constants)
- (record-case glil
- ((<glil-program> meta body)
- (let lp ((body body) (code '()) (bindings '(())) (source-alist '())
- (label-alist '()) (arities '()) (addr 0))
- (cond
- ((null? body)
- (let ((code (fold append '() code))
- (bindings (close-all-bindings bindings addr))
- (sources (limn-sources (reverse! source-alist)))
- (labels (reverse label-alist))
- (arities (reverse (close-arity addr arities)))
- (len addr))
- (let* ((meta (make-meta bindings sources arities meta))
- (meta-pad (if meta (modulo (- 8 (modulo len 8)) 8) 0)))
- `(load-program ,labels
- ,(+ len meta-pad)
- ,meta
- ,@code
- ,@(if meta
- (make-list meta-pad '(nop))
- '())))))
- (else
- (receive (subcode bindings source-alist label-alist arities)
- (glil->assembly (car body) bindings
- source-alist label-alist
- constants arities addr)
- (lp (cdr body) (cons subcode code)
- bindings source-alist label-alist arities
- (addr+ addr subcode)))))))))
-
-(define (compile-objtable constants table addr)
- (define (load-constant idx)
- (if (< idx 256)
- (values `((object-ref ,idx))
- 2)
- (values `((long-object-ref
- ,(quotient idx 256) ,(modulo idx 256)))
- 3)))
- (cond
- ((vlist-null? table)
- ;; Empty table; just return #f.
- (values '((make-false))
- (1+ addr)))
- (else
- (call-with-values
- (lambda ()
- (vhash-fold-right2
- (lambda (obj idx codes addr)
- (cond
- ((vhash-assoc obj constants)
- => (lambda (pair)
- (receive (load len) (load-constant (cdr pair))
- (values (cons load codes)
- (+ addr len)))))
- ((variable-cache-cell? obj)
- (cond
- ((vhash-assoc (variable-cache-cell-key obj) constants)
- => (lambda (pair)
- (receive (load len) (load-constant (cdr pair))
- (values (cons load codes)
- (+ addr len)))))
- (else (error "vcache cell key not in table" obj))))
- ((glil-program? obj)
- ;; Programs are not cached in the global constants
- ;; table because when a program is loaded, its module
- ;; is bound, and we want to do that only after any
- ;; preceding effectful statements.
- (let* ((table (build-object-table obj))
- (prog (compile-program obj table)))
- (receive (tablecode addr)
- (compile-objtable constants table addr)
- (let ((prog (align-program prog addr)))
- (values (cons `(,@tablecode ,@prog)
- codes)
- (addr+ addr prog))))))
- (else
- (error "unrecognized constant" obj))))
- table
- '(((make-false))) (1+ addr)))
- (lambda (elts addr)
- (let ((len (1+ (vlist-length table))))
- (values
- (fold append
- `((vector ,(quotient len 256) ,(modulo len 256)))
- elts)
- (+ addr 3))))))))
-
-(define (glil->assembly glil bindings source-alist label-alist
- constants arities addr)
- (define (emit-code x)
- (values x bindings source-alist label-alist arities))
- (define (emit-object-ref i)
- (values (if (< i 256)
- `((object-ref ,i))
- `((long-object-ref ,(quotient i 256) ,(modulo i 256))))
- bindings source-alist label-alist arities))
- (define (emit-code/arity x nreq nopt rest kw)
- (values x bindings source-alist label-alist
- (begin-arity addr (addr+ addr x) nreq nopt rest kw arities)))
-
- (record-case glil
- ((<glil-program> meta body)
- (cond
- ((vhash-assoc glil constants)
- ;; We are cached in someone's objtable; just emit a load.
- => (lambda (pair)
- (emit-object-ref (cdr pair))))
- (else
- ;; Otherwise, build an objtable for the program, compile it, and
- ;; emit a load-program.
- (let* ((table (build-object-table glil))
- (prog (compile-program glil table)))
- (receive (tablecode addr) (compile-objtable constants table addr)
- (emit-code `(,@tablecode ,@(align-program prog addr))))))))
-
- ((<glil-std-prelude> nreq nlocs else-label)
- (emit-code/arity
- (if (and (< nreq 8) (< nlocs (+ nreq 32)) (not else-label))
- `((assert-nargs-ee/locals ,(logior nreq (ash (- nlocs nreq) 3))))
- `(,(if else-label
- `(br-if-nargs-ne ,(quotient nreq 256)
- ,(modulo nreq 256)
- ,else-label)
- `(assert-nargs-ee ,(quotient nreq 256)
- ,(modulo nreq 256)))
- (reserve-locals ,(quotient nlocs 256)
- ,(modulo nlocs 256))))
- nreq #f #f #f))
-
- ((<glil-opt-prelude> nreq nopt rest nlocs else-label)
- (let ((bind-required
- (if else-label
- `((br-if-nargs-lt ,(quotient nreq 256)
- ,(modulo nreq 256)
- ,else-label))
- `((assert-nargs-ge ,(quotient nreq 256)
- ,(modulo nreq 256)))))
- (bind-optionals
- (if (zero? nopt)
- '()
- `((bind-optionals ,(quotient (+ nopt nreq) 256)
- ,(modulo (+ nreq nopt) 256)))))
- (bind-rest
- (cond
- (rest
- `((push-rest ,(quotient (+ nreq nopt) 256)
- ,(modulo (+ nreq nopt) 256))))
- (else
- (if else-label
- `((br-if-nargs-gt ,(quotient (+ nreq nopt) 256)
- ,(modulo (+ nreq nopt) 256)
- ,else-label))
- `((assert-nargs-ee ,(quotient (+ nreq nopt) 256)
- ,(modulo (+ nreq nopt) 256))))))))
- (emit-code/arity
- `(,@bind-required
- ,@bind-optionals
- ,@bind-rest
- (reserve-locals ,(quotient nlocs 256)
- ,(modulo nlocs 256)))
- nreq nopt rest #f)))
-
- ((<glil-kw-prelude> nreq nopt rest kw allow-other-keys? nlocs else-label)
- (let* ((kw-idx (or (and=> (vhash-assoc kw constants) cdr)
- (error "kw not in objtable")))
- (bind-required
- (if else-label
- `((br-if-nargs-lt ,(quotient nreq 256)
- ,(modulo nreq 256)
- ,else-label))
- `((assert-nargs-ge ,(quotient nreq 256)
- ,(modulo nreq 256)))))
- (ntotal (apply max (+ nreq nopt) (map 1+ (map cdr kw))))
- (bind-optionals-and-shuffle
- `((,(if (and else-label (not rest))
- 'bind-optionals/shuffle-or-br
- 'bind-optionals/shuffle)
- ,(quotient nreq 256)
- ,(modulo nreq 256)
- ,(quotient (+ nreq nopt) 256)
- ,(modulo (+ nreq nopt) 256)
- ,(quotient ntotal 256)
- ,(modulo ntotal 256)
- ,@(if (and else-label (not rest))
- `(,else-label)
- '()))))
- (bind-kw
- ;; when this code gets called, all optionals are filled
- ;; in, space has been made for kwargs, and the kwargs
- ;; themselves have been shuffled above the slots for all
- ;; req/opt/kwargs locals.
- `((bind-kwargs
- ,(quotient kw-idx 256)
- ,(modulo kw-idx 256)
- ,(quotient ntotal 256)
- ,(modulo ntotal 256)
- ,(logior (if rest 2 0)
- (if allow-other-keys? 1 0)))))
- (bind-rest
- (if rest
- `((bind-rest ,(quotient ntotal 256)
- ,(modulo ntotal 256)
- ,(quotient rest 256)
- ,(modulo rest 256)))
- '())))
-
- (let ((code `(,@bind-required
- ,@bind-optionals-and-shuffle
- ,@bind-kw
- ,@bind-rest
- (reserve-locals ,(quotient nlocs 256)
- ,(modulo nlocs 256)))))
- (values code bindings source-alist label-alist
- (begin-arity addr (addr+ addr code) nreq nopt rest
- (and kw (cons allow-other-keys? kw))
- arities)))))
-
- ((<glil-bind> vars)
- (values '()
- (open-binding bindings vars addr)
- source-alist
- label-alist
- arities))
-
- ((<glil-mv-bind> vars rest)
- (if (integer? vars)
- (values `((truncate-values ,vars ,(if rest 1 0)))
- bindings
- source-alist
- label-alist
- arities)
- (values `((truncate-values ,(length vars) ,(if rest 1 0)))
- (open-binding bindings vars addr)
- source-alist
- label-alist
- arities)))
-
- ((<glil-unbind>)
- (values '()
- (close-binding bindings addr)
- source-alist
- label-alist
- arities))
-
- ((<glil-source> props)
- (values '()
- bindings
- (acons addr props source-alist)
- label-alist
- arities))
-
- ((<glil-void>)
- (emit-code '((void))))
-
- ((<glil-const> obj)
- (cond
- ((object->assembly obj)
- => (lambda (code)
- (emit-code (list code))))
- ((vhash-assoc obj constants)
- => (lambda (pair)
- (emit-object-ref (cdr pair))))
- (else (error "const not in table" obj))))
-
- ((<glil-lexical> local? boxed? op index)
- (emit-code
- (if local?
- (if (< index 256)
- (case op
- ((ref) (if boxed?
- `((local-boxed-ref ,index))
- `((local-ref ,index))))
- ((set) (if boxed?
- `((local-boxed-set ,index))
- `((local-set ,index))))
- ((box) `((box ,index)))
- ((empty-box) `((empty-box ,index)))
- ((fix) `((fix-closure 0 ,index)))
- ((bound?) (if boxed?
- `((local-ref ,index)
- (variable-bound?))
- `((local-bound? ,index))))
- (else (error "what" op)))
- (let ((a (quotient index 256))
- (b (modulo index 256)))
- (case op
- ((ref)
- (if boxed?
- `((long-local-ref ,a ,b)
- (variable-ref))
- `((long-local-ref ,a ,b))))
- ((set)
- (if boxed?
- `((long-local-ref ,a ,b)
- (variable-set))
- `((long-local-set ,a ,b))))
- ((box)
- `((make-variable)
- (variable-set)
- (long-local-set ,a ,b)))
- ((empty-box)
- `((make-variable)
- (long-local-set ,a ,b)))
- ((fix)
- `((fix-closure ,a ,b)))
- ((bound?)
- (if boxed?
- `((long-local-ref ,a ,b)
- (variable-bound?))
- `((long-local-bound? ,a ,b))))
- (else (error "what" op)))))
- `((,(case op
- ((ref) (if boxed? 'free-boxed-ref 'free-ref))
- ((set) (if boxed? 'free-boxed-set (error "what." glil)))
- (else (error "what" op)))
- ,index)))))
-
- ((<glil-toplevel> op name)
- (case op
- ((ref set)
- (cond
- ((and=> (vhash-assoc (make-variable-cache-cell name) constants)
- cdr)
- => (lambda (i)
- (emit-code (if (< i 256)
- `((,(case op
- ((ref) 'toplevel-ref)
- ((set) 'toplevel-set))
- ,i))
- `((,(case op
- ((ref) 'long-toplevel-ref)
- ((set) 'long-toplevel-set))
- ,(quotient i 256)
- ,(modulo i 256)))))))
- (else
- (let ((i (or (and=> (vhash-assoc name constants) cdr)
- (error "toplevel name not in objtable" name))))
- (emit-code `(,(if (< i 256)
- `(object-ref ,i)
- `(long-object-ref ,(quotient i 256)
- ,(modulo i 256)))
- (link-now)
- ,(case op
- ((ref) '(variable-ref))
- ((set) '(variable-set)))))))))
- ((define)
- (let ((i (or (and=> (vhash-assoc name constants) cdr)
- (error "toplevel name not in objtable" name))))
- (emit-code `(,(if (< i 256)
- `(object-ref ,i)
- `(long-object-ref ,(quotient i 256)
- ,(modulo i 256)))
- (define)))))
- (else
- (error "unknown toplevel var kind" op name))))
-
- ((<glil-module> op mod name public?)
- (let ((key (list mod name public?)))
- (case op
- ((ref set)
- (let ((i (or (and=> (vhash-assoc (make-variable-cache-cell key)
- constants) cdr)
- (error "module vcache not in objtable" key))))
- (emit-code (if (< i 256)
- `((,(case op
- ((ref) 'toplevel-ref)
- ((set) 'toplevel-set))
- ,i))
- `((,(case op
- ((ref) 'long-toplevel-ref)
- ((set) 'long-toplevel-set))
- ,(quotient i 256)
- ,(modulo i 256)))))))
- (else
- (error "unknown module var kind" op key)))))
-
- ((<glil-label> label)
- (let ((code (align-block addr)))
- (values code
- bindings
- source-alist
- (acons label (addr+ addr code) label-alist)
- arities)))
-
- ((<glil-branch> inst label)
- (emit-code `((,inst ,label))))
-
- ;; nargs is number of stack args to insn. probably should rename.
- ((<glil-call> inst nargs)
- (if (not (instruction? inst))
- (error "Unknown instruction:" inst))
- (let ((pops (instruction-pops inst)))
- (cond ((< pops 0)
- (case (instruction-length inst)
- ((1) (emit-code `((,inst ,nargs))))
- ((2) (emit-code `((,inst ,(quotient nargs 256)
- ,(modulo nargs 256)))))
- (else (error "Unknown length for variable-arg instruction:"
- inst (instruction-length inst)))))
- ((= pops nargs)
- (emit-code `((,inst))))
- (else
- (error "Wrong number of stack arguments to instruction:" inst
nargs)))))
-
- ((<glil-mv-call> nargs ra)
- (emit-code `((mv-call ,nargs ,ra))))
-
- ((<glil-prompt> label escape-only?)
- (emit-code `((prompt ,(if escape-only? 1 0) ,label))))))
-
-(define (dump-object x addr)
- (define (too-long x)
- (error (string-append x " too long")))
-
- (cond
- ((object->assembly x) => list)
- ((variable-cache-cell? x) (dump-object (variable-cache-cell-key x) addr))
- ((number? x)
- `((load-number ,(number->string x))))
- ((string? x)
- (case (string-bytes-per-char x)
- ((1) `((load-string ,x)))
- ((4) (align-code `(load-wide-string ,x) addr 4 4))
- (else (error "bad string bytes per char" x))))
- ((symbol? x)
- (let ((str (symbol->string x)))
- (case (string-bytes-per-char str)
- ((1) `((load-symbol ,str)))
- ((4) `(,@(dump-object str addr)
- (make-symbol)))
- (else (error "bad string bytes per char" str)))))
- ((keyword? x)
- `(,@(dump-object (keyword->symbol x) addr)
- (make-keyword)))
- ((scheme-list? x)
- (let ((tail (let ((len (length x)))
- (if (>= len 65536) (too-long "list"))
- `((list ,(quotient len 256) ,(modulo len 256))))))
- (let dump-objects ((objects x) (codes '()) (addr addr))
- (if (null? objects)
- (fold append tail codes)
- (let ((code (dump-object (car objects) addr)))
- (dump-objects (cdr objects) (cons code codes)
- (addr+ addr code)))))))
- ((pair? x)
- (let ((kar (dump-object (car x) addr)))
- `(,@kar
- ,@(dump-object (cdr x) (addr+ addr kar))
- (cons))))
- ((and (vector? x)
- (equal? (array-shape x) (list (list 0 (1- (vector-length x))))))
- (let* ((len (vector-length x))
- (tail (if (>= len 65536)
- (too-long "vector")
- `((vector ,(quotient len 256) ,(modulo len 256))))))
- (let dump-objects ((i 0) (codes '()) (addr addr))
- (if (>= i len)
- (fold append tail codes)
- (let ((code (dump-object (vector-ref x i) addr)))
- (dump-objects (1+ i) (cons code codes)
- (addr+ addr code)))))))
- ((and (array? x) (symbol? (array-type x)))
- (let* ((type (dump-object (array-type x) addr))
- (shape (dump-object (array-shape x) (addr+ addr type))))
- `(,@type
- ,@shape
- ,@(align-code
- `(load-array ,(uniform-array->bytevector x))
- (addr+ (addr+ addr type) shape)
- 8
- 4))))
- ((array? x)
- ;; an array of generic scheme values
- (let* ((contents (array-contents x))
- (len (vector-length contents)))
- (let dump-objects ((i 0) (codes '()) (addr addr))
- (if (< i len)
- (let ((code (dump-object (vector-ref contents i) addr)))
- (dump-objects (1+ i) (cons code codes)
- (addr+ addr code)))
- (fold append
- `(,@(dump-object (array-shape x) addr)
- (make-array ,(quotient (ash len -16) 256)
- ,(logand #xff (ash len -8))
- ,(logand #xff len)))
- codes)))))
- (else
- (error "dump-object: unrecognized object" x))))
-
-(define (dump-constants constants)
- (define (ref-or-dump x i addr)
- (let ((pair (vhash-assoc x constants)))
- (if (and pair (< (cdr pair) i))
- (let ((idx (cdr pair)))
- (if (< idx 256)
- (values `((object-ref ,idx))
- (+ addr 2))
- (values `((long-object-ref ,(quotient idx 256)
- ,(modulo idx 256)))
- (+ addr 3))))
- (dump1 x i addr))))
- (define (dump1 x i addr)
- (cond
- ((object->assembly x)
- => (lambda (code)
- (values (list code)
- (+ (byte-length code) addr))))
- ((or (number? x)
- (string? x)
- (symbol? x)
- (keyword? x))
- ;; Atoms.
- (let ((code (dump-object x addr)))
- (values code (addr+ addr code))))
- ((variable-cache-cell? x)
- (dump1 (variable-cache-cell-key x) i addr))
- ((scheme-list? x)
- (receive (codes addr)
- (fold2 (lambda (x codes addr)
- (receive (subcode addr) (ref-or-dump x i addr)
- (values (cons subcode codes) addr)))
- x '() addr)
- (values (fold append
- (let ((len (length x)))
- `((list ,(quotient len 256) ,(modulo len 256))))
- codes)
- (+ addr 3))))
- ((pair? x)
- (receive (car-code addr) (ref-or-dump (car x) i addr)
- (receive (cdr-code addr) (ref-or-dump (cdr x) i addr)
- (values `(,@car-code ,@cdr-code (cons))
- (1+ addr)))))
- ((and (vector? x)
- (<= (vector-length x) #xffff)
- (equal? (array-shape x) (list (list 0 (1- (vector-length x))))))
- (receive (codes addr)
- (vector-fold2 (lambda (x codes addr)
- (receive (subcode addr) (ref-or-dump x i addr)
- (values (cons subcode codes) addr)))
- x '() addr)
- (values (fold append
- (let ((len (vector-length x)))
- `((vector ,(quotient len 256) ,(modulo len 256))))
- codes)
- (+ addr 3))))
- ((and (array? x) (symbol? (array-type x)))
- (receive (type addr) (ref-or-dump (array-type x) i addr)
- (receive (shape addr) (ref-or-dump (array-shape x) i addr)
- (let ((bv (align-code `(load-array ,(uniform-array->bytevector x))
- addr 8 4)))
- (values `(,@type ,@shape ,@bv)
- (addr+ addr bv))))))
- ((array? x)
- (let ((contents (array-contents x)))
- (receive (codes addr)
- (vector-fold2 (lambda (x codes addr)
- (receive (subcode addr) (ref-or-dump x i addr)
- (values (cons subcode codes) addr)))
- contents '() addr)
- (receive (shape addr) (ref-or-dump (array-shape x) i addr)
- (values (fold append
- (let ((len (vector-length contents)))
- `(,@shape
- (make-array ,(quotient (ash len -16) 256)
- ,(logand #xff (ash len -8))
- ,(logand #xff len))))
- codes)
- (+ addr 4))))))
- (else
- (error "write-table: unrecognized object" x))))
-
- (receive (codes addr)
- (vhash-fold-right2 (lambda (obj idx code addr)
- ;; The vector is on the stack. Dup it, push
- ;; the index, push the val, then vector-set.
- (let ((pre `((dup)
- ,(object->assembly idx))))
- (receive (valcode addr) (dump1 obj idx
- (addr+ addr pre))
- (values (cons* '((vector-set))
- valcode
- pre
- code)
- (1+ addr)))))
- constants
- '(((assert-nargs-ee/locals 1)
- ;; Push the vector.
- (local-ref 0)))
- 4)
- (let* ((len (1+ (vlist-length constants)))
- (pre-prog-addr (+ 2 ; reserve-locals
- len 3 ; empty vector
- 2 ; local-set
- 1 ; new-frame
- 2 ; local-ref
- ))
- (prog (align-program
- `(load-program ()
- ,(+ addr 1)
- #f
- ;; The `return' will be at the tail of the
- ;; program. The vector is already pushed
- ;; on the stack.
- . ,(fold append '((return)) codes))
- pre-prog-addr)))
- (values `(;; Reserve storage for the vector.
- (assert-nargs-ee/locals ,(logior 0 (ash 1 3)))
- ;; Push the vector, and store it in slot 0.
- ,@(make-list len '(make-false))
- (vector ,(quotient len 256) ,(modulo len 256))
- (local-set 0)
- ;; Now we open the call frame.
- ;;
- (new-frame)
- ;; Now build a thunk to init the constants. It will
- ;; have the unfinished constant table both as its
- ;; argument and as its objtable. The former allows it
- ;; to update the objtable, with vector-set!, and the
- ;; latter allows init code to refer to previously set
- ;; values.
- ;;
- ;; Grab the vector, to be the objtable.
- (local-ref 0)
- ;; Now the load-program, properly aligned. Pops the vector.
- ,@prog
- ;; Grab the vector, as an argument this time.
- (local-ref 0)
- ;; Call the init thunk with the vector as an arg.
- (call 1)
- ;; The thunk also returns the vector. Leave it on the
- ;; stack for compile-assembly to use.
- )
- ;; The byte length of the init code, which we can
- ;; determine without folding over the code again.
- (+ (addr+ pre-prog-addr prog) ; aligned program
- 2 ; local-ref
- 2 ; call
- )))))
diff --git a/module/language/glil/spec.scm b/module/language/glil/spec.scm
deleted file mode 100644
index 81e06af..0000000
--- a/module/language/glil/spec.scm
+++ /dev/null
@@ -1,40 +0,0 @@
-;;; Guile Lowlevel Intermediate Language
-
-;; Copyright (C) 2001, 2009, 2010, 2013 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
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Code:
-
-(define-module (language glil spec)
- #:use-module (system base language)
- #:use-module (language glil)
- #:use-module (language glil compile-assembly)
- #:export (glil))
-
-(define (write-glil exp . port)
- (apply write (unparse-glil exp) port))
-
-(define (compile-asm x e opts)
- (values (compile-assembly x) e e))
-
-(define-language glil
- #:title "Guile Lowlevel Intermediate Language (GLIL)"
- #:reader (lambda (port env) (read port))
- #:printer write-glil
- #:parser parse-glil
- #:compilers `((assembly . ,compile-asm))
- #:for-humans? #f
- )
diff --git a/module/language/objcode.scm b/module/language/objcode.scm
deleted file mode 100644
index d8bcda8..0000000
--- a/module/language/objcode.scm
+++ /dev/null
@@ -1,51 +0,0 @@
-;;; Guile Virtual Machine Object Code
-
-;; Copyright (C) 2001 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
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Code:
-
-(define-module (language objcode)
- #:export (encode-length decode-length))
-
-
-;;;
-;;; Variable-length interface
-;;;
-
-;; NOTE: decoded in vm_fetch_length in vm.c as well.
-
-(define (encode-length len)
- (cond ((< len 254) (u8vector len))
- ((< len (* 256 256))
- (u8vector 254 (quotient len 256) (modulo len 256)))
- ((< len most-positive-fixnum)
- (u8vector 255
- (quotient len (* 256 256 256))
- (modulo (quotient len (* 256 256)) 256)
- (modulo (quotient len 256) 256)
- (modulo len 256)))
- (else (error "Too long code length:" len))))
-
-(define (decode-length pop)
- (let ((x (pop)))
- (cond ((< x 254) x)
- ((= x 254) (+ (ash x 8) (pop)))
- (else
- (let* ((b2 (pop))
- (b3 (pop))
- (b4 (pop)))
- (+ (ash x 24) (ash b2 16) (ash b3 8) b4))))))
diff --git a/module/language/objcode/elf.scm b/module/language/objcode/elf.scm
deleted file mode 100644
index ddbd7b2..0000000
--- a/module/language/objcode/elf.scm
+++ /dev/null
@@ -1,92 +0,0 @@
-;;; Embedding bytecode in ELF
-
-;; Copyright (C) 2012, 2013 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
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Code:
-
-;; The eval-when is because (language objcode elf) will not be loaded
-;; yet when we go to compile it, but later passes of the
-;; compiler need it. So we have to be sure that the module is present
-;; at compile time, with all of its definitions. The easiest way to do
-;; that is just to go ahead and resolve it now.
-;;
-(define-module (language objcode elf)
- #:use-module (system vm objcode)
- #:use-module (system base target)
- #:use-module (rnrs bytevectors)
- #:use-module (ice-9 binary-ports)
- #:use-module (system vm elf)
- #:use-module (system vm linker)
- #:export (write-objcode))
-
-(define (bytecode->elf bv)
- (let ((string-table (make-string-table)))
- (define (intern-string! string)
- (string-table-intern! string-table string))
- (define (make-object index name bv relocs . kwargs)
- (let ((name-idx (intern-string! (symbol->string name))))
- (make-linker-object (apply make-elf-section
- #:index index
- #:name name-idx
- #:size (bytevector-length bv)
- kwargs)
- bv relocs
- (list (make-linker-symbol name 0)))))
- (define (make-dynamic-section index word-size endianness)
- (define (make-dynamic-section/32)
- (let ((bv (make-bytevector 24 0)))
- (bytevector-u32-set! bv 0 DT_GUILE_RTL_VERSION endianness)
- (bytevector-u32-set! bv 4 #x02000000 endianness)
- (bytevector-u32-set! bv 8 DT_GUILE_ENTRY endianness)
- (bytevector-u32-set! bv 12 0 endianness)
- (bytevector-u32-set! bv 16 DT_NULL endianness)
- (bytevector-u32-set! bv 20 0 endianness)
- (values bv (make-linker-reloc 'abs32/1 12 0 '.rtl-text))))
- (define (make-dynamic-section/64)
- (let ((bv (make-bytevector 48 0)))
- (bytevector-u64-set! bv 0 DT_GUILE_RTL_VERSION endianness)
- (bytevector-u64-set! bv 8 #x02000000 endianness)
- (bytevector-u64-set! bv 16 DT_GUILE_ENTRY endianness)
- (bytevector-u64-set! bv 24 0 endianness)
- (bytevector-u64-set! bv 32 DT_NULL endianness)
- (bytevector-u64-set! bv 40 0 endianness)
- (values bv (make-linker-reloc 'abs64/1 24 0 '.rtl-text))))
- (call-with-values (lambda ()
- (case word-size
- ((4) (make-dynamic-section/32))
- ((8) (make-dynamic-section/64))
- (else (error "unexpected word size" word-size))))
- (lambda (bv reloc)
- (make-object index '.dynamic bv (list reloc)
- #:type SHT_DYNAMIC #:flags SHF_ALLOC))))
- (define (make-string-table index)
- (intern-string! ".shstrtab")
- (make-object index '.shstrtab (link-string-table! string-table) '()
- #:type SHT_STRTAB #:flags 0))
- (let* ((word-size (target-word-size))
- (endianness (target-endianness))
- (text (make-object 1 '.rtl-text bv '()))
- (dt (make-dynamic-section 2 word-size endianness))
- ;; This needs to be linked last, because linking other
- ;; sections adds entries to the string table.
- (shstrtab (make-string-table 3)))
- (link-elf (list text dt shstrtab)
- #:endianness endianness #:word-size word-size))))
-
-(define (write-objcode objcode port)
- (let ((bv (objcode->bytecode objcode (target-endianness))))
- (put-bytevector port (bytecode->elf bv))))
diff --git a/module/language/objcode/spec.scm b/module/language/objcode/spec.scm
deleted file mode 100644
index 16f5241..0000000
--- a/module/language/objcode/spec.scm
+++ /dev/null
@@ -1,84 +0,0 @@
-;;; Guile Lowlevel Intermediate Language
-
-;; Copyright (C) 2001, 2009, 2010, 2011, 2013 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
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Code:
-
-(define-module (language objcode spec)
- #:use-module (system base language)
- #:use-module (system vm objcode)
- #:use-module (system vm program)
- #:use-module (language objcode elf)
- #:export (objcode))
-
-(define (objcode->value x e opts)
- (let ((thunk (make-program x #f #f)))
- (if (eq? e (current-module))
- ;; save a cons in this case
- (values (thunk) e e)
- (save-module-excursion
- (lambda ()
- (set-current-module e)
- (values (thunk) e e))))))
-
-;; since locals are allocated on the stack and can have limited scope,
-;; in many cases we use one local for more than one lexical variable. so
-;; the returned locals set is a list, where element N of the list is
-;; itself a list of bindings for local variable N.
-(define (collapse-locals locs)
- (let lp ((ret '()) (locs locs))
- (if (null? locs)
- (map cdr (sort! ret
- (lambda (x y) (< (car x) (car y)))))
- (let ((b (car locs)))
- (cond
- ((assv-ref ret (binding:index b))
- => (lambda (bindings)
- (append! bindings (list b))
- (lp ret (cdr locs))))
- (else
- (lp (acons (binding:index b) (list b) ret)
- (cdr locs))))))))
-
-(define (decompile-value x env opts)
- (cond
- ((program? x)
- (let ((objs (program-objects x))
- (meta (program-meta x))
- (free-vars (program-free-variables x))
- (binds (program-bindings x))
- (srcs (program-sources x)))
- (let ((blocs (and binds (collapse-locals binds))))
- (values (program-objcode x)
- `((objects . ,objs)
- (meta . ,(and meta (meta)))
- (free-vars . ,free-vars)
- (blocs . ,blocs)
- (sources . ,srcs))))))
- ((objcode? x)
- (values x #f))
- (else
- (error "Object for disassembly not a program or objcode" x))))
-
-(define-language objcode
- #:title "Guile Object Code"
- #:reader #f
- #:printer write-objcode
- #:compilers `((value . ,objcode->value))
- #:decompilers `((value . ,decompile-value))
- #:for-humans? #f
- )
diff --git a/module/language/tree-il/compile-glil.scm
b/module/language/tree-il/compile-glil.scm
deleted file mode 100644
index 60df245..0000000
--- a/module/language/tree-il/compile-glil.scm
+++ /dev/null
@@ -1,1052 +0,0 @@
-;;; TREE-IL -> GLIL compiler
-
-;; Copyright (C) 2001,2008,2009,2010,2011,2012,2013 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
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Code:
-
-(define-module (language tree-il compile-glil)
- #:use-module (system base syntax)
- #:use-module (system base pmatch)
- #:use-module (system base message)
- #:use-module (ice-9 receive)
- #:use-module (ice-9 match)
- #:use-module (language glil)
- #:use-module (system vm instruction)
- #:use-module (language tree-il)
- #:use-module (language tree-il optimize)
- #:use-module (language tree-il canonicalize)
- #:use-module (language tree-il analyze)
- #:use-module ((srfi srfi-1) #:select (filter-map))
- #:export (compile-glil))
-
-;; allocation:
-;; sym -> {lambda -> address}
-;; lambda -> (labels . free-locs)
-;; lambda-case -> (gensym . nlocs)
-;;
-;; address ::= (local? boxed? . index)
-;; labels ::= ((sym . lambda) ...)
-;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
-;; free variable addresses are relative to parent proc.
-
-(define *comp-module* (make-fluid))
-
-(define %warning-passes
- `((unused-variable . ,unused-variable-analysis)
- (unused-toplevel . ,unused-toplevel-analysis)
- (unbound-variable . ,unbound-variable-analysis)
- (arity-mismatch . ,arity-analysis)
- (format . ,format-analysis)))
-
-(define (compile-glil x e opts)
- (define warnings
- (or (and=> (memq #:warnings opts) cadr)
- '()))
-
- ;; Go through the warning passes.
- (let ((analyses (filter-map (lambda (kind)
- (assoc-ref %warning-passes kind))
- warnings)))
- (analyze-tree analyses x e))
-
- (let* ((x (make-lambda (tree-il-src x) '()
- (make-lambda-case #f '() #f #f #f '() '() x #f)))
- (x (optimize x e opts))
- (x (canonicalize x))
- (allocation (analyze-lexicals x)))
-
- (with-fluids ((*comp-module* e))
- (values (flatten-lambda x #f allocation)
- e
- e))))
-
-
-
-(define *primcall-ops* (make-hash-table))
-(for-each
- (lambda (x) (hash-set! *primcall-ops* (car x) (cdr x)))
- '(((eq? . 2) . eq?)
- ((eqv? . 2) . eqv?)
- ((equal? . 2) . equal?)
- ((= . 2) . ee?)
- ((< . 2) . lt?)
- ((> . 2) . gt?)
- ((<= . 2) . le?)
- ((>= . 2) . ge?)
- ((+ . 2) . add)
- ((- . 2) . sub)
- ((1+ . 1) . add1)
- ((1- . 1) . sub1)
- ((* . 2) . mul)
- ((/ . 2) . div)
- ((quotient . 2) . quo)
- ((remainder . 2) . rem)
- ((modulo . 2) . mod)
- ((ash . 2) . ash)
- ((logand . 2) . logand)
- ((logior . 2) . logior)
- ((logxor . 2) . logxor)
- ((not . 1) . not)
- ((pair? . 1) . pair?)
- ((cons . 2) . cons)
- ((car . 1) . car)
- ((cdr . 1) . cdr)
- ((set-car! . 2) . set-car!)
- ((set-cdr! . 2) . set-cdr!)
- ((null? . 1) . null?)
- ((list? . 1) . list?)
- ((symbol? . 1) . symbol?)
- ((vector? . 1) . vector?)
- ((nil? . 1) . nil?)
- (list . list)
- (vector . vector)
- ((class-of . 1) . class-of)
- ((fluid-ref . 1) . fluid-ref)
- ((fluid-set! . 2) . fluid-set)
- ((@slot-ref . 2) . slot-ref)
- ((@slot-set! . 3) . slot-set)
- ((string-length . 1) . string-length)
- ((string-ref . 2) . string-ref)
- ((vector-length . 1) . vector-length)
- ((vector-ref . 2) . vector-ref)
- ((vector-set! . 3) . vector-set)
- ((variable-ref . 1) . variable-ref)
- ;; nb, *not* variable-set! -- the args are switched
- ((variable-bound? . 1) . variable-bound?)
- ((struct? . 1) . struct?)
- ((struct-vtable . 1) . struct-vtable)
- ((struct-ref . 2) . struct-ref)
- ((struct-set! . 3) . struct-set)
- (make-struct/no-tail . make-struct)
-
- ;; hack for javascript
- ((return . 1) . return)
- ;; hack for lua
- (return/values . return/values)
-
- ((wind . 2) . wind)
- ((unwind . 0) . unwind)
- ((push-fluid . 2) . push-fluid)
- ((pop-fluid . 0) . pop-fluid)
-
- ((bytevector-u8-ref . 2) . bv-u8-ref)
- ((bytevector-u8-set! . 3) . bv-u8-set)
- ((bytevector-s8-ref . 2) . bv-s8-ref)
- ((bytevector-s8-set! . 3) . bv-s8-set)
-
- ((bytevector-u16-ref . 3) . bv-u16-ref)
- ((bytevector-u16-set! . 4) . bv-u16-set)
- ((bytevector-u16-native-ref . 2) . bv-u16-native-ref)
- ((bytevector-u16-native-set! . 3) . bv-u16-native-set)
- ((bytevector-s16-ref . 3) . bv-s16-ref)
- ((bytevector-s16-set! . 4) . bv-s16-set)
- ((bytevector-s16-native-ref . 2) . bv-s16-native-ref)
- ((bytevector-s16-native-set! . 3) . bv-s16-native-set)
-
- ((bytevector-u32-ref . 3) . bv-u32-ref)
- ((bytevector-u32-set! . 4) . bv-u32-set)
- ((bytevector-u32-native-ref . 2) . bv-u32-native-ref)
- ((bytevector-u32-native-set! . 3) . bv-u32-native-set)
- ((bytevector-s32-ref . 3) . bv-s32-ref)
- ((bytevector-s32-set! . 4) . bv-s32-set)
- ((bytevector-s32-native-ref . 2) . bv-s32-native-ref)
- ((bytevector-s32-native-set! . 3) . bv-s32-native-set)
-
- ((bytevector-u64-ref . 3) . bv-u64-ref)
- ((bytevector-u64-set! . 4) . bv-u64-set)
- ((bytevector-u64-native-ref . 2) . bv-u64-native-ref)
- ((bytevector-u64-native-set! . 3) . bv-u64-native-set)
- ((bytevector-s64-ref . 3) . bv-s64-ref)
- ((bytevector-s64-set! . 4) . bv-s64-set)
- ((bytevector-s64-native-ref . 2) . bv-s64-native-ref)
- ((bytevector-s64-native-set! . 3) . bv-s64-native-set)
-
- ((bytevector-ieee-single-ref . 3) . bv-f32-ref)
- ((bytevector-ieee-single-set! . 4) . bv-f32-set)
- ((bytevector-ieee-single-native-ref . 2) . bv-f32-native-ref)
- ((bytevector-ieee-single-native-set! . 3) . bv-f32-native-set)
- ((bytevector-ieee-double-ref . 3) . bv-f64-ref)
- ((bytevector-ieee-double-set! . 4) . bv-f64-set)
- ((bytevector-ieee-double-native-ref . 2) . bv-f64-native-ref)
- ((bytevector-ieee-double-native-set! . 3) . bv-f64-native-set)))
-
-
-
-
-(define (make-label) (gensym ":L"))
-
-(define (vars->bind-list ids vars allocation proc)
- (map (lambda (id v)
- (pmatch (hashq-ref (hashq-ref allocation v) proc)
- ((#t ,boxed? . ,n)
- (list id boxed? n))
- (,x (error "bad var list element" id v x))))
- ids
- vars))
-
-(define (emit-bindings src ids vars allocation proc emit-code)
- (emit-code src (make-glil-bind
- (vars->bind-list ids vars allocation proc))))
-
-(define (with-output-to-code proc)
- (let ((out '()))
- (define (emit-code src x)
- (set! out (cons x out))
- (if src
- (set! out (cons (make-glil-source src) out))))
- (proc emit-code)
- (reverse out)))
-
-(define (flatten-lambda x self-label allocation)
- (record-case x
- ((<lambda> src meta body)
- (make-glil-program
- meta
- (with-output-to-code
- (lambda (emit-code)
- ;; write source info for proc
- (if src (emit-code #f (make-glil-source src)))
- ;; compile the body, yo
- (flatten-lambda-case body allocation x self-label
- (car (hashq-ref allocation x))
- emit-code)))))))
-
-(define (flatten-lambda-case lcase allocation self self-label fix-labels
- emit-code)
- (define (emit-label label)
- (emit-code #f (make-glil-label label)))
- (define (emit-branch src inst label)
- (emit-code src (make-glil-branch inst label)))
-
- ;; RA: "return address"; #f unless we're in a non-tail fix with labels
- ;; MVRA: "multiple-values return address"; #f unless we're in a let-values
- (let comp ((x lcase) (context 'tail) (RA #f) (MVRA #f))
- (define (comp-tail tree) (comp tree context RA MVRA))
- (define (comp-push tree) (comp tree 'push #f #f))
- (define (comp-drop tree) (comp tree 'drop #f #f))
- (define (comp-vals tree MVRA) (comp tree 'vals #f MVRA))
- (define (comp-fix tree RA) (comp tree context RA MVRA))
-
- ;; A couple of helpers. Note that if we are in tail context, we
- ;; won't have an RA.
- (define (maybe-emit-return)
- (if RA
- (emit-branch #f 'br RA)
- (if (eq? context 'tail)
- (emit-code #f (make-glil-call 'return 1)))))
-
- ;; After lexical binding forms in non-tail context, call this
- ;; function to clear stack slots, allowing their previous values to
- ;; be collected.
- (define (clear-stack-slots context syms)
- (case context
- ((push drop)
- (for-each (lambda (v)
- (and=>
- ;; Can be #f if the var is labels-allocated.
- (hashq-ref allocation v)
- (lambda (h)
- (pmatch (hashq-ref h self)
- ((#t _ . ,n)
- (emit-code #f (make-glil-void))
- (emit-code #f (make-glil-lexical #t #f 'set n)))
- (,loc (error "bad let var allocation" x loc))))))
- syms))))
-
- (record-case x
- ((<void>)
- (case context
- ((push vals tail)
- (emit-code #f (make-glil-void))))
- (maybe-emit-return))
-
- ((<const> src exp)
- (case context
- ((push vals tail)
- (emit-code src (make-glil-const exp))))
- (maybe-emit-return))
-
- ((<seq> head tail)
- (comp-drop head)
- (comp-tail tail))
-
- ((<call> src proc args)
- (cond
- ;; call to the same lambda-case in tail position
- ((and (lexical-ref? proc)
- self-label (eq? (lexical-ref-gensym proc) self-label)
- (eq? context 'tail)
- (not (lambda-case-kw lcase))
- (not (lambda-case-rest lcase))
- (= (length args)
- (+ (length (lambda-case-req lcase))
- (or (and=> (lambda-case-opt lcase) length) 0))))
- (for-each comp-push args)
- (for-each (lambda (sym)
- (pmatch (hashq-ref (hashq-ref allocation sym) self)
- ((#t #f . ,index) ; unboxed
- (emit-code #f (make-glil-lexical #t #f 'set index)))
- ((#t #t . ,index) ; boxed
- ;; new box
- (emit-code #f (make-glil-lexical #t #t 'box index)))
- (,x (error "bad lambda-case arg allocation" x))))
- (reverse (lambda-case-gensyms lcase)))
- (emit-branch src 'br (car (hashq-ref allocation lcase))))
-
- ;; lambda, the ultimate goto
- ((and (lexical-ref? proc)
- (assq (lexical-ref-gensym proc) fix-labels))
- ;; like the self-tail-call case, though we can handle "drop"
- ;; contexts too. first, evaluate new values, pushing them on
- ;; the stack
- (for-each comp-push args)
- ;; find the specific case, rename args, and goto the case label
- (let lp ((lcase (lambda-body
- (assq-ref fix-labels (lexical-ref-gensym proc)))))
- (cond
- ((and (lambda-case? lcase)
- (not (lambda-case-kw lcase))
- (not (lambda-case-opt lcase))
- (not (lambda-case-rest lcase))
- (= (length args) (length (lambda-case-req lcase))))
- ;; we have a case that matches the args; rename variables
- ;; and goto the case label
- (for-each (lambda (sym)
- (pmatch (hashq-ref (hashq-ref allocation sym) self)
- ((#t #f . ,index) ; unboxed
- (emit-code #f (make-glil-lexical #t #f 'set
index)))
- ((#t #t . ,index) ; boxed
- (emit-code #f (make-glil-lexical #t #t 'box
index)))
- (,x (error "bad lambda-case arg allocation" x))))
- (reverse (lambda-case-gensyms lcase)))
- (emit-branch src 'br (car (hashq-ref allocation lcase))))
- ((lambda-case? lcase)
- ;; no match, try next case
- (lp (lambda-case-alternate lcase)))
- (else
- ;; no cases left. we can't really handle this currently.
- ;; ideally we would push on a new frame, then do a "local
- ;; call" -- which doesn't require consing up a program
- ;; object. but for now error, as this sort of case should
- ;; preclude label allocation.
- (error "couldn't find matching case for label call" x)))))
-
- (else
- (if (not (eq? context 'tail))
- (emit-code src (make-glil-call 'new-frame 0)))
- (comp-push proc)
- (for-each comp-push args)
- (let ((len (length args)))
- (case context
- ((tail) (if (<= len #xff)
- (emit-code src (make-glil-call 'tail-call len))
- (begin
- (comp-push (make-const #f len))
- (emit-code src (make-glil-call 'tail-call/nargs
0)))))
- ((push) (if (<= len #xff)
- (emit-code src (make-glil-call 'call len))
- (begin
- (comp-push (make-const #f len))
- (emit-code src (make-glil-call 'call/nargs 0))))
- (maybe-emit-return))
- ;; FIXME: mv-call doesn't have a /nargs variant, so it is
- ;; limited to 255 args. Can work around it with a
- ;; trampoline and tail-call/nargs, but it's not so nice.
- ((vals) (emit-code src (make-glil-mv-call len MVRA))
- (maybe-emit-return))
- ((drop) (let ((MV (make-label)) (POST (make-label)))
- (emit-code src (make-glil-mv-call len MV))
- (emit-code #f (make-glil-call 'drop 1))
- (emit-branch #f 'br (or RA POST))
- (emit-label MV)
- (emit-code #f (make-glil-mv-bind 0 #f))
- (if RA
- (emit-branch #f 'br RA)
- (emit-label POST)))))))))
-
- ((<primcall> src name args)
- (pmatch (cons name args)
- ((apply ,proc . ,args)
- (cond
- ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
- (not (eq? context 'push)) (not (eq? context 'vals)))
- ;; tail: (lambda () (apply values '(1 2)))
- ;; drop: (lambda () (apply values '(1 2)) 3)
- ;; push: (lambda () (list (apply values '(10 12)) 1))
- (case context
- ((drop) (for-each comp-drop args) (maybe-emit-return))
- ((tail)
- (for-each comp-push args)
- (emit-code src (make-glil-call 'return/values* (length
args))))))
-
- (else
- (case context
- ((tail)
- (comp-push proc)
- (for-each comp-push args)
- (emit-code src (make-glil-call 'tail-apply (1+ (length args)))))
- ((push)
- (emit-code src (make-glil-call 'new-frame 0))
- (comp-push proc)
- (for-each comp-push args)
- (emit-code src (make-glil-call 'apply (1+ (length args))))
- (maybe-emit-return))
- (else
- (comp-tail (make-call src (make-primitive-ref #f 'apply)
- (cons proc args))))))))
-
- ((values . _)
- ;; tail: (lambda () (values '(1 2)))
- ;; drop: (lambda () (values '(1 2)) 3)
- ;; push: (lambda () (list (values '(10 12)) 1))
- ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
- (case context
- ((drop) (for-each comp-drop args) (maybe-emit-return))
- ((push)
- (case (length args)
- ((0)
- ;; FIXME: This is surely an error. We need to add a
- ;; values-mismatch warning pass.
- (comp-push (make-call src (make-primitive-ref #f 'values)
- '())))
- (else
- ;; Taking advantage of unspecified order of evaluation of
- ;; arguments.
- (for-each comp-drop (cdr args))
- (comp-push (car args))
- (maybe-emit-return))))
- ((vals)
- (for-each comp-push args)
- (emit-code #f (make-glil-const (length args)))
- (emit-branch src 'br MVRA))
- ((tail)
- (for-each comp-push args)
- (emit-code src (let ((len (length args)))
- (if (= len 1)
- (make-glil-call 'return 1)
- (make-glil-call 'return/values len)))))))
-
- ((call-with-values ,producer ,consumer)
- ;; CONSUMER
- ;; PRODUCER
- ;; (mv-call MV)
- ;; ([tail]-call 1)
- ;; goto POST
- ;; MV: [tail-]call/nargs
- ;; POST: (maybe-drop)
- (case context
- ((vals)
- ;; Fall back.
- (comp-tail
- (make-call src (make-toplevel-ref #f 'call-with-values) args)))
- (else
- (let ((MV (make-label)) (POST (make-label)))
- (if (not (eq? context 'tail))
- (emit-code src (make-glil-call 'new-frame 0)))
- (comp-push consumer)
- (emit-code src (make-glil-call 'new-frame 0))
- (comp-push producer)
- (emit-code src (make-glil-mv-call 0 MV))
- (case context
- ((tail) (emit-code src (make-glil-call 'tail-call 1)))
- (else (emit-code src (make-glil-call 'call 1))
- (emit-branch #f 'br POST)))
- (emit-label MV)
- (case context
- ((tail) (emit-code src (make-glil-call 'tail-call/nargs 0)))
- (else (emit-code src (make-glil-call 'call/nargs 0))
- (emit-label POST)
- (if (eq? context 'drop)
- (emit-code #f (make-glil-call 'drop 1)))
- (maybe-emit-return)))))))
-
- ((call-with-current-continuation ,proc)
- (case context
- ((tail)
- (comp-push proc)
- (emit-code src (make-glil-call 'tail-call/cc 1)))
- ((vals)
- (comp-vals
- (make-call src
- (make-primitive-ref #f
'call-with-current-continuation)
- args)
- MVRA)
- (maybe-emit-return))
- ((push)
- (comp-push proc)
- (emit-code src (make-glil-call 'call/cc 1))
- (maybe-emit-return))
- ((drop)
- ;; Fall back.
- (comp-tail
- (make-call src
- (make-primitive-ref #f
'call-with-current-continuation)
- args)))))
-
- ;; A hack for variable-set, the opcode for which takes its args
- ;; reversed, relative to the variable-set! function
- ((variable-set! ,var ,val)
- (comp-push val)
- (comp-push var)
- (emit-code src (make-glil-call 'variable-set 2))
- (case context
- ((tail push vals) (emit-code #f (make-glil-void))))
- (maybe-emit-return))
-
- (else
- (cond
- ((or (hash-ref *primcall-ops* (cons name (length args)))
- (hash-ref *primcall-ops* name))
- => (lambda (op)
- (for-each comp-push args)
- (emit-code src (make-glil-call op (length args)))
- (case (instruction-pushes op)
- ((0)
- (case context
- ((tail push vals) (emit-code #f (make-glil-void))))
- (maybe-emit-return))
- ((1)
- (case context
- ((drop) (emit-code #f (make-glil-call 'drop 1))))
- (maybe-emit-return))
- ((-1)
- ;; A control instruction, like return/values. Here we
- ;; just have to hope that the author of the tree-il
- ;; knew what they were doing.
- *unspecified*)
- (else
- (error "bad primitive op: too many pushes"
- op (instruction-pushes op))))))
- (else
- ;; Fall back to the normal compilation strategy.
- (comp-tail (make-call src (make-primitive-ref #f name) args)))))))
-
- ((<conditional> src test consequent alternate)
- ;; TEST
- ;; (br-if-not L1)
- ;; consequent
- ;; (br L2)
- ;; L1: alternate
- ;; L2:
- (let ((L1 (make-label)) (L2 (make-label)))
- (record-case test
- ((<primcall> name args)
- (pmatch (cons name args)
- ((eq? ,a ,b)
- (comp-push a)
- (comp-push b)
- (emit-branch src 'br-if-not-eq L1))
- ((null? ,x)
- (comp-push x)
- (emit-branch src 'br-if-not-null L1))
- ((nil? ,x)
- (comp-push x)
- (emit-branch src 'br-if-not-nil L1))
- ((not ,x)
- (record-case x
- ((<primcall> name args)
- (pmatch (cons name args)
- ((eq? ,a ,b)
- (comp-push a)
- (comp-push b)
- (emit-branch src 'br-if-eq L1))
- ((null? ,x)
- (comp-push x)
- (emit-branch src 'br-if-null L1))
- ((nil? ,x)
- (comp-push x)
- (emit-branch src 'br-if-nil L1))
- (else
- (comp-push x)
- (emit-branch src 'br-if L1))))
- (else
- (comp-push x)
- (emit-branch src 'br-if L1))))
- (else
- (comp-push test)
- (emit-branch src 'br-if-not L1))))
- (else
- (comp-push test)
- (emit-branch src 'br-if-not L1)))
-
- (comp-tail consequent)
- ;; if there is an RA, comp-tail will cause a jump to it -- just
- ;; have to clean up here if there is no RA.
- (if (and (not RA) (not (eq? context 'tail)))
- (emit-branch #f 'br L2))
- (emit-label L1)
- (comp-tail alternate)
- (if (and (not RA) (not (eq? context 'tail)))
- (emit-label L2))))
-
- ((<primitive-ref> src name)
- (cond
- ((eq? (fluid-ref *comp-module*) the-root-module)
- (case context
- ((tail push vals)
- (emit-code src (make-glil-toplevel 'ref name))))
- (maybe-emit-return))
- ((module-variable the-root-module name)
- (case context
- ((tail push vals)
- (emit-code src (make-glil-module 'ref '(guile) name #f))))
- (maybe-emit-return))
- (else
- (case context
- ((tail push vals)
- (emit-code src (make-glil-module
- 'ref (module-name (fluid-ref *comp-module*)) name
#f))))
- (maybe-emit-return))))
-
- ((<lexical-ref> src gensym)
- (case context
- ((push vals tail)
- (pmatch (hashq-ref (hashq-ref allocation gensym) self)
- ((,local? ,boxed? . ,index)
- (emit-code src (make-glil-lexical local? boxed? 'ref index)))
- (,loc
- (error "bad lexical allocation" x loc)))))
- (maybe-emit-return))
-
- ((<lexical-set> src gensym exp)
- (comp-push exp)
- (pmatch (hashq-ref (hashq-ref allocation gensym) self)
- ((,local? ,boxed? . ,index)
- (emit-code src (make-glil-lexical local? boxed? 'set index)))
- (,loc
- (error "bad lexical allocation" x loc)))
- (case context
- ((tail push vals)
- (emit-code #f (make-glil-void))))
- (maybe-emit-return))
-
- ((<module-ref> src mod name public?)
- (emit-code src (make-glil-module 'ref mod name public?))
- (case context
- ((drop) (emit-code #f (make-glil-call 'drop 1))))
- (maybe-emit-return))
-
- ((<module-set> src mod name public? exp)
- (comp-push exp)
- (emit-code src (make-glil-module 'set mod name public?))
- (case context
- ((tail push vals)
- (emit-code #f (make-glil-void))))
- (maybe-emit-return))
-
- ((<toplevel-ref> src name)
- (emit-code src (make-glil-toplevel 'ref name))
- (case context
- ((drop) (emit-code #f (make-glil-call 'drop 1))))
- (maybe-emit-return))
-
- ((<toplevel-set> src name exp)
- (comp-push exp)
- (emit-code src (make-glil-toplevel 'set name))
- (case context
- ((tail push vals)
- (emit-code #f (make-glil-void))))
- (maybe-emit-return))
-
- ((<toplevel-define> src name exp)
- (comp-push exp)
- (emit-code src (make-glil-toplevel 'define name))
- (case context
- ((tail push vals)
- (emit-code #f (make-glil-void))))
- (maybe-emit-return))
-
- ((<lambda>)
- (let ((free-locs (cdr (hashq-ref allocation x))))
- (case context
- ((push vals tail)
- (emit-code #f (flatten-lambda x #f allocation))
- (if (not (null? free-locs))
- (begin
- (for-each
- (lambda (loc)
- (pmatch loc
- ((,local? ,boxed? . ,n)
- (emit-code #f (make-glil-lexical local? #f 'ref n)))
- (else (error "bad lambda free var allocation" x loc))))
- free-locs)
- (emit-code #f (make-glil-call 'make-closure
- (length free-locs))))))))
- (maybe-emit-return))
-
- ((<lambda-case> src req opt rest kw inits gensyms alternate body)
- ;; o/~ feature on top of feature o/~
- ;; req := (name ...)
- ;; opt := (name ...) | #f
- ;; rest := name | #f
- ;; kw: (allow-other-keys? (keyword name var) ...) | #f
- ;; gensyms: (sym ...)
- ;; init: tree-il in context of gensyms
- ;; gensyms map to named arguments in the following order:
- ;; required, optional (positional), rest, keyword.
- (let* ((nreq (length req))
- (nopt (if opt (length opt) 0))
- (rest-idx (and rest (+ nreq nopt)))
- (opt-names (or opt '()))
- (allow-other-keys? (if kw (car kw) #f))
- (kw-indices (map (lambda (x)
- (pmatch x
- ((,key ,name ,var)
- (cons key (list-index gensyms var)))
- (else (error "bad kwarg" x))))
- (if kw (cdr kw) '())))
- (nargs (apply max (+ nreq nopt (if rest 1 0))
- (map 1+ (map cdr kw-indices))))
- (nlocs (cdr (hashq-ref allocation x)))
- (alternate-label (and alternate (make-label))))
- (or (= nargs
- (length gensyms)
- (+ nreq (length inits) (if rest 1 0)))
- (error "lambda-case gensyms don't correspond to args"
- req opt rest kw inits gensyms nreq nopt kw-indices nargs))
- ;; the prelude, to check args & reset the stack pointer,
- ;; allowing room for locals
- (emit-code
- src
- (cond
- (kw
- (make-glil-kw-prelude nreq nopt rest-idx kw-indices
- allow-other-keys? nlocs alternate-label))
- ((or rest opt)
- (make-glil-opt-prelude nreq nopt rest-idx nlocs alternate-label))
- (#t
- (make-glil-std-prelude nreq nlocs alternate-label))))
- ;; box args if necessary
- (for-each
- (lambda (v)
- (pmatch (hashq-ref (hashq-ref allocation v) self)
- ((#t #t . ,n)
- (emit-code #f (make-glil-lexical #t #f 'ref n))
- (emit-code #f (make-glil-lexical #t #t 'box n)))))
- gensyms)
- ;; write bindings info
- (if (not (null? gensyms))
- (emit-bindings
- #f
- (let lp ((kw (if kw (cdr kw) '()))
- (names (append (reverse opt-names) (reverse req)))
- (gensyms (list-tail gensyms (+ nreq nopt
- (if rest 1 0)))))
- (pmatch kw
- (()
- ;; fixme: check that gensyms is empty
- (reverse (if rest (cons rest names) names)))
- (((,key ,name ,var) . ,kw)
- (if (memq var gensyms)
- (lp kw (cons name names) (delq var gensyms))
- (lp kw names gensyms)))
- (,kw (error "bad keywords, yo" kw))))
- gensyms allocation self emit-code))
- ;; init optional/kw args
- (let lp ((inits inits) (n nreq) (gensyms (list-tail gensyms nreq)))
- (cond
- ((null? inits)) ; done
- ((and rest-idx (= n rest-idx))
- (lp inits (1+ n) (cdr gensyms)))
- (#t
- (pmatch (hashq-ref (hashq-ref allocation (car gensyms)) self)
- ((#t ,boxed? . ,n*) (guard (= n* n))
- (let ((L (make-label)))
- (emit-code #f (make-glil-lexical #t boxed? 'bound? n))
- (emit-code #f (make-glil-branch 'br-if L))
- (comp-push (car inits))
- (emit-code #f (make-glil-lexical #t boxed? 'set n))
- (emit-label L)
- (lp (cdr inits) (1+ n) (cdr gensyms))))
- (#t (error "bad arg allocation" (car gensyms) inits))))))
- ;; post-prelude case label for label calls
- (emit-label (car (hashq-ref allocation x)))
- (comp-tail body)
- (if (not (null? gensyms))
- (emit-code #f (make-glil-unbind)))
- (if alternate-label
- (begin
- (emit-label alternate-label)
- (flatten-lambda-case alternate allocation self self-label
- fix-labels emit-code)))))
-
- ((<let> src names gensyms vals body)
- (for-each comp-push vals)
- (emit-bindings src names gensyms allocation self emit-code)
- (for-each (lambda (v)
- (pmatch (hashq-ref (hashq-ref allocation v) self)
- ((#t #f . ,n)
- (emit-code src (make-glil-lexical #t #f 'set n)))
- ((#t #t . ,n)
- (emit-code src (make-glil-lexical #t #t 'box n)))
- (,loc (error "bad let var allocation" x loc))))
- (reverse gensyms))
- (comp-tail body)
- (clear-stack-slots context gensyms)
- (emit-code #f (make-glil-unbind)))
-
- ((<letrec> src in-order? names gensyms vals body)
- ;; First prepare heap storage slots.
- (for-each (lambda (v)
- (pmatch (hashq-ref (hashq-ref allocation v) self)
- ((#t #t . ,n)
- (emit-code src (make-glil-lexical #t #t 'empty-box n)))
- (,loc (error "bad letrec var allocation" x loc))))
- gensyms)
- ;; Even though the slots are empty, the bindings are valid.
- (emit-bindings src names gensyms allocation self emit-code)
- (cond
- (in-order?
- ;; For letrec*, bind values in order.
- (for-each (lambda (name v val)
- (pmatch (hashq-ref (hashq-ref allocation v) self)
- ((#t #t . ,n)
- (comp-push val)
- (emit-code src (make-glil-lexical #t #t 'set n)))
- (,loc (error "bad letrec var allocation" x loc))))
- names gensyms vals))
- (else
- ;; But for letrec, eval all values, then bind.
- (for-each comp-push vals)
- (for-each (lambda (v)
- (pmatch (hashq-ref (hashq-ref allocation v) self)
- ((#t #t . ,n)
- (emit-code src (make-glil-lexical #t #t 'set n)))
- (,loc (error "bad letrec var allocation" x loc))))
- (reverse gensyms))))
- (comp-tail body)
- (clear-stack-slots context gensyms)
- (emit-code #f (make-glil-unbind)))
-
- ((<fix> src names gensyms vals body)
- ;; The ideal here is to just render the lambda bodies inline, and
- ;; wire the code together with gotos. We can do that if
- ;; analyze-lexicals has determined that a given var has "label"
- ;; allocation -- which is the case if it is in `fix-labels'.
- ;;
- ;; But even for closures that we can't inline, we can do some
- ;; tricks to avoid heap-allocation for the binding itself. Since
- ;; we know the vals are lambdas, we can set them to their local
- ;; var slots first, then capture their bindings, mutating them in
- ;; place.
- (let ((new-RA (if (or (eq? context 'tail) RA) #f (make-label))))
- (for-each
- (lambda (x v)
- (cond
- ((hashq-ref allocation x)
- ;; allocating a closure
- (emit-code #f (flatten-lambda x v allocation))
- (let ((free-locs (cdr (hashq-ref allocation x))))
- (if (not (null? free-locs))
- ;; Need to make-closure first, so we have a fresh closure
on
- ;; the heap, but with a temporary free values.
- (begin
- (for-each (lambda (loc)
- (emit-code #f (make-glil-const #f)))
- free-locs)
- (emit-code #f (make-glil-call 'make-closure
- (length free-locs))))))
- (pmatch (hashq-ref (hashq-ref allocation v) self)
- ((#t #f . ,n)
- (emit-code src (make-glil-lexical #t #f 'set n)))
- (,loc (error "bad fix var allocation" x loc))))
- (else
- ;; labels allocation: emit label & body, but jump over it
- (let ((POST (make-label)))
- (emit-branch #f 'br POST)
- (let lp ((lcase (lambda-body x)))
- (if lcase
- (record-case lcase
- ((<lambda-case> src req gensyms body alternate)
- (emit-label (car (hashq-ref allocation lcase)))
- ;; FIXME: opt & kw args in the bindings
- (emit-bindings #f req gensyms allocation self
emit-code)
- (if src
- (emit-code #f (make-glil-source src)))
- (comp-fix body (or RA new-RA))
- (emit-code #f (make-glil-unbind))
- (lp alternate)))
- (emit-label POST)))))))
- vals
- gensyms)
- ;; Emit bindings metadata for closures
- (let ((binds (let lp ((out '()) (gensyms gensyms) (names names))
- (cond ((null? gensyms) (reverse! out))
- ((assq (car gensyms) fix-labels)
- (lp out (cdr gensyms) (cdr names)))
- (else
- (lp (acons (car gensyms) (car names) out)
- (cdr gensyms) (cdr names)))))))
- (emit-bindings src (map cdr binds) (map car binds)
- allocation self emit-code))
- ;; Now go back and fix up the bindings for closures.
- (for-each
- (lambda (x v)
- (let ((free-locs (if (hashq-ref allocation x)
- (cdr (hashq-ref allocation x))
- ;; can hit this latter case for labels
allocation
- '())))
- (if (not (null? free-locs))
- (begin
- (for-each
- (lambda (loc)
- (pmatch loc
- ((,local? ,boxed? . ,n)
- (emit-code #f (make-glil-lexical local? #f 'ref n)))
- (else (error "bad free var allocation" x loc))))
- free-locs)
- (pmatch (hashq-ref (hashq-ref allocation v) self)
- ((#t #f . ,n)
- (emit-code #f (make-glil-lexical #t #f 'fix n)))
- (,loc (error "bad fix var allocation" x loc)))))))
- vals
- gensyms)
- (comp-tail body)
- (if new-RA
- (emit-label new-RA))
- (clear-stack-slots context gensyms)
- (emit-code #f (make-glil-unbind))))
-
- ((<let-values> src exp body)
- (record-case body
- ((<lambda-case> req opt kw rest gensyms body alternate)
- (if (or opt kw alternate)
- (error "unexpected lambda-case in let-values" x))
- (let ((MV (make-label)))
- (comp-vals exp MV)
- (emit-code #f (make-glil-const 1))
- (emit-label MV)
- (emit-code src (make-glil-mv-bind
- (vars->bind-list
- (append req (if rest (list rest) '()))
- gensyms allocation self)
- (and rest #t)))
- (for-each (lambda (v)
- (pmatch (hashq-ref (hashq-ref allocation v) self)
- ((#t #f . ,n)
- (emit-code src (make-glil-lexical #t #f 'set n)))
- ((#t #t . ,n)
- (emit-code src (make-glil-lexical #t #t 'box n)))
- (,loc (error "bad let-values var allocation" x
loc))))
- (reverse gensyms))
- (comp-tail body)
- (clear-stack-slots context gensyms)
- (emit-code #f (make-glil-unbind))))))
-
- ;; What's the deal here? The deal is that we are compiling the start of a
- ;; delimited continuation. We try to avoid heap allocation in the normal
- ;; case; so the body is an expression, not a thunk, and we try to render
- ;; the handler inline. Also we did some analysis, in analyze.scm, so that
- ;; if the continuation isn't referenced, we don't reify it. This makes it
- ;; possible to implement catch and throw with delimited continuations,
- ;; without any overhead.
- ((<prompt> src escape-only? tag body handler)
- (let ((H (make-label))
- (POST (make-label))
- (body (if escape-only? body (make-call #f body '()))))
-
- ;; First, set up the prompt.
- (comp-push tag)
- (emit-code src (make-glil-prompt H escape-only?))
-
- ;; Then we compile the body, with its normal return path, unwinding
- ;; before proceeding.
- (case context
- ((tail)
- (let ((MV (make-label)))
- (comp-vals body MV)
- ;; one value: unwind and return
- (emit-code #f (make-glil-call 'unwind 0))
- (emit-code #f (make-glil-call 'return 1))
- ;; multiple values: unwind and return
- (emit-label MV)
- (emit-code #f (make-glil-call 'unwind 0))
- (emit-code #f (make-glil-call 'return/nvalues 1))))
-
- ((push)
- ;; we only want one value. so ask for one value, unwind, and jump
to
- ;; post
- (comp-push body)
- (emit-code #f (make-glil-call 'unwind 0))
- (emit-branch #f 'br (or RA POST)))
-
- ((vals)
- (let ((MV (make-label)))
- (comp-vals body MV)
- ;; one value: push 1 and fall through to MV case
- (emit-code #f (make-glil-const 1))
- ;; multiple values: unwind and goto MVRA
- (emit-label MV)
- (emit-code #f (make-glil-call 'unwind 0))
- (emit-branch #f 'br MVRA)))
-
- ((drop)
- ;; compile body, discarding values, then unwind & fall through.
- (comp-drop body)
- (emit-code #f (make-glil-call 'unwind 0))
- (emit-branch #f 'br (or RA POST))))
-
- (emit-label H)
- ;; Now the handler. The stack is now made up of the continuation, and
- ;; then the args to the continuation (pushed separately), and then the
- ;; number of args, including the continuation.
- (match handler
- (($ <lambda> src meta
- ($ <lambda-case> lsrc req #f rest #f () gensyms body #f))
- (emit-code (or lsrc src)
- (make-glil-mv-bind
- (vars->bind-list
- (append req (if rest (list rest) '()))
- gensyms allocation self)
- (and rest #t)))
- (for-each (lambda (v)
- (pmatch (hashq-ref (hashq-ref allocation v) self)
- ((#t #f . ,n)
- (emit-code src (make-glil-lexical #t #f 'set n)))
- ((#t #t . ,n)
- (emit-code src (make-glil-lexical #t #t 'box n)))
- (,loc
- (error "bad prompt handler arg allocation" x loc))))
- (reverse gensyms))
- (comp-tail body)
- (emit-code #f (make-glil-unbind))))
-
- (if (and (not RA)
- (or (eq? context 'push) (eq? context 'drop)))
- (emit-label POST))))
-
- ((<abort> src tag args tail)
- (comp-push tag)
- (for-each comp-push args)
- (comp-push tail)
- (emit-code src (make-glil-call 'abort (length args)))
- ;; so, the abort can actually return. if it does, the values will be on
- ;; the stack, then the MV marker, just as in an MV context.
- (case context
- ((tail)
- ;; Return values.
- (emit-code #f (make-glil-call 'return/nvalues 1)))
- ((drop)
- ;; Drop all values and goto RA, or otherwise fall through.
- (emit-code #f (make-glil-mv-bind 0 #f))
- (if RA (emit-branch #f 'br RA)))
- ((push)
- ;; Truncate to one value.
- (emit-code #f (make-glil-mv-bind 1 #f)))
- ((vals)
- ;; Go to MVRA.
- (emit-branch #f 'br MVRA)))))))
diff --git a/module/language/tree-il/spec.scm b/module/language/tree-il/spec.scm
index a1018cb..a7d1696 100644
--- a/module/language/tree-il/spec.scm
+++ b/module/language/tree-il/spec.scm
@@ -21,10 +21,8 @@
(define-module (language tree-il spec)
#:use-module (system base language)
#:use-module (system base pmatch)
- #:use-module (language glil)
#:use-module (language tree-il)
#:use-module (language tree-il compile-cps)
- #:use-module (language tree-il compile-glil)
#:export (tree-il))
(define (write-tree-il exp . port)
@@ -44,7 +42,6 @@
#:printer write-tree-il
#:parser parse-tree-il
#:joiner join
- #:compilers `((cps . ,compile-cps)
- (glil . ,compile-glil))
+ #:compilers `((cps . ,compile-cps))
#:for-humans? #f
)
diff --git a/module/scripts/compile.scm b/module/scripts/compile.scm
index db58a33..76a2531 100644
--- a/module/scripts/compile.scm
+++ b/module/scripts/compile.scm
@@ -158,7 +158,7 @@ Compile each Guile source file FILE into a Guile object.
for a list of available warnings
-f, --from=LANG specify a source language other than `scheme'
- -t, --to=LANG specify a target language other than `objcode'
+ -t, --to=LANG specify a target language other than `rtl'
-T, --target=TRIPLET produce bytecode for host TRIPLET
Note that auto-compilation will be turned off.
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index b932e64..18941d7 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -271,8 +271,8 @@
(define* (decompile x #:key
(env #f)
- (from 'value)
- (to 'assembly)
+ (from 'tree-il)
+ (to 'scheme)
(opts '()))
(decompile-fold (decompile-passes from to opts)
x
diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index 1e6aaff..631957a 100644
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -466,7 +466,6 @@ Change languages."
Generate compiled code."
(let ((x (repl-compile repl (repl-parse repl form))))
(cond ((bytevector? x) (disassemble-image (load-image x)))
- ((objcode? x) (guile:disassemble x))
(else (repl-print repl x)))))
(define-meta-command (compile-file repl file . opts)
@@ -488,9 +487,6 @@ Run the optimizer on a piece of code and print the result."
(run-hook before-print-hook x)
(pp x)))
-(define (guile:disassemble x)
- ((@ (language assembly disassemble) disassemble) x))
-
(define-meta-command (disassemble repl (form))
"disassemble EXP
Disassemble a compiled procedure."
@@ -500,10 +496,9 @@ Disassemble a compiled procedure."
(disassemble-program obj))
((bytevector? obj)
(disassemble-image (load-image obj)))
- ((or (program? obj) (objcode? obj))
- (guile:disassemble obj))
(else
- (format #t "Argument to ,disassemble not a procedure or objcode: ~a~%"
+ (format #t
+ "Argument to ,disassemble not a procedure or a bytevector: ~a~%"
obj)))))
(define-meta-command (disassemble-file repl file)
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 58c00ef..9f40221 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -48,7 +48,6 @@
#:use-module (system vm dwarf)
#:use-module (system vm elf)
#:use-module (system vm linker)
- #:use-module (system vm objcode)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 binary-ports)
#:use-module (ice-9 vlist)
@@ -59,8 +58,7 @@
#:use-module (srfi srfi-11)
#:export (make-assembler
emit-text
- link-assembly
- assemble-program))
+ link-assembly))
@@ -1991,11 +1989,3 @@ The result is a bytevector, by default linked so that
read-only and
writable data are on separate pages. Pass @code{#:page-aligned? #f} to
disable this behavior."
(link-elf (link-objects asm) #:page-aligned? page-aligned?))
-
-(define (assemble-program instructions)
- "Take the sequence of instructions @var{instructions}, assemble them
-into RTL code, link an image, and load that image from memory. Returns
-a procedure."
- (let ((asm (make-assembler)))
- (emit-text asm instructions)
- (load-thunk-from-memory (link-assembly asm #:page-aligned? #f))))
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index af99a54..ca6fe07 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -42,6 +42,7 @@
program-debug-info-context
program-debug-info-image
program-debug-info-offset
+ program-debug-info-size
program-debug-info-addr
program-debug-info-u32-offset
program-debug-info-u32-offset-end
diff --git a/module/system/vm/disassembler.scm
b/module/system/vm/disassembler.scm
index 1683b68..ccdedf8 100644
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -32,6 +32,7 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-4)
#:export (disassemble-program
+ fold-program-code
disassemble-image
disassemble-file))
@@ -362,6 +363,71 @@ address of that offset."
(format port "Debugging information unavailable.~%")))
(values))
+(define (fold-code-range proc seed bv start end context raw?)
+ (define (cook code offset)
+ (define (reference-scm target)
+ (unpack-scm (u32-offset->addr (+ offset target) context)))
+
+ (define (dereference-scm target)
+ (let ((addr (u32-offset->addr (+ offset target)
+ context)))
+ (pointer->scm
+ (dereference-pointer (make-pointer addr)))))
+ (match code
+ (((or 'make-short-immediate 'make-long-immediate) dst imm)
+ `(,(car code) ,dst ,(unpack-scm imm)))
+ (('make-long-long-immediate dst high low)
+ `(make-long-long-immediate ,dst
+ ,(unpack-scm (logior (ash high 32) low))))
+ (('make-closure dst target nfree)
+ `(make-closure ,dst
+ ,(u32-offset->addr (+ offset target) context)
+ ,nfree))
+ (('make-non-immediate dst target)
+ `(make-non-immediate ,dst ,(reference-scm target)))
+ (('builtin-ref dst idx)
+ `(builtin-ref ,dst ,(builtin-index->name idx)))
+ (((or 'static-ref 'static-set!) dst target)
+ `(,(car code) ,dst ,(dereference-scm target)))
+ (('toplevel-box dst var-offset mod-offset sym-offset bound?)
+ `(toplevel-box ,dst
+ ,(dereference-scm var-offset)
+ ,(dereference-scm mod-offset)
+ ,(dereference-scm sym-offset)
+ ,bound?))
+ (('module-box dst var-offset mod-name-offset sym-offset bound?)
+ (let ((mod-name (reference-scm mod-name-offset)))
+ `(module-box ,dst
+ ,(dereference-scm var-offset)
+ ,(car mod-name)
+ ,(cdr mod-name)
+ ,(dereference-scm sym-offset)
+ ,bound?)))
+ (_ code)))
+ (let lp ((offset start) (seed seed))
+ (cond
+ ((< offset end)
+ (call-with-values (lambda () (disassemble-one bv offset))
+ (lambda (len elt)
+ (lp (+ offset len)
+ (proc (if raw? elt (cook elt offset))
+ seed)))))
+ (else seed))))
+
+(define* (fold-program-code proc seed program-or-addr #:key raw?)
+ (cond
+ ((find-program-debug-info (if (rtl-program? program-or-addr)
+ (rtl-program-code program-or-addr)
+ program-or-addr))
+ => (lambda (pdi)
+ (fold-code-range proc seed
+ (program-debug-info-image pdi)
+ (program-debug-info-u32-offset pdi)
+ (program-debug-info-u32-offset-end pdi)
+ (program-debug-info-context pdi)
+ raw?)))
+ (else seed)))
+
(define* (disassemble-image bv #:optional (port (current-output-port)))
(let* ((ctx (debug-context-from-image bv))
(base (debug-context-text-base ctx)))
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index 8aba837..e3b3352 100644
--- a/module/system/vm/frame.scm
+++ b/module/system/vm/frame.scm
@@ -22,7 +22,6 @@
#:use-module (system base pmatch)
#:use-module (system vm program)
#:use-module (system vm instruction)
- #:use-module (system vm objcode)
#:export (frame-bindings
frame-lookup-binding
frame-binding-ref frame-binding-set!
diff --git a/module/system/vm/inspect.scm b/module/system/vm/inspect.scm
index 1023437..1f6d99d 100644
--- a/module/system/vm/inspect.scm
+++ b/module/system/vm/inspect.scm
@@ -1,6 +1,6 @@
;;; Guile VM debugging facilities
-;;; Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2009, 2010, 2011, 2013 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
@@ -23,8 +23,7 @@
#:use-module (system base syntax)
#:use-module (system vm vm)
#:use-module (system vm frame)
- #:use-module ((language assembly disassemble)
- #:select ((disassemble . %disassemble)))
+ #:use-module (system vm disassembler)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 pretty-print)
#:use-module (ice-9 format)
@@ -112,10 +111,10 @@
(display x))
(define-command ((commands disassemble x))
- "Disassemble the current object, which should be objcode or a procedure."
+ "Disassemble the current object, which should be a procedure."
(catch #t
(lambda ()
- (%disassemble x))
+ (disassemble-program x))
(lambda args
(format #t "Error disassembling object: ~a\n" args))))
diff --git a/module/system/vm/objcode.scm b/module/system/vm/objcode.scm
index 4a0e992..ba4ba53 100644
--- a/module/system/vm/objcode.scm
+++ b/module/system/vm/objcode.scm
@@ -19,10 +19,8 @@
;;; Code:
(define-module (system vm objcode)
- #:export (objcode? objcode-meta
- bytecode->objcode objcode->bytecode
- load-thunk-from-file load-thunk-from-memory
- word-size byte-order
+ #:export (load-thunk-from-file
+ load-thunk-from-memory
find-mapped-elf-image all-mapped-elf-images))
(load-extension (string-append "libguile-" (effective-version))
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index cf77c28..f99df80 100644
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -21,7 +21,6 @@
(define-module (system vm program)
#:use-module (ice-9 match)
#:use-module (system vm instruction)
- #:use-module (system vm objcode)
#:use-module (system vm debug)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
@@ -161,34 +160,12 @@
;; pre-retire addresses.
;;
(define (program-sources-pre-retire proc)
- (cond
- ((rtl-program? proc)
- (map (lambda (source)
- (cons* (- (source-pre-pc source) (rtl-program-code proc))
- (source-file source)
- (source-line source)
- (source-column source)))
- (find-program-sources (rtl-program-code proc))))
- (else
- (let ((bv (objcode->bytecode (program-objcode proc))))
- (let lp ((in (program-sources proc))
- (out '())
- (ip 0))
- (cond
- ((null? in)
- (reverse out))
- (else
- (match (car in)
- ((post-ip . source)
- (let lp2 ((ip ip)
- (next ip))
- (if (< next post-ip)
- (lp2 next (+ next (bytecode-instruction-length bv next)))
- (lp (cdr in)
- (acons ip source out)
- next))))
- (_
- (error "unexpected"))))))))))
+ (map (lambda (source)
+ (cons* (- (source-pre-pc source) (rtl-program-code proc))
+ (source-file source)
+ (source-line source)
+ (source-column source)))
+ (find-program-sources (rtl-program-code proc))))
(define (collapse-locals locs)
(let lp ((ret '()) (locs locs))
diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm
index 7b96af5..7657be4 100644
--- a/module/system/vm/trace.scm
+++ b/module/system/vm/trace.scm
@@ -23,7 +23,6 @@
#:use-module (system vm vm)
#:use-module (system vm frame)
#:use-module (system vm program)
- #:use-module (system vm objcode)
#:use-module (system vm traps)
#:use-module (rnrs bytevectors)
#:use-module (system vm instruction)
@@ -33,9 +32,6 @@
trace-instructions-in-procedure
call-with-trace))
-;; FIXME: this constant needs to go in system vm objcode
-(define *objcode-header-len* 8)
-
(define (build-prefix prefix depth infix numeric-format max-indent)
(let lp ((indent "") (n 0))
(cond
@@ -96,11 +92,9 @@
(define* (trace-instructions-in-procedure proc #:key (width 80) (vm (the-vm))
(max-indent (- width 40)))
(define (trace-next frame)
- (let* ((ip (frame-instruction-pointer frame))
- (objcode (program-objcode (frame-procedure frame)))
- (opcode (bytevector-u8-ref (objcode->bytecode objcode)
- (+ ip *objcode-header-len*))))
- (format #t "~8d: ~a\n" ip (opcode->instruction opcode))))
+ ;; FIXME: We could disassemble this instruction here.
+ (let ((ip (frame-instruction-pointer frame)))
+ (format #t "0x~x\n" ip)))
(trap-instructions-in-dynamic-extent proc trace-next
#:vm vm))
diff --git a/module/system/vm/traps.scm b/module/system/vm/traps.scm
index af74433..f1dcc29 100644
--- a/module/system/vm/traps.scm
+++ b/module/system/vm/traps.scm
@@ -57,9 +57,9 @@
(define-module (system vm traps)
#:use-module (system base pmatch)
#:use-module (system vm vm)
+ #:use-module (system vm debug)
#:use-module (system vm frame)
#:use-module (system vm program)
- #:use-module (system vm objcode)
#:use-module (system vm instruction)
#:use-module (system xref)
#:use-module (rnrs bytevectors)
@@ -108,24 +108,20 @@
(define (new-enabled-trap vm frame enable disable)
((new-disabled-trap vm enable disable) frame))
-(define (frame-matcher proc match-objcode?)
- (if match-objcode?
- (cond
- ((program? proc)
- (lambda (frame)
- (let ((frame-proc (frame-procedure frame)))
- (or (eq? frame-proc proc)
- (and (program? frame-proc)
- (eq? (program-objcode frame-proc)
- (program-objcode proc)))))))
- ((rtl-program? proc)
- (lambda (frame)
- (let ((frame-proc (frame-procedure frame)))
- (or (eq? frame-proc proc)
- (and (rtl-program? frame-proc)
- (eqv? (rtl-program-code frame-proc)
- (rtl-program-code proc)))))))
- (else (lambda (frame) #f)))
+;; Returns an absolute IP.
+(define (program-last-ip prog)
+ (let ((pdi (find-program-debug-info (rtl-program-code prog))))
+ (and pdi (program-debug-info-size pdi))))
+
+(define (frame-matcher proc match-code?)
+ (if match-code?
+ (if (rtl-program? proc)
+ (let ((start (rtl-program-code proc))
+ (end (program-last-ip proc)))
+ (lambda (frame)
+ (let ((ip (frame-instruction-pointer frame)))
+ (and (<= start ip) (< ip end)))))
+ (lambda (frame) #f))
(lambda (frame)
(eq? (frame-procedure frame) proc))))
@@ -319,41 +315,41 @@
#:current-frame current-frame #:vm vm
#:our-frame? our-frame?)))
-;; FIXME: define this in objcode somehow. We are reffing the first
-;; uint32 in the objcode, which is the length of the program (without
-;; the meta).
-(define (program-last-ip prog)
- (bytevector-u32-native-ref (objcode->bytecode (program-objcode prog)) 0))
-
(define (program-sources-by-line proc file)
- (let lp ((sources (program-sources-pre-retire proc))
- (out '()))
- (if (pair? sources)
- (lp (cdr sources)
- (pmatch (car sources)
- ((,start-ip ,start-file ,start-line . ,start-col)
- (if (equal? start-file file)
- (cons (cons start-line
- (if (pair? (cdr sources))
- (pmatch (cadr sources)
- ((,end-ip . _)
- (cons start-ip end-ip))
- (else (error "unexpected")))
- (cons start-ip (program-last-ip proc))))
- out)
- out))
- (else (error "unexpected"))))
- (let ((alist '()))
- (for-each
- (lambda (pair)
- (set! alist
- (assv-set! alist (car pair)
- (cons (cdr pair)
- (or (assv-ref alist (car pair))
- '())))))
- out)
- (sort! alist (lambda (x y) (< (car x) (car y))))
- alist))))
+ (cond
+ ((rtl-program? proc)
+ (let ((code (rtl-program-code proc)))
+ (let lp ((sources (program-sources proc))
+ (out '()))
+ (if (pair? sources)
+ (lp (cdr sources)
+ (pmatch (car sources)
+ ((,start-ip ,start-file ,start-line . ,start-col)
+ (if (equal? start-file file)
+ (acons start-line
+ (if (pair? (cdr sources))
+ (pmatch (cadr sources)
+ ((,end-ip . _)
+ (cons (+ start-ip code)
+ (+ end-ip code)))
+ (else (error "unexpected")))
+ (cons (+ start-ip code)
+ (program-last-ip proc)))
+ out)
+ out))
+ (else (error "unexpected"))))
+ (let ((alist '()))
+ (for-each
+ (lambda (pair)
+ (set! alist
+ (assv-set! alist (car pair)
+ (cons (cdr pair)
+ (or (assv-ref alist (car pair))
+ '())))))
+ out)
+ (sort! alist (lambda (x y) (< (car x) (car y))))
+ alist)))))
+ (else '())))
(define (source->ip-range proc file line)
(or (or-map (lambda (line-and-ranges)
diff --git a/module/system/xref.scm b/module/system/xref.scm
index b6211d8..65d0fed 100644
--- a/module/system/xref.scm
+++ b/module/system/xref.scm
@@ -17,9 +17,10 @@
(define-module (system xref)
- #:use-module (system base pmatch)
#:use-module (system base compile)
#:use-module (system vm program)
+ #:use-module (system vm disassembler)
+ #:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:export (*xref-ignored-modules*
procedure-callees
@@ -31,59 +32,54 @@
;;; The cross-reference database: who calls whom.
;;;
+(define (nested-procedures prog)
+ (define (cons-uniq x y)
+ (if (memq x y) y (cons x y)))
+ (if (rtl-program? prog)
+ (reverse
+ (fold-program-code (lambda (elt out)
+ (match elt
+ (('static-ref dst proc)
+ (if (rtl-program? proc)
+ (fold cons-uniq
+ (cons proc out)
+ (nested-procedures prog))
+ out))
+ (_ out)))
+ (list prog)
+ prog))
+ (list prog)))
+
(define (program-callee-rev-vars prog)
(define (cons-uniq x y)
(if (memq x y) y (cons x y)))
- (cond
- ((program-objects prog)
- => (lambda (objects)
- (let ((n (vector-length objects))
- (progv (make-vector (vector-length objects) #f))
- (asm (decompile (program-objcode prog) #:to 'assembly)))
- (pmatch asm
- ((load-program ,labels ,len . ,body)
- (for-each
- (lambda (x)
- (pmatch x
- ((toplevel-ref ,n) (vector-set! progv n #t))
- ((toplevel-set ,n) (vector-set! progv n #t))))
- body)))
- (let lp ((i 0) (out '()))
- (cond
- ((= i n) out)
- ((program? (vector-ref objects i))
- (lp (1+ i)
- (fold cons-uniq out
- (program-callee-rev-vars (vector-ref objects i)))))
- ((vector-ref progv i)
- (let ((obj (vector-ref objects i)))
- (if (variable? obj)
- (lp (1+ i) (cons-uniq obj out))
- ;; otherwise it's an unmemoized binding
- (pmatch obj
- (,sym (guard (symbol? sym))
- (let ((v (module-variable (or (program-module prog)
- the-root-module)
- sym)))
- (lp (1+ i) (if v (cons-uniq v out) out))))
- ((,mod ,sym ,public?)
- ;; hm, hacky.
- (let* ((m (nested-ref-module (resolve-module '() #f)
- mod))
- (v (and m
- (module-variable
- (if public?
- (module-public-interface m)
- m)
- sym))))
- (lp (1+ i)
- (if v (cons-uniq v out) out))))))))
- (else (lp (1+ i) out)))))))
- (else '())))
+ (fold (lambda (prog out)
+ (fold-program-code
+ (lambda (elt out)
+ (match elt
+ (('toplevel-box dst var mod sym bound?)
+ (let ((var (or var (and mod (module-variable mod sym)))))
+ (if var
+ (cons-uniq var out)
+ out)))
+ (('module-box dst var public? mod-name sym bound?)
+ (let ((var (or var
+ (module-variable (if public?
+ (resolve-interface
mod-name)
+ (resolve-module mod-name))
+ sym))))
+ (if var
+ (cons-uniq var out)
+ out)))
+ (_ out)))
+ out
+ prog))
+ '()
+ (nested-procedures prog)))
(define (procedure-callee-rev-vars proc)
(cond
- ((program? proc) (program-callee-rev-vars proc))
+ ((rtl-program? proc) (program-callee-rev-vars proc))
(else '())))
(define (procedure-callees prog)
@@ -186,10 +182,10 @@ pair of the form (module-name . variable-name), "
(let ((v (cond ((variable? var) var)
((symbol? var) (module-variable (current-module) var))
(else
- (pmatch var
- ((,modname . ,sym)
+ (match var
+ ((modname . sym)
(module-variable (resolve-module modname) sym))
- (else
+ (_
(error "expected a variable, symbol, or (modname . sym)"
var)))))))
(untaint-modules)
(hashq-ref *callers-db* v '())))
@@ -255,39 +251,32 @@ pair of the form (module-name . variable-name), "
sources)
;; Actually add the source entries.
(for-each (lambda (source)
- (pmatch source
- ((,ip ,file ,line . ,col)
+ (match source
+ ((ip file line . col)
(add-source proc file line db))
- (else (error "unexpected source format" source))))
+ (_ (error "unexpected source format" source))))
sources)))
;; Add source entries for nested procedures.
(for-each (lambda (obj)
- (if (procedure? obj)
- (add-sources obj mod-name *closure-sources-db*)))
- (or (and (program? proc)
- (and=> (program-objects proc) vector->list))
- '()))))
+ (add-sources obj mod-name *closure-sources-db*))
+ (cdr (nested-procedures proc)))))
(define (forget-sources proc mod-name db)
(let ((mod-table (hash-ref *module-sources-db* mod-name)))
- (if mod-table
- (begin
- ;; Forget source entries.
- (for-each (lambda (source)
- (pmatch source
- ((,ip ,file ,line . ,col)
- (forget-source proc file line db))
- (else (error "unexpected source format" source))))
- (hashq-ref mod-table proc '()))
- ;; Forget the proc.
- (hashq-remove! mod-table proc)
- ;; Forget source entries for nested procedures.
- (for-each (lambda (obj)
- (if (procedure? obj)
- (forget-sources obj mod-name *closure-sources-db*)))
- (or (and (program? proc)
- (and=> (program-objects proc) vector->list))
- '()))))))
+ (when mod-table
+ ;; Forget source entries.
+ (for-each (lambda (source)
+ (match source
+ ((ip file line . col)
+ (forget-source proc file line db))
+ (_ (error "unexpected source format" source))))
+ (hashq-ref mod-table proc '()))
+ ;; Forget the proc.
+ (hashq-remove! mod-table proc)
+ ;; Forget source entries for nested procedures.
+ (for-each (lambda (obj)
+ (forget-sources obj mod-name *closure-sources-db*))
+ (cdr (nested-procedures proc))))))
(define (untaint-sources)
(define (untaint m)
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 19789db..3ab34d6 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -28,7 +28,6 @@ SCM_TESTS = tests/00-initial-env.test \
tests/and-let-star.test \
tests/arbiters.test \
tests/arrays.test \
- tests/asm-to-bytecode.test \
tests/bit-operations.test \
tests/bitvectors.test \
tests/brainfuck.test \
@@ -40,6 +39,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/control.test \
tests/continuations.test \
tests/coverage.test \
+ tests/cross-compilation.test \
tests/cse.test \
tests/curried-definitions.test \
tests/dwarf.test \
diff --git a/test-suite/tests/asm-to-bytecode.test
b/test-suite/tests/asm-to-bytecode.test
deleted file mode 100644
index 688e752..0000000
--- a/test-suite/tests/asm-to-bytecode.test
+++ /dev/null
@@ -1,217 +0,0 @@
-;;;; Assembly to bytecode compilation -*- mode: scheme; coding: utf-8; -*-
-;;;;
-;;;; Copyright (C) 2010, 2011, 2012, 2013 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
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-(define-module (tests asm-to-bytecode)
- #:use-module (rnrs bytevectors)
- #:use-module ((rnrs io ports) #:select (open-bytevector-output-port))
- #:use-module (test-suite lib)
- #:use-module (system vm instruction)
- #:use-module (system vm objcode)
- #:use-module (system vm elf)
- #:use-module (system base target)
- #:use-module (language objcode elf)
- #:use-module (language assembly)
- #:use-module (language assembly compile-bytecode))
-
-(define (->u8-list sym val)
- (let ((entry (assq-ref `((uint16 2 ,bytevector-u16-native-set!)
- (uint32 4 ,bytevector-u32-native-set!))
- sym)))
- (or entry (error "unknown sym" sym))
- (let ((bv (make-bytevector (car entry))))
- ((cadr entry) bv 0 val)
- (bytevector->u8-list bv))))
-
-(define (munge-bytecode v)
- (let lp ((i 0) (out '()))
- (if (= i (vector-length v))
- (u8-list->bytevector (reverse out))
- (let ((x (vector-ref v i)))
- (cond
- ((symbol? x)
- (lp (1+ i) (cons (instruction->opcode x) out)))
- ((integer? x)
- (lp (1+ i) (cons x out)))
- ((pair? x)
- (lp (1+ i) (append (reverse (apply ->u8-list x)) out)))
- (else (error "bad test bytecode" x)))))))
-
-(define (comp-test x y)
- (let* ((y (munge-bytecode y))
- (len (bytevector-length y))
- (v #f))
-
- (run-test `(length ,x) #t
- (lambda ()
- (let* ((wrapped `(load-program () ,(byte-length x) #f ,x))
- (bv (compile-bytecode wrapped '())))
- (set! v (make-bytevector (- (bytevector-length bv) 8)))
- (bytevector-copy! bv 8 v 0 (bytevector-length v))
- (= (bytevector-length v) len))))
- (run-test `(compile-equal? ,x ,y) #t
- (lambda ()
- (equal? v y)))))
-
-
-(with-test-prefix "compiler"
- (with-test-prefix "asm-to-bytecode"
-
- (comp-test '(make-int8 3)
- #(make-int8 3))
-
- (comp-test '(load-number "3.14")
- (vector 'load-number 0 0 4 (char->integer #\3) (char->integer
#\.)
- (char->integer #\1) (char->integer #\4)))
-
- (comp-test '(load-string "foo")
- (vector 'load-string 0 0 3 (char->integer #\f) (char->integer
#\o)
- (char->integer #\o)))
-
- (comp-test '(load-symbol "foo")
- (vector 'load-symbol 0 0 3 (char->integer #\f) (char->integer
#\o)
- (char->integer #\o)))
-
- (comp-test '(load-string "æ") ;; a non-ASCII Latin-1 string
- (vector 'load-string 0 0 1 230))
-
- (comp-test '(load-wide-string "λ")
- (apply vector 'load-wide-string 0 0 4
- (if (eq? (native-endianness) (endianness little))
- '(187 3 0 0)
- '(0 0 3 187))))
-
- (comp-test '(load-program () 3 #f (make-int8 3) (return))
- #(load-program
- (uint32 3) ;; len
- (uint32 0) ;; metalen
- make-int8 3
- return))
-
- ;; the nops are to pad meta to an 8-byte alignment. not strictly
- ;; necessary for this test, but representative of the common case.
- (comp-test '(load-program () 8
- (load-program () 3
- #f
- (make-int8 3) (return))
- (make-int8 3) (return)
- (nop) (nop) (nop) (nop) (nop))
- #(load-program
- (uint32 8) ;; len
- (uint32 11) ;; metalen
- make-int8 3
- return
- nop nop nop nop nop
- (uint32 3) ;; len
- (uint32 0) ;; metalen
- make-int8 3
- return))))
-
-
-(define (test-triplet cpu vendor os)
- (let ((triplet (string-append cpu "-" vendor "-" os)))
- (pass-if (format #f "triplet ~a" triplet)
- (with-target triplet
- (lambda ()
- (and (string=? (target-cpu) cpu)
- (string=? (target-vendor) vendor)
- (string=? (target-os) os)))))))
-
-(define (native-cpu)
- (with-target %host-type target-cpu))
-
-(define (native-os)
- (with-target %host-type target-os))
-
-(define (native-word-size)
- ((@ (system foreign) sizeof) '*))
-
-(define %objcode-cookie-size
- (string-length "GOOF----LE-8"))
-
-(define (test-target triplet endian word-size)
- (pass-if (format #f "target `~a' honored" triplet)
- (call-with-values (lambda ()
- (open-bytevector-output-port))
- (lambda (p get-objcode)
- (with-target triplet
- (lambda ()
- (let ((word-size
- ;; When the target is the native CPU, rather trust
- ;; the native CPU's word size. This is because
- ;; Debian's `sparc64-linux-gnu' port, for instance,
- ;; actually has a 32-bit user-land, for instance (see
- ;; <http://www.debian.org/ports/sparc/#sparc64bit>
- ;; for details.)
- (if (and (string=? (native-cpu) (target-cpu))
- (string=? (native-os) (target-os)))
- (native-word-size)
- word-size))
- (b (compile-bytecode
- '(load-program () 16 #f
- (assert-nargs-ee/locals 1)
- (make-int8 77)
- (toplevel-ref 1)
- (local-ref 0)
- (mul)
- (add)
- (return)
- (nop) (nop) (nop)
- (nop) (nop))
- #f)))
- (write-objcode (bytecode->objcode b (target-endianness)) p)
- (let* ((bv (get-objcode)))
- (and=> (parse-elf bv)
- (lambda (elf)
- (and (equal? (elf-byte-order elf) endian)
- (equal? (elf-word-size elf) word-size))))))))))))
-
-(with-test-prefix "cross-compilation"
-
- (test-triplet "i586" "pc" "gnu0.3")
- (test-triplet "x86_64" "unknown" "linux-gnu")
- (test-triplet "x86_64" "unknown" "kfreebsd-gnu")
-
- (test-target "i586-pc-gnu0.3" (endianness little) 4)
- (test-target "x86_64-pc-linux-gnu" (endianness little) 8)
- (test-target "powerpc-unknown-linux-gnu" (endianness big) 4)
- (test-target "sparc64-unknown-freebsd8.2" (endianness big) 8)
-
- (test-target "mips64el-unknown-linux-gnu" ; n32 or o32 ABI
- (endianness little) 4)
- (test-target "mips64el-unknown-linux-gnuabi64" ; n64 ABI (Debian tuplet)
- (endianness little) 8)
- (test-target "x86_64-unknown-linux-gnux32" ; x32 ABI (Debian tuplet)
- (endianness little) 4)
-
- (pass-if-exception "unknown target"
- exception:miscellaneous-error
- (call-with-values (lambda ()
- (open-bytevector-output-port))
- (lambda (p get-objcode)
- (let* ((b (compile-bytecode '(load-program () 3 #f
- (make-int8 77)
- (return))
- #f))
- (o (bytecode->objcode b (target-endianness))))
- (with-target "fcpu-unknown-gnu1.0"
- (lambda ()
- (write-objcode o p))))))))
-
-;; Local Variables:
-;; eval: (put 'with-target 'scheme-indent-function 1)
-;; End:
diff --git a/test-suite/tests/cross-compilation.test
b/test-suite/tests/cross-compilation.test
new file mode 100644
index 0000000..78d9c80
--- /dev/null
+++ b/test-suite/tests/cross-compilation.test
@@ -0,0 +1,90 @@
+;;;; Cross compilation -*- mode: scheme; coding: utf-8; -*-
+;;;;
+;;;; Copyright (C) 2010, 2011, 2012, 2013 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
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+(define-module (tests cross-compilation)
+ #:use-module (test-suite lib)
+ #:use-module (rnrs bytevectors)
+ #:use-module (system vm elf)
+ #:use-module (system base compile)
+ #:use-module (system base target))
+
+(define (test-triplet cpu vendor os)
+ (let ((triplet (string-append cpu "-" vendor "-" os)))
+ (pass-if (format #f "triplet ~a" triplet)
+ (with-target triplet
+ (lambda ()
+ (and (string=? (target-cpu) cpu)
+ (string=? (target-vendor) vendor)
+ (string=? (target-os) os)))))))
+
+(define (native-cpu)
+ (with-target %host-type target-cpu))
+
+(define (native-os)
+ (with-target %host-type target-os))
+
+(define (native-word-size)
+ ((@ (system foreign) sizeof) '*))
+
+(define (test-target triplet endian word-size)
+ (pass-if (format #f "target `~a' honored" triplet)
+ (with-target triplet
+ (lambda ()
+ (let ((word-size
+ ;; When the target is the native CPU, rather trust
+ ;; the native CPU's word size. This is because
+ ;; Debian's `sparc64-linux-gnu' port, for instance,
+ ;; actually has a 32-bit user-land, for instance (see
+ ;; <http://www.debian.org/ports/sparc/#sparc64bit>
+ ;; for details.)
+ (if (and (string=? (native-cpu) (target-cpu))
+ (string=? (native-os) (target-os)))
+ (native-word-size)
+ word-size))
+ (bv (compile '(hello-world) #:to 'rtl)))
+ (and=> (parse-elf bv)
+ (lambda (elf)
+ (and (equal? (elf-byte-order elf) endian)
+ (equal? (elf-word-size elf) word-size)))))))))
+
+(with-test-prefix "cross-compilation"
+
+ (test-triplet "i586" "pc" "gnu0.3")
+ (test-triplet "x86_64" "unknown" "linux-gnu")
+ (test-triplet "x86_64" "unknown" "kfreebsd-gnu")
+
+ (test-target "i586-pc-gnu0.3" (endianness little) 4)
+ (test-target "x86_64-pc-linux-gnu" (endianness little) 8)
+ (test-target "powerpc-unknown-linux-gnu" (endianness big) 4)
+ (test-target "sparc64-unknown-freebsd8.2" (endianness big) 8)
+
+ (test-target "mips64el-unknown-linux-gnu" ; n32 or o32 ABI
+ (endianness little) 4)
+ (test-target "mips64el-unknown-linux-gnuabi64" ; n64 ABI (Debian tuplet)
+ (endianness little) 8)
+ (test-target "x86_64-unknown-linux-gnux32" ; x32 ABI (Debian tuplet)
+ (endianness little) 4)
+
+ (pass-if-exception "unknown target" exception:miscellaneous-error
+ (with-target "fcpu-unknown-gnu1.0"
+ (lambda ()
+ (compile '(ohai) #:to 'rtl)))))
+
+;; Local Variables:
+;; eval: (put 'with-target 'scheme-indent-function 1)
+;; End:
diff --git a/test-suite/tests/cse.test b/test-suite/tests/cse.test
index e60fdf3..25e6626 100644
--- a/test-suite/tests/cse.test
+++ b/test-suite/tests/cse.test
@@ -28,7 +28,6 @@
#:use-module (language tree-il fix-letrec)
#:use-module (language tree-il cse)
#:use-module (language tree-il peval)
- #:use-module (language glil)
#:use-module (srfi srfi-13))
(define-syntax pass-if-cse
@@ -292,8 +291,8 @@
(pass-if "http://bugs.gnu.org/12883";
;; In 2.0.6, compiling this code would trigger an out-of-bounds
;; vlist access in CSE's traversal of its "database".
- (glil-program?
- (compile '(define (proc v)
+ (procedure?
+ (compile '(lambda (v)
(let ((failure (lambda () (bail-out 'match))))
(if (and (pair? v)
(null? (cdr v)))
@@ -303,5 +302,4 @@
#t
(failure)))
(failure))))
- #:from 'scheme
- #:to 'glil))))
+ #:from 'scheme))))
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index 730808b..cb17652 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -24,7 +24,6 @@
#:use-module (system base message)
#:use-module (language tree-il)
#:use-module (language tree-il primitives)
- #:use-module (language glil)
#:use-module (rnrs bytevectors) ;; for the bytevector primitives
#:use-module (srfi srfi-13))
diff --git a/test-suite/tests/rtl.test b/test-suite/tests/rtl.test
index 84bb656..a435d52 100644
--- a/test-suite/tests/rtl.test
+++ b/test-suite/tests/rtl.test
@@ -20,8 +20,18 @@
#:use-module (test-suite lib)
#:use-module (system vm assembler)
#:use-module (system vm program)
+ #:use-module (system vm objcode)
+ #:use-module (system vm linker)
#:use-module (system vm debug))
+(define (assemble-program instructions)
+ "Take the sequence of instructions @var{instructions}, assemble them
+into RTL code, link an image, and load that image from memory. Returns
+a procedure."
+ (let ((asm (make-assembler)))
+ (emit-text asm instructions)
+ (load-thunk-from-memory (link-assembly asm #:page-aligned? #f))))
+
(define-syntax-rule (assert-equal val expr)
(let ((x val))
(pass-if (object->string x) (equal? expr x))))
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 762fb59..c2e6c65 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -24,42 +24,8 @@
#:use-module (system base message)
#:use-module (language tree-il)
#:use-module (language tree-il primitives)
- #:use-module (language glil)
#:use-module (srfi srfi-13))
-;; Of course, the GLIL that is emitted depends on the source info of the
-;; input. Here we're not concerned about that, so we strip source
-;; information from the incoming tree-il.
-
-(define (strip-source x)
- (post-order (lambda (x)
- (set! (tree-il-src x) #f)
- x)
- x))
-
-(define-syntax assert-tree-il->glil
- (syntax-rules (with-partial-evaluation without-partial-evaluation
- with-options)
- ((_ with-partial-evaluation in pat test ...)
- (assert-tree-il->glil with-options (#:partial-eval? #t)
- in pat test ...))
- ((_ without-partial-evaluation in pat test ...)
- (assert-tree-il->glil with-options (#:partial-eval? #f)
- in pat test ...))
- ((_ with-options opts in pat test ...)
- (let ((exp 'in))
- (pass-if 'in
- (let ((glil (unparse-glil
- (compile (strip-source (parse-tree-il exp))
- #:from 'tree-il #:to 'glil
- #:opts 'opts))))
- (pmatch glil
- (pat (guard test ...) #t)
- (else #f))))))
- ((_ in pat test ...)
- (assert-tree-il->glil with-partial-evaluation
- in pat test ...))))
-
(define-syntax-rule (pass-if-primitives-resolved in expected)
(pass-if (format #f "primitives-resolved in ~s" 'in)
(let* ((module (let ((m (make-module)))
@@ -155,557 +121,16 @@
(case-lambda ((,a) ,a1) ((,b ,c) (list ,b1 ,c1)))
(and (eq? a a1) (eq? b b1) (eq? c c1))))
-(with-test-prefix "void"
- (assert-tree-il->glil
- (void)
- (program () (std-prelude 0 0 #f) (label _) (void) (call return 1)))
- (assert-tree-il->glil
- (begin (void) (const 1))
- (program () (std-prelude 0 0 #f) (label _) (const 1) (call return 1)))
- (assert-tree-il->glil
- (primcall + (void) (const 1))
- (program () (std-prelude 0 0 #f) (label _) (void) (call add1 1) (call
return 1))))
-
-(with-test-prefix "application"
- (assert-tree-il->glil
- (call (toplevel foo) (const 1))
- (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (const 1)
(call tail-call 1)))
- (assert-tree-il->glil
- (begin (call (toplevel foo) (const 1)) (void))
- (program () (std-prelude 0 0 #f) (label _) (call new-frame 0) (toplevel ref
foo) (const 1) (mv-call 1 ,l1)
- (call drop 1) (branch br ,l2)
- (label ,l3) (mv-bind 0 #f)
- (label ,l4)
- (void) (call return 1))
- (and (eq? l1 l3) (eq? l2 l4)))
- (assert-tree-il->glil
- (call (toplevel foo) (call (toplevel bar)))
- (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call
new-frame 0) (toplevel ref bar) (call call 0)
- (call tail-call 1))))
-
-(with-test-prefix "conditional"
- (assert-tree-il->glil
- (if (toplevel foo) (const 1) (const 2))
- (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch
br-if-not ,l1)
- (const 1) (call return 1)
- (label ,l2) (const 2) (call return 1))
- (eq? l1 l2))
-
- (assert-tree-il->glil without-partial-evaluation
- (begin (if (toplevel foo) (const 1) (const 2)) (const #f))
- (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (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
- (primcall null? (if (toplevel foo) (const 1) (const 2)))
- (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch
br-if-not ,l1)
- (const 1) (branch br ,l2)
- (label ,l3) (const 2) (label ,l4)
- (call null? 1) (call return 1))
- (eq? l1 l3) (eq? l2 l4)))
-
-(with-test-prefix "primitive-ref"
- (assert-tree-il->glil
- (primitive +)
- (program () (std-prelude 0 0 #f)
- (label _) (module private ref (guile) +) (call return 1)))
-
- (assert-tree-il->glil
- (begin (primitive +) (const #f))
- (program () (std-prelude 0 0 #f) (label _) (const #f) (call return 1)))
-
- (assert-tree-il->glil
- (primcall null? (primitive +))
- (program () (std-prelude 0 0 #f) (label _)
- (module private ref (guile) +) (call null? 1)
- (call return 1))))
-
-(with-test-prefix "lexical refs"
- (assert-tree-il->glil without-partial-evaluation
- (let (x) (y) ((const 1)) (lexical x y))
- (program () (std-prelude 0 1 #f) (label _)
- (const 1) (bind (x #f 0)) (lexical #t #f set 0)
- (lexical #t #f ref 0) (call return 1)
- (unbind)))
-
- (assert-tree-il->glil with-options (#:partial-eval? #f #:cse? #f)
- (let (x) (y) ((const 1)) (begin (lexical x y) (const #f)))
- (program () (std-prelude 0 1 #f) (label _)
- (const 1) (bind (x #f 0)) (lexical #t #f set 0)
- (const #f) (call return 1)
- (unbind)))
-
- (assert-tree-il->glil without-partial-evaluation
- (let (x) (y) ((const 1)) (primcall null? (lexical x y)))
- (program () (std-prelude 0 1 #f) (label _)
- (const 1) (bind (x #f 0)) (lexical #t #f set 0)
- (lexical #t #f ref 0) (call null? 1) (call return 1)
- (unbind))))
-
-(with-test-prefix "lexical sets"
- (assert-tree-il->glil
- ;; unreferenced sets may be optimized away -- make sure they are ref'd
- (let (x) (y) ((const 1))
- (set! (lexical x y) (primcall 1+ (lexical x y))))
- (program () (std-prelude 0 1 #f) (label _)
- (const 1) (bind (x #t 0)) (lexical #t #t box 0)
- (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
- (void) (call return 1)
- (unbind)))
-
- (assert-tree-il->glil
- (let (x) (y) ((const 1))
- (begin (set! (lexical x y) (primcall 1+ (lexical x y)))
- (lexical x y)))
- (program () (std-prelude 0 1 #f) (label _)
- (const 1) (bind (x #t 0)) (lexical #t #t box 0)
- (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
- (lexical #t #t ref 0) (call return 1)
- (unbind)))
-
- (assert-tree-il->glil
- (let (x) (y) ((const 1))
- (primcall null?
- (set! (lexical x y) (primcall 1+ (lexical x y)))))
- (program () (std-prelude 0 1 #f) (label _)
- (const 1) (bind (x #t 0)) (lexical #t #t box 0)
- (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (void)
- (call null? 1) (call return 1)
- (unbind))))
-
-(with-test-prefix "module refs"
- (assert-tree-il->glil
- (@ (foo) bar)
- (program () (std-prelude 0 0 #f) (label _)
- (module public ref (foo) bar)
- (call return 1)))
-
- (assert-tree-il->glil
- (begin (@ (foo) bar) (const #f))
- (program () (std-prelude 0 0 #f) (label _)
- (module public ref (foo) bar) (call drop 1)
- (const #f) (call return 1)))
-
- (assert-tree-il->glil
- (primcall null? (@ (foo) bar))
- (program () (std-prelude 0 0 #f) (label _)
- (module public ref (foo) bar)
- (call null? 1) (call return 1)))
-
- (assert-tree-il->glil
- (@@ (foo) bar)
- (program () (std-prelude 0 0 #f) (label _)
- (module private ref (foo) bar)
- (call return 1)))
-
- (assert-tree-il->glil
- (begin (@@ (foo) bar) (const #f))
- (program () (std-prelude 0 0 #f) (label _)
- (module private ref (foo) bar) (call drop 1)
- (const #f) (call return 1)))
-
- (assert-tree-il->glil
- (primcall null? (@@ (foo) bar))
- (program () (std-prelude 0 0 #f) (label _)
- (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 () (std-prelude 0 0 #f) (label _)
- (const 2) (module public set (foo) bar)
- (void) (call return 1)))
-
- (assert-tree-il->glil
- (begin (set! (@ (foo) bar) (const 2)) (const #f))
- (program () (std-prelude 0 0 #f) (label _)
- (const 2) (module public set (foo) bar)
- (const #f) (call return 1)))
-
- (assert-tree-il->glil
- (primcall null? (set! (@ (foo) bar) (const 2)))
- (program () (std-prelude 0 0 #f) (label _)
- (const 2) (module public set (foo) bar)
- (void) (call null? 1) (call return 1)))
-
- (assert-tree-il->glil
- (set! (@@ (foo) bar) (const 2))
- (program () (std-prelude 0 0 #f) (label _)
- (const 2) (module private set (foo) bar)
- (void) (call return 1)))
-
- (assert-tree-il->glil
- (begin (set! (@@ (foo) bar) (const 2)) (const #f))
- (program () (std-prelude 0 0 #f) (label _)
- (const 2) (module private set (foo) bar)
- (const #f) (call return 1)))
-
- (assert-tree-il->glil
- (primcall null? (set! (@@ (foo) bar) (const 2)))
- (program () (std-prelude 0 0 #f) (label _)
- (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 () (std-prelude 0 0 #f) (label _)
- (toplevel ref bar)
- (call return 1)))
-
- (assert-tree-il->glil without-partial-evaluation
- (begin (toplevel bar) (const #f))
- (program () (std-prelude 0 0 #f) (label _)
- (toplevel ref bar) (call drop 1)
- (const #f) (call return 1)))
-
- (assert-tree-il->glil
- (primcall null? (toplevel bar))
- (program () (std-prelude 0 0 #f) (label _)
- (toplevel ref bar)
- (call null? 1) (call return 1))))
-
-(with-test-prefix "toplevel sets"
- (assert-tree-il->glil
- (set! (toplevel bar) (const 2))
- (program () (std-prelude 0 0 #f) (label _)
- (const 2) (toplevel set bar)
- (void) (call return 1)))
-
- (assert-tree-il->glil
- (begin (set! (toplevel bar) (const 2)) (const #f))
- (program () (std-prelude 0 0 #f) (label _)
- (const 2) (toplevel set bar)
- (const #f) (call return 1)))
-
- (assert-tree-il->glil
- (primcall null? (set! (toplevel bar) (const 2)))
- (program () (std-prelude 0 0 #f) (label _)
- (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 () (std-prelude 0 0 #f) (label _)
- (const 2) (toplevel define bar)
- (void) (call return 1)))
-
- (assert-tree-il->glil
- (begin (define bar (const 2)) (const #f))
- (program () (std-prelude 0 0 #f) (label _)
- (const 2) (toplevel define bar)
- (const #f) (call return 1)))
-
- (assert-tree-il->glil
- (primcall null? (define bar (const 2)))
- (program () (std-prelude 0 0 #f) (label _)
- (const 2) (toplevel define bar)
- (void) (call null? 1) (call return 1))))
-
-(with-test-prefix "constants"
- (assert-tree-il->glil
- (const 2)
- (program () (std-prelude 0 0 #f) (label _)
- (const 2) (call return 1)))
-
- (assert-tree-il->glil
- (begin (const 2) (const #f))
- (program () (std-prelude 0 0 #f) (label _)
- (const #f) (call return 1)))
-
- (assert-tree-il->glil
- ;; This gets simplified by `peval'.
- (primcall null? (const 2))
- (program () (std-prelude 0 0 #f) (label _)
- (const #f) (call return 1))))
-
-(with-test-prefix "letrec"
- ;; simple bindings -> let
- (assert-tree-il->glil without-partial-evaluation
- (letrec (x y) (x1 y1) ((const 10) (const 20))
- (call (toplevel foo) (lexical x x1) (lexical y y1)))
- (program () (std-prelude 0 2 #f) (label _)
- (const 10) (const 20)
- (bind (x #f 0) (y #f 1))
- (lexical #t #f set 1) (lexical #t #f set 0)
- (toplevel ref foo)
- (lexical #t #f ref 0) (lexical #t #f ref 1)
- (call tail-call 2)
- (unbind)))
-
- ;; complex bindings -> box and set! within let
- (assert-tree-il->glil without-partial-evaluation
- (letrec (x y) (x1 y1) ((call (toplevel foo)) (call (toplevel bar)))
- (primcall + (lexical x x1) (lexical y y1)))
- (program () (std-prelude 0 4 #f) (label _)
- (void) (void) ;; what are these?
- (bind (x #t 0) (y #t 1))
- (lexical #t #t box 1) (lexical #t #t box 0)
- (call new-frame 0) (toplevel ref foo) (call call 0)
- (call new-frame 0) (toplevel ref bar) (call call 0)
- (bind (x #f 2) (y #f 3)) (lexical #t #f set 3) (lexical #t #f set
2)
- (lexical #t #f ref 2) (lexical #t #t set 0)
- (lexical #t #f ref 3) (lexical #t #t set 1)
- (void) (lexical #t #f set 2) (void) (lexical #t #f set 3) ;; clear
bindings
- (unbind)
- (lexical #t #t ref 0) (lexical #t #t ref 1)
- (call add 2) (call return 1) (unbind)))
-
- ;; complex bindings in letrec* -> box and set! in order
- (assert-tree-il->glil without-partial-evaluation
- (letrec* (x y) (x1 y1) ((call (toplevel foo)) (call (toplevel bar)))
- (primcall + (lexical x x1) (lexical y y1)))
- (program () (std-prelude 0 2 #f) (label _)
- (void) (void) ;; what are these?
- (bind (x #t 0) (y #t 1))
- (lexical #t #t box 1) (lexical #t #t box 0)
- (call new-frame 0) (toplevel ref foo) (call call 0)
- (lexical #t #t set 0)
- (call new-frame 0) (toplevel ref bar) (call call 0)
- (lexical #t #t set 1)
- (lexical #t #t ref 0)
- (lexical #t #t ref 1)
- (call add 2) (call return 1) (unbind)))
-
- ;; simple bindings in letrec* -> equivalent to letrec
- (assert-tree-il->glil without-partial-evaluation
- (letrec* (x y) (xx yy) ((const 1) (const 2))
- (lexical y yy))
- (program () (std-prelude 0 1 #f) (label _)
- (const 2)
- (bind (y #f 0)) ;; X is removed, and Y is unboxed
- (lexical #t #f set 0)
- (lexical #t #f ref 0)
- (call return 1) (unbind))))
-
-(with-test-prefix "lambda"
- (assert-tree-il->glil
- (lambda ()
- (lambda-case (((x) #f #f #f () (y)) (const 2)) #f))
- (program () (std-prelude 0 0 #f) (label _)
- (program () (std-prelude 1 1 #f)
- (bind (x #f 0)) (label _)
- (const 2) (call return 1) (unbind))
- (call return 1)))
-
- (assert-tree-il->glil
- (lambda ()
- (lambda-case (((x y) #f #f #f () (x1 y1))
- (const 2))
- #f))
- (program () (std-prelude 0 0 #f) (label _)
- (program () (std-prelude 2 2 #f)
- (bind (x #f 0) (y #f 1)) (label _)
- (const 2) (call return 1)
- (unbind))
- (call return 1)))
-
- (assert-tree-il->glil
- (lambda ()
- (lambda-case ((() #f x #f () (y)) (const 2))
- #f))
- (program () (std-prelude 0 0 #f) (label _)
- (program () (opt-prelude 0 0 0 1 #f)
- (bind (x #f 0)) (label _)
- (const 2) (call return 1)
- (unbind))
- (call return 1)))
-
- (assert-tree-il->glil
- (lambda ()
- (lambda-case (((x) #f x1 #f () (y y1)) (const 2))
- #f))
- (program () (std-prelude 0 0 #f) (label _)
- (program () (opt-prelude 1 0 1 2 #f)
- (bind (x #f 0) (x1 #f 1)) (label _)
- (const 2) (call return 1)
- (unbind))
- (call return 1)))
-
- (assert-tree-il->glil
- (lambda ()
- (lambda-case (((x) #f x1 #f () (y y1)) (lexical x y))
- #f))
- (program () (std-prelude 0 0 #f) (label _)
- (program () (opt-prelude 1 0 1 2 #f)
- (bind (x #f 0) (x1 #f 1)) (label _)
- (lexical #t #f ref 0) (call return 1)
- (unbind))
- (call return 1)))
-
- (assert-tree-il->glil
- (lambda ()
- (lambda-case (((x) #f x1 #f () (y y1)) (lexical x1 y1))
- #f))
- (program () (std-prelude 0 0 #f) (label _)
- (program () (opt-prelude 1 0 1 2 #f)
- (bind (x #f 0) (x1 #f 1)) (label _)
- (lexical #t #f ref 1) (call return 1)
- (unbind))
- (call return 1)))
-
- (assert-tree-il->glil
- (lambda ()
- (lambda-case (((x) #f #f #f () (x1))
- (lambda ()
- (lambda-case (((y) #f #f #f () (y1))
- (lexical x x1))
- #f)))
- #f))
- (program () (std-prelude 0 0 #f) (label _)
- (program () (std-prelude 1 1 #f)
- (bind (x #f 0)) (label _)
- (program () (std-prelude 1 1 #f)
- (bind (y #f 0)) (label _)
- (lexical #f #f ref 0) (call return 1)
- (unbind))
- (lexical #t #f ref 0)
- (call make-closure 1)
- (call return 1)
- (unbind))
- (call return 1))))
-
-(with-test-prefix "sequence"
- (assert-tree-il->glil
- (begin (begin (const 2) (const #f)) (const #t))
- (program () (std-prelude 0 0 #f) (label _)
- (const #t) (call return 1)))
-
- (assert-tree-il->glil
- ;; This gets simplified by `peval'.
- (primcall null? (begin (const #f) (const 2)))
- (program () (std-prelude 0 0 #f) (label _)
- (const #f) (call return 1))))
-
-(with-test-prefix "values"
- (assert-tree-il->glil
- (primcall values
- (primcall values (const 1) (const 2)))
- (program () (std-prelude 0 0 #f) (label _)
- (const 1) (call return 1)))
-
- (assert-tree-il->glil
- (primcall values
- (primcall values (const 1) (const 2))
- (const 3))
- (program () (std-prelude 0 0 #f) (label _)
- (const 1) (const 3) (call return/values 2)))
-
- (assert-tree-il->glil
- (primcall +
- (primcall values (const 1) (const 2)))
- (program () (std-prelude 0 0 #f) (label _)
- (const 1) (call return 1)))
-
- ;; Testing `(values foo)' in push context with RA.
- (assert-tree-il->glil without-partial-evaluation
- (primcall cdr
- (letrec (lp) (#{lp ~V9KrhVD4PFEL6oCTrLg3A}#)
- ((lambda ((name . lp))
- (lambda-case ((() #f #f #f () ())
- (primcall values (const (one two)))))))
- (call (lexical lp #{lp ~V9KrhVD4PFEL6oCTrLg3A}#))))
- (program () (std-prelude 0 0 #f) (label _)
- (branch br _) ;; entering the fix, jump to :2
- ;; :1 body of lp, jump to :3
- (label _) (bind) (const (one two)) (branch br _) (unbind)
- ;; :2 initial call of lp, jump to :1
- (label _) (bind) (branch br _) (label _) (unbind)
- ;; :3 the push continuation
- (call cdr 1) (call return 1))))
-
-;; FIXME: binding info for or-hacked locals might bork the disassembler,
-;; and could be tightened in any case
-(with-test-prefix "the or hack"
- (assert-tree-il->glil without-partial-evaluation
- (let (x) (y) ((const 1))
- (if (lexical x y)
- (lexical x y)
- (let (a) (b) ((const 2))
- (lexical a b))))
- (program () (std-prelude 0 1 #f) (label _)
- (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)
- (label ,l2)
- (const 2) (bind (a #f 0)) (lexical #t #f set 0)
- (lexical #t #f ref 0) (call return 1)
- (unbind)
- (unbind))
- (eq? l1 l2))
-
- ;; second bound var is unreferenced
- (assert-tree-il->glil without-partial-evaluation
- (let (x) (y) ((const 1))
- (if (lexical x y)
- (lexical x y)
- (let (a) (b) ((const 2))
- (lexical x y))))
- (program () (std-prelude 0 1 #f) (label _)
- (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)
- (label ,l2)
- (lexical #t #f ref 0) (call return 1)
- (unbind))
- (eq? l1 l2)))
-
-(with-test-prefix "apply"
- (assert-tree-il->glil
- (primcall apply (toplevel foo) (toplevel bar))
- (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (toplevel ref
bar) (call tail-apply 2)))
- (assert-tree-il->glil
- (begin (primcall apply (toplevel foo) (toplevel bar)) (void))
- (program () (std-prelude 0 0 #f) (label _)
- (call new-frame 0) (module private ref (guile) apply)
- (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1)
- (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
- (label ,l4)
- (void) (call return 1))
- (and (eq? l1 l3) (eq? l2 l4)))
- (assert-tree-il->glil
- (call (toplevel foo) (call (toplevel apply) (toplevel bar) (toplevel baz)))
- (program () (std-prelude 0 0 #f) (label _)
- (toplevel ref foo)
- (call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call
apply 2)
- (call tail-call 1))))
-
-(with-test-prefix "call/cc"
- (assert-tree-il->glil
- (primcall call-with-current-continuation (toplevel foo))
- (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call
tail-call/cc 1)))
- (assert-tree-il->glil
- (begin (primcall call-with-current-continuation (toplevel foo)) (void))
- (program () (std-prelude 0 0 #f) (label _)
- (call new-frame 0)
- (module private ref (guile) call-with-current-continuation)
- (toplevel ref foo) (mv-call 1 ,l1)
- (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
- (label ,l4)
- (void) (call return 1))
- (and (eq? l1 l3) (eq? l2 l4)))
- (assert-tree-il->glil
- (call (toplevel foo)
- (call (toplevel call-with-current-continuation) (toplevel bar)))
- (program () (std-prelude 0 0 #f) (label _)
- (toplevel ref foo)
- (toplevel ref bar) (call call/cc 1)
- (call tail-call 1))))
-
-(with-test-prefix "labels allocation"
+(with-test-prefix "contification"
(pass-if "http://debbugs.gnu.org/9769";
((compile '(lambda ()
(let ((fail (lambda () #f)))
(let ((test (lambda () (fail))))
(test))
#t))
- ;; Prevent inlining. We're testing analyze.scm's
- ;; labels allocator here, and inlining it will
- ;; reduce the entire thing to #t.
+ ;; Prevent inlining. We're testing contificatoin here,
+ ;; and inlining it will reduce the entire thing to #t.
#:opts '(#:partial-eval? #f)))))
@@ -754,6 +179,11 @@
(lexical x x1)
(lexical y y1)))
#f))))))
+ (define (strip-source x)
+ (post-order (lambda (x)
+ (set! (tree-il-src x) #f)
+ x)
+ x))
(and (= result 12)
(equal? (map strip-source (list-head (reverse ups) 3))
(list (make-toplevel-ref #f '+)
@@ -864,7 +294,7 @@
(let ((_ 'underscore)
(#{gensym name}# 'ignore-me))
#t))
- #:to 'assembly
+ #:to 'cps
#:opts %opts-w-unused))))))
(with-test-prefix "unused-toplevel"
@@ -875,7 +305,7 @@
(let ((in (open-input-string
"(define foo 2) foo")))
(read-and-compile in
- #:to 'assembly
+ #:to 'cps
#:opts %opts-w-unused-toplevel))))))
(pass-if "used before definition"
@@ -884,7 +314,7 @@
(let ((in (open-input-string
"(define (bar) foo) (define foo 2) (bar)")))
(read-and-compile in
- #:to 'assembly
+ #:to 'cps
#:opts %opts-w-unused-toplevel))))))
(pass-if "unused but public"
@@ -894,7 +324,7 @@
(null? (call-with-warnings
(lambda ()
(read-and-compile in
- #:to 'assembly
+ #:to 'cps
#:opts %opts-w-unused-toplevel))))))
(pass-if "unused but public (more)"
@@ -906,14 +336,14 @@
(null? (call-with-warnings
(lambda ()
(read-and-compile in
- #:to 'assembly
+ #:to 'cps
#:opts %opts-w-unused-toplevel))))))
(pass-if "unused but define-public"
(null? (call-with-warnings
(lambda ()
(compile '(define-public foo 2)
- #:to 'assembly
+ #:to 'cps
#:opts %opts-w-unused-toplevel)))))
(pass-if "used by macro"
@@ -927,14 +357,14 @@
(define-syntax baz
(syntax-rules () ((_) (bar))))")))
(read-and-compile in
- #:to 'assembly
+ #:to 'cps
#:opts %opts-w-unused-toplevel))))))
(pass-if "unused"
(let ((w (call-with-warnings
(lambda ()
(compile '(define foo 2)
- #:to 'assembly
+ #:to 'cps
#:opts %opts-w-unused-toplevel)))))
(and (= (length w) 1)
(number? (string-contains (car w)
@@ -945,7 +375,7 @@
(let ((w (call-with-warnings
(lambda ()
(compile '(define (foo) (foo))
- #:to 'assembly
+ #:to 'cps
#:opts %opts-w-unused-toplevel)))))
(and (= (length w) 1)
(number? (string-contains (car w)
@@ -958,7 +388,7 @@
(w (call-with-warnings
(lambda ()
(read-and-compile in
- #:to 'assembly
+ #:to 'cps
#:opts %opts-w-unused-toplevel)))))
(and (= (length w) 2)
(number? (string-contains (car w)
@@ -972,7 +402,7 @@
(null? (call-with-warnings
(lambda ()
(compile '(define #{gensym name}# 'ignore-me)
- #:to 'assembly
+ #:to 'cps
#:opts %opts-w-unused-toplevel))))))
(with-test-prefix "unbound variable"
@@ -987,7 +417,7 @@
(w (call-with-warnings
(lambda ()
(compile v
- #:to 'assembly
+ #:to 'cps
#:opts %opts-w-unbound)))))
(and (= (length w) 1)
(number? (string-contains (car w)
@@ -999,7 +429,7 @@
(w (call-with-warnings
(lambda ()
(compile `(set! ,v 7)
- #:to 'assembly
+ #:to 'cps
#:opts %opts-w-unbound)))))
(and (= (length w) 1)
(number? (string-contains (car w)
@@ -1016,7 +446,7 @@
(lambda ()
(compile v
#:env m
- #:to 'assembly
+ #:to 'cps
#:opts %opts-w-unbound))))))
(pass-if "module-local top-level is visible after"
@@ -1038,14 +468,14 @@
(lambda ()
(compile '(lambda* (x #:optional y z) (list x y z))
#:opts %opts-w-unbound
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "keyword arguments are visible"
(null? (call-with-warnings
(lambda ()
(compile '(lambda* (x #:key y z) (list x y z))
#:opts %opts-w-unbound
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "GOOPS definitions are visible"
(let ((m (make-module))
@@ -1074,7 +504,7 @@
(lambda ()
(compile '((lambda (x y) (or x y)) 1 2 3 4 5)
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong number of arguments to")))))
@@ -1084,7 +514,7 @@
(compile '(let ((f (lambda (x y) (+ x y))))
(f 2))
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong number of arguments to")))))
@@ -1094,7 +524,7 @@
(lambda ()
(compile '(cons 1 2 3 4)
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong number of arguments to")))))
@@ -1104,7 +534,7 @@
(lambda ()
(compile '(let ((f cons)) (f 1 2 3 4))
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong number of arguments to")))))
@@ -1116,7 +546,7 @@
(let ((g f))
(f 1 2 3 4)))
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong number of arguments to")))))
@@ -1128,7 +558,7 @@
(let ((g f))
(g 1)))
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong number of arguments to")))))
@@ -1142,7 +572,7 @@
(odd?)))))
(odd? 1))
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong number of arguments to")))))
@@ -1158,7 +588,7 @@
(f 1 2)
(f 1 2 3)))
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "case-lambda with wrong number of arguments"
(let ((w (call-with-warnings
@@ -1168,7 +598,7 @@
((x y) 2))))
(f 1 2 3))
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong number of arguments to")))))
@@ -1185,7 +615,7 @@
(f #:y 2)
(f 1 2 #:z 3)))
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "case-lambda* with wrong arguments"
(let ((w (call-with-warnings
@@ -1197,7 +627,7 @@
(list (f)
(f 1 #:z 3)))
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 2)
(null? (filter (lambda (w)
(not
@@ -1213,7 +643,7 @@
(p (+ (p) 1))
(p))
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "top-level applicable struct with wrong arguments"
(let ((w (call-with-warnings
@@ -1221,7 +651,7 @@
(compile '(let ((p current-warning-port))
(p 1 2 3))
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong number of arguments to")))))
@@ -1234,7 +664,7 @@
(define (f) 1)")))
(read-and-compile in
#:opts %opts-w-arity
- #:to 'assembly))))))
+ #:to 'cps))))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong number of arguments to")))))
@@ -1247,7 +677,7 @@
(define (g) (f))")))
(read-and-compile in
#:opts %opts-w-arity
- #:to 'assembly))))))
+ #:to 'cps))))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong number of arguments to")))))
@@ -1260,7 +690,7 @@
(define (foo x) (cons))")))
(read-and-compile in
#:opts %opts-w-arity
- #:to 'assembly))))))
+ #:to 'cps))))))
(pass-if "keyword not passed and quiet"
(null? (call-with-warnings
@@ -1268,7 +698,7 @@
(compile '(let ((f (lambda* (x #:key y) y)))
(f 2))
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "keyword passed and quiet"
(null? (call-with-warnings
@@ -1276,7 +706,7 @@
(compile '(let ((f (lambda* (x #:key y) y)))
(f 2 #:y 3))
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "keyword passed to global and quiet"
(null? (call-with-warnings
@@ -1286,7 +716,7 @@
(compile '(+ 2 3) #:env (current-module))")))
(read-and-compile in
#:opts %opts-w-arity
- #:to 'assembly))))))
+ #:to 'cps))))))
(pass-if "extra keyword"
(let ((w (call-with-warnings
@@ -1294,7 +724,7 @@
(compile '(let ((f (lambda* (x #:key y) y)))
(f 2 #:Z 3))
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong number of arguments to")))))
@@ -1306,7 +736,7 @@
y)))
(f 2 #:Z 3))
#:opts %opts-w-arity
- #:to 'assembly))))))
+ #:to 'cps))))))
(with-test-prefix "format"
@@ -1315,28 +745,28 @@
(lambda ()
(compile '(format #t "hey!")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "quiet (1 arg)"
(null? (call-with-warnings
(lambda ()
(compile '(format #t "hey ~A!" "you")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "quiet (2 args)"
(null? (call-with-warnings
(lambda ()
(compile '(format #t "~A ~A!" "hello" "world")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "wrong port arg"
(let ((w (call-with-warnings
(lambda ()
(compile '(format 10 "foo")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong port argument")))))
@@ -1346,7 +776,7 @@
(lambda ()
(compile '(format #f fmt)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"non-literal format string")))))
@@ -1356,14 +786,14 @@
(lambda ()
(compile '(format #t (gettext "~A ~A!") "hello" "world")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "non-literal format string using gettext as _"
(null? (call-with-warnings
(lambda ()
(compile '(format #t (_ "~A ~A!") "hello" "world")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "non-literal format string using gettext as top-level _"
(null? (call-with-warnings
@@ -1372,14 +802,14 @@
(define (_ s) (gettext s "my-domain"))
(format #t (_ "~A ~A!") "hello" "world"))
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "non-literal format string using gettext as module-ref _"
(null? (call-with-warnings
(lambda ()
(compile '(format #t ((@@ (foo) _) "~A ~A!") "hello" "world")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "non-literal format string using gettext as lexical _"
(null? (call-with-warnings
@@ -1388,7 +818,7 @@
(gettext s "my-domain"))))
(format #t (_ "~A ~A!") "hello" "world"))
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "non-literal format string using ngettext"
(null? (call-with-warnings
@@ -1396,14 +826,14 @@
(compile '(format #t
(ngettext "~a thing" "~a things" n "dom") n)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "non-literal format string using ngettext as N_"
(null? (call-with-warnings
(lambda ()
(compile '(format #t (N_ "~a thing" "~a things" n) n)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "non-literal format string with (define _ gettext)"
(null? (call-with-warnings
@@ -1413,14 +843,14 @@
(define (foo)
(format #t (_ "~A ~A!") "hello" "world")))
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "wrong format string"
(let ((w (call-with-warnings
(lambda ()
(compile '(format #f 'not-a-string)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong format string")))))
@@ -1430,7 +860,7 @@
(lambda ()
(compile '(format "shbweeb")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong number of arguments")))))
@@ -1441,14 +871,14 @@
(compile '((@ (ice-9 format) format) some-port
"~&~3_~~ ~\n~12they~% ~!~|~/~q")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "one missing argument"
(let ((w (call-with-warnings
(lambda ()
(compile '(format some-port "foo ~A~%")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 1, got 0")))))
@@ -1458,7 +888,7 @@
(lambda ()
(compile '(format some-port (gettext "foo ~A~%"))
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 1, got 0")))))
@@ -1469,7 +899,7 @@
(compile '((@ (ice-9 format) format) #f
"foo ~10,2f and bar ~S~%")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 2, got 0")))))
@@ -1479,7 +909,7 @@
(lambda ()
(compile '(format #t "foo ~A and ~S~%" hey)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 2, got 1")))))
@@ -1489,7 +919,7 @@
(lambda ()
(compile '(format #t "foo ~A~%" 1 2)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 1, got 2")))))
@@ -1500,7 +930,7 @@
(compile '((@ (ice-9 format) format) #t
"foo ~h ~a~%" 123.4 'bar)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "~:h with locale object"
(null? (call-with-warnings
@@ -1508,14 +938,14 @@
(compile '((@ (ice-9 format) format) #t
"foo ~:h~%" 123.4 %global-locale)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "~:h without locale object"
(let ((w (call-with-warnings
(lambda ()
(compile '((@ (ice-9 format) format) #t "foo ~,2:h" 123.4)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 2, got 1")))))
@@ -1527,7 +957,7 @@
(compile '((@ (ice-9 format) format) #f "~A
~[foo~;bar~;baz~;~] ~10,2f"
'a 1 3.14)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "literals with selector"
(let ((w (call-with-warnings
@@ -1535,7 +965,7 @@
(compile '((@ (ice-9 format) format) #f
"~2[foo~;bar~;baz~;~] ~A"
1 'dont-ignore-me)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 1, got 2")))))
@@ -1545,7 +975,7 @@
(lambda ()
(compile '((@ (ice-9 format) format) #f "~[~a~;~a~]")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 2, got 0")))))
@@ -1555,7 +985,7 @@
(lambda ()
(compile '((@ (ice-9 format) format) #f
"~1[chbouib~;~a~]")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 1, got 0")))))
@@ -1565,7 +995,7 @@
(lambda ()
(compile '((@ (ice-9 format) format) #f
"~[chbouib~;~a~;~2*~a~]")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 1 to 4, got 0")))))
@@ -1575,7 +1005,7 @@
(lambda ()
(compile '((@ (ice-9 format) format) #f "address@hidden")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 1, got 0")))))
@@ -1585,7 +1015,7 @@
(lambda ()
(compile '((@ (ice-9 format) format) #f
"~:[~[hey~;~a~;~va~]~;~3*~]")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 2 to 4, got 0")))))
@@ -1595,7 +1025,7 @@
(lambda ()
(compile '((@ (ice-9 format) format) #f "~[unterminated")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"unterminated conditional")))))
@@ -1605,7 +1035,7 @@
(lambda ()
(compile '((@ (ice-9 format) format) #f "foo~;bar")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"unexpected")))))
@@ -1615,7 +1045,7 @@
(lambda ()
(compile '((@ (ice-9 format) format) #f "foo~]")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"unexpected"))))))
@@ -1627,14 +1057,14 @@
'hello '("ladies" "and")
'gentlemen)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "~{...~}, too many args"
(let ((w (call-with-warnings
(lambda ()
(compile '((@ (ice-9 format) format) #f "~{~S~}" 1 2 3)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 1, got 3")))))
@@ -1644,14 +1074,14 @@
(lambda ()
(compile '((@ (ice-9 format) format) #f "address@hidden" 1 2
3)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "address@hidden, too few args"
(let ((w (call-with-warnings
(lambda ()
(compile '((@ (ice-9 format) format) #f "~A address@hidden")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected at least 1, got 0")))))
@@ -1661,7 +1091,7 @@
(lambda ()
(compile '((@ (ice-9 format) format) #f "~{")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"unterminated")))))
@@ -1671,14 +1101,14 @@
(lambda ()
(compile '((@ (ice-9 format) format) #f "~:@(~A ~A~)" 'foo
'bar)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "~v"
(let ((w (call-with-warnings
(lambda ()
(compile '((@ (ice-9 format) format) #f "~v_foo")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 1, got 0")))))
@@ -1687,7 +1117,7 @@
(lambda ()
(compile '((@ (ice-9 format) format) #f "~v:@y" 1 123)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "~*"
@@ -1695,7 +1125,7 @@
(lambda ()
(compile '((@ (ice-9 format) format) #f "~2*~a" 'a 'b)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 3, got 2")))))
@@ -1705,21 +1135,21 @@
(lambda ()
(compile '((@ (ice-9 format) format) #f "~?" "~d ~d" '(1 2))
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "~^"
(null? (call-with-warnings
(lambda ()
(compile '((@ (ice-9 format) format) #f "~a ~^ ~a" 0 1)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "~^, too few args"
(let ((w (call-with-warnings
(lambda ()
(compile '((@ (ice-9 format) format) #f "~a ~^ ~a")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected at least 1, got 0")))))
@@ -1730,7 +1160,7 @@
(compile '((@ (ice-9 format) format) some-port
"~#~ ~,,-2f ~,,+2f ~'A~" 1234 1234)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "complex 1"
(let ((w (call-with-warnings
@@ -1739,7 +1169,7 @@
"address@hidden address@hidden;;
address@hidden@[~61t at ~a~]\n"
1 2 3 4 5 6)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 4, got 6")))))
@@ -1751,7 +1181,7 @@
"~:(~A~) Commands~:[~; [abbrev]~]:~2%"
1 2 3 4)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 2, got 4")))))
@@ -1761,7 +1191,7 @@
(lambda ()
(compile '((@ (ice-9 format) format) #f
"address@hidden:[~*~3_~;~3d~] ~v:@y~%")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 5, got 0")))))
@@ -1775,7 +1205,7 @@
(i9-format #t \"yo! ~A\" 1 2)")))
(read-and-compile in
#:opts %opts-w-format
- #:to 'assembly))))))
+ #:to 'cps))))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 1, got 2")))))
@@ -1786,7 +1216,7 @@
(compile '(let ((format chbouib))
(format #t "not ~A a format string"))
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(with-test-prefix "simple-format"
@@ -1795,14 +1225,14 @@
(lambda ()
(compile '(simple-format #t "foo ~a bar ~s ~%~~" 1 2)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "wrong number of args"
(let ((w (call-with-warnings
(lambda ()
(compile '(simple-format #t "foo ~a ~s~%" 'one-missing)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w) "wrong number")))))
@@ -1811,7 +1241,7 @@
(lambda ()
(compile '(simple-format #t "foo ~x~%" 16)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w) "unsupported format
option")))))
@@ -1820,7 +1250,7 @@
(lambda ()
(compile '(simple-format #t (gettext "foo ~2f~%") 3.14)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w) "unsupported format
option")))))
@@ -1829,7 +1259,7 @@
(lambda ()
(compile '(simple-format #t (ngettext "s ~x" "p ~x" x) x)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w) "unsupported format
option")))))))
@@ -1840,7 +1270,7 @@
(lambda ()
(compile '(case x ((1) 'one) ((2) 'two))
#:opts %opts-w-duplicate-case-datum
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "one duplicate"
(let ((w (call-with-warnings
@@ -1850,7 +1280,7 @@
((2) 'two)
((1) 'one-again))
#:opts %opts-w-duplicate-case-datum
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w) "duplicate")))))
@@ -1861,7 +1291,7 @@
((1 2 3) 'a)
((1) 'one))
#:opts %opts-w-duplicate-case-datum
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w) "duplicate"))))))
@@ -1872,7 +1302,7 @@
(lambda ()
(compile '(case x ((1) 'one) ((2) 'two))
#:opts %opts-w-bad-case-datum
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "not eqv?"
(let ((w (call-with-warnings
@@ -1881,7 +1311,7 @@
((1) 'one)
(("bad") 'bad))
#:opts %opts-w-bad-case-datum
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"cannot be meaningfully compared")))))
@@ -1892,7 +1322,7 @@
(compile '(case x
((1 (2) 3) 'a))
#:opts %opts-w-duplicate-case-datum
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"cannot be meaningfully
compared")))))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-376-g84680d2,
Andy Wingo <=