[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-25-g82e299f
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-25-g82e299f |
|
Date: |
Sun, 09 Jun 2013 18:08:42 +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=82e299f3864c663c45ddb960112a12b4f17d68c9
The branch, master has been updated
via 82e299f3864c663c45ddb960112a12b4f17d68c9 (commit)
via e65f80af42aefe13fe870b92b912cfd0156a1ac1 (commit)
via e2cbf527c48fba803ef0bada712c5514f45ec4e4 (commit)
via cb86cbd71db17273f6dfdfdecae450515cbdfc12 (commit)
via e78991aa36922575d26842eb670d1b09a44bd534 (commit)
via f5473fbaafd3c8332645a6e00b5838ceb758fcb2 (commit)
via 90a7976eb862f8b04b92c9b765ae2d49052a16f7 (commit)
from 510ca12687b2137031d537be7b99bcf6d5306e41 (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 82e299f3864c663c45ddb960112a12b4f17d68c9
Author: Andy Wingo <address@hidden>
Date: Wed May 1 22:45:19 2013 +0200
Add RTL disassembler
* module/Makefile.am:
* module/system/vm/disassembler.scm: New module.
* module/system/repl/command.scm (disassemble): Work with RTL programs.
commit e65f80af42aefe13fe870b92b912cfd0156a1ac1
Author: Andy Wingo <address@hidden>
Date: Sun May 5 18:26:53 2013 +0200
RTL programs print with their name
* libguile/print.c (iprin1): Use scm_i_program_print for RTL programs
too.
* libguile/procprop.c (scm_procedure_name): For RTL programs, call
scm_i_rtl_program_name if there is no override.
* libguile/programs.h:
* libguile/programs.c (scm_i_rtl_program_name): New helper, dispatches
to (system vm program).
(scm_i_program_print): For RTL programs, the fallback prints the code
pointer too.
* module/system/vm/program.scm (rtl-program-name): Use the debug info to
get an RTL program name.
(write-program): Work with RTL programs too.
* test-suite/tests/rtl.test ("procedure name"): Add test.
commit e2cbf527c48fba803ef0bada712c5514f45ec4e4
Author: Andy Wingo <address@hidden>
Date: Sun May 5 17:52:59 2013 +0200
move procedure-name and procedure-source to procprop.c
* libguile/procprop.h:
* libguile/procprop.c (scm_procedure_name, scm_procedure_source): Move
these functions here, from debug.[ch].
commit cb86cbd71db17273f6dfdfdecae450515cbdfc12
Author: Andy Wingo <address@hidden>
Date: Wed May 1 22:17:51 2013 +0200
Add runtime support for reading debug information from ELF
* module/Makefile.am:
* module/system/vm/debug.scm: New module.
* module/system/vm/elf.scm (elf-section-by-name): New helper.
(elf-symbol-table-len): New helper.
* test-suite/tests/rtl.test: Add test for finding debug info.
commit e78991aa36922575d26842eb670d1b09a44bd534
Author: Andy Wingo <address@hidden>
Date: Mon May 28 12:37:56 2012 +0200
Add RTL assembler
* module/Makefile.am:
* module/system/vm/assembler.scm: New module, implementing an assembler
for RTL.
* test-suite/Makefile.am:
* test-suite/tests/rtl.test: New test suite.
* module/system/vm/elf.scm (make-elf-symbol*): Add constructor; export
as make-elf-symbol.
(elf-symbol-len): New export.
(write-elf32-symbol, write-elf64-symbol): New helpers.
(write-elf-symbol): New export.
commit f5473fbaafd3c8332645a6e00b5838ceb758fcb2
Author: Andy Wingo <address@hidden>
Date: Sun Jun 9 16:03:18 2013 +0200
linker string tables are stateful objects
* module/system/vm/linker.scm (make-string-table): Rework to be a
stateful object instead of a function object. Works better in this
case. Adapt users.
(string-table-intern!): Rename from string-table-intern, and just
return the index of the string.
(link-string-table!): Rename from link-string-table, and set a flag to
prevent interning strings after linking, as that's not going to work
well.
* module/language/objcode/elf.scm (bytecode->elf): Adapt.
commit 90a7976eb862f8b04b92c9b765ae2d49052a16f7
Author: Andy Wingo <address@hidden>
Date: Sat Jun 8 14:58:10 2013 +0200
const cleanups in instructions.c
* libguile/instructions.c (fetch_rtl_instruction_table)
(fetch_instruction_table): Make the returned table const. Adapt
callers.
(scm_rtl_instruction_list): Fix comment about format of return value.
-----------------------------------------------------------------------
Summary of changes:
libguile/debug.c | 41 +--
libguile/debug.h | 4 +-
libguile/instructions.c | 22 +-
libguile/print.c | 2 -
libguile/procprop.c | 60 ++-
libguile/procprop.h | 4 +-
libguile/programs.c | 33 +-
libguile/programs.h | 3 +-
module/Makefile.am | 3 +
module/language/objcode/elf.scm | 8 +-
module/system/repl/command.scm | 15 +-
module/system/vm/assembler.scm | 1088 +++++++++++++++++++++++++++++++++++++
module/system/vm/debug.scm | 161 ++++++
module/system/vm/disassembler.scm | 350 ++++++++++++
module/system/vm/elf.scm | 63 ++-
module/system/vm/linker.scm | 78 ++--
module/system/vm/program.scm | 12 +-
test-suite/Makefile.am | 1 +
test-suite/tests/rtl.test | 280 ++++++++++
19 files changed, 2110 insertions(+), 118 deletions(-)
create mode 100644 module/system/vm/assembler.scm
create mode 100644 module/system/vm/debug.scm
create mode 100644 module/system/vm/disassembler.scm
create mode 100644 test-suite/tests/rtl.test
diff --git a/libguile/debug.c b/libguile/debug.c
index b01864f..9e63f2c 100644
--- a/libguile/debug.c
+++ b/libguile/debug.c
@@ -1,5 +1,5 @@
/* Debugging extensions for Guile
- * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008,
2009, 2010, 2011, 2012 Free Software Foundation
+ * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008,
2009, 2010, 2011, 2012, 2013 Free Software Foundation
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -115,45 +115,6 @@ SCM_DEFINE (scm_debug_options, "debug-options-interface",
0, 1, 0,
}
#undef FUNC_NAME
-
-SCM_SYMBOL (scm_sym_source, "source");
-
-SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
- (SCM proc),
- "Return the name of the procedure @var{proc}")
-#define FUNC_NAME s_scm_procedure_name
-{
- SCM_VALIDATE_PROC (1, proc);
- while (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
- proc = SCM_STRUCT_PROCEDURE (proc);
- return scm_procedure_property (proc, scm_sym_name);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
- (SCM proc),
- "Return the source of the procedure @var{proc}.")
-#define FUNC_NAME s_scm_procedure_source
-{
- SCM src;
- SCM_VALIDATE_PROC (1, proc);
-
- do
- {
- src = scm_procedure_property (proc, scm_sym_source);
- if (scm_is_true (src))
- return src;
-
- if (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc)
- && SCM_HEAP_OBJECT_P ((proc = SCM_STRUCT_PROCEDURE (proc))))
- continue;
- }
- while (0);
-
- return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
diff --git a/libguile/debug.h b/libguile/debug.h
index 362d9b7..e535a6a 100644
--- a/libguile/debug.h
+++ b/libguile/debug.h
@@ -3,7 +3,7 @@
#ifndef SCM_DEBUG_H
#define SCM_DEBUG_H
-/* Copyright (C)
1995,1996,1998,1999,2000,2001,2002,2004,2008,2009,2010,2011,2012
+/* Copyright (C)
1995,1996,1998,1999,2000,2001,2002,2004,2008,2009,2010,2011,2012,2013
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -44,8 +44,6 @@ typedef union scm_t_debug_info
SCM_API SCM scm_local_eval (SCM exp, SCM env);
SCM_API SCM scm_reverse_lookup (SCM env, SCM data);
-SCM_API SCM scm_procedure_source (SCM proc);
-SCM_API SCM scm_procedure_name (SCM proc);
SCM_API SCM scm_debug_options (SCM setting);
SCM_INTERNAL void scm_init_debug (void);
diff --git a/libguile/instructions.c b/libguile/instructions.c
index 08f7cd6..9e8ccb4 100644
--- a/libguile/instructions.c
+++ b/libguile/instructions.c
@@ -127,7 +127,7 @@ struct scm_rtl_instruction {
static scm_i_pthread_mutex_t itable_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
-static struct scm_instruction*
+static const struct scm_instruction*
fetch_instruction_table ()
{
static struct scm_instruction *table = NULL;
@@ -159,7 +159,7 @@ fetch_instruction_table ()
return table;
}
-static struct scm_rtl_instruction*
+static const struct scm_rtl_instruction*
fetch_rtl_instruction_table ()
{
static struct scm_rtl_instruction *table = NULL;
@@ -190,11 +190,11 @@ fetch_rtl_instruction_table ()
return table;
}
-static struct scm_instruction *
+static const struct scm_instruction *
scm_lookup_instruction_by_name (SCM name)
{
static SCM instructions_by_name = SCM_BOOL_F;
- struct scm_instruction *table = fetch_instruction_table ();
+ const struct scm_instruction *table = fetch_instruction_table ();
SCM op;
if (SCM_UNLIKELY (scm_is_false (instructions_by_name)))
@@ -227,7 +227,7 @@ SCM_DEFINE (scm_instruction_list, "instruction-list", 0, 0,
0,
{
SCM list = SCM_EOL;
int i;
- struct scm_instruction *ip = fetch_instruction_table ();
+ const struct scm_instruction *ip = fetch_instruction_table ();
for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
if (ip[i].name)
list = scm_cons (ip[i].symname, list);
@@ -242,7 +242,7 @@ SCM_DEFINE (scm_rtl_instruction_list,
"rtl-instruction-list", 0, 0, 0,
{
SCM list = SCM_EOL;
int i;
- struct scm_rtl_instruction *ip = fetch_rtl_instruction_table ();
+ const struct scm_rtl_instruction *ip = fetch_rtl_instruction_table ();
for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
if (ip[i].name)
{
@@ -250,7 +250,7 @@ SCM_DEFINE (scm_rtl_instruction_list,
"rtl-instruction-list", 0, 0, 0,
SCM tail = SCM_EOL;
int len;
- /* Format: (name opcode len rest? out br in) */
+ /* Format: (name opcode word0 word1 ...) */
if (WORD_TYPE (3, meta))
len = 4;
@@ -300,7 +300,7 @@ SCM_DEFINE (scm_instruction_length, "instruction-length",
1, 0, 0,
"")
#define FUNC_NAME s_scm_instruction_length
{
- struct scm_instruction *ip;
+ const struct scm_instruction *ip;
SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip);
return SCM_I_MAKINUM (ip->len);
}
@@ -311,7 +311,7 @@ SCM_DEFINE (scm_instruction_pops, "instruction-pops", 1, 0,
0,
"")
#define FUNC_NAME s_scm_instruction_pops
{
- struct scm_instruction *ip;
+ const struct scm_instruction *ip;
SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip);
return SCM_I_MAKINUM (ip->npop);
}
@@ -322,7 +322,7 @@ SCM_DEFINE (scm_instruction_pushes, "instruction-pushes",
1, 0, 0,
"")
#define FUNC_NAME s_scm_instruction_pushes
{
- struct scm_instruction *ip;
+ const struct scm_instruction *ip;
SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip);
return SCM_I_MAKINUM (ip->npush);
}
@@ -333,7 +333,7 @@ SCM_DEFINE (scm_instruction_to_opcode,
"instruction->opcode", 1, 0, 0,
"")
#define FUNC_NAME s_scm_instruction_to_opcode
{
- struct scm_instruction *ip;
+ const struct scm_instruction *ip;
SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip);
return SCM_I_MAKINUM (ip->opcode);
}
diff --git a/libguile/print.c b/libguile/print.c
index f912a35..50f5a3e 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -657,8 +657,6 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
scm_i_variable_print (exp, port, pstate);
break;
case scm_tc7_rtl_program:
- scm_i_rtl_program_print (exp, port, pstate);
- break;
case scm_tc7_program:
scm_i_program_print (exp, port, pstate);
break;
diff --git a/libguile/procprop.c b/libguile/procprop.c
index d37495b..4809702 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,2000,2001,2003,2004, 2006, 2008, 2009, 2010,
2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001,2003,2004, 2006, 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
@@ -212,8 +212,66 @@ SCM_DEFINE (scm_set_procedure_property_x,
"set-procedure-property!", 3, 0, 0,
}
#undef FUNC_NAME
+
+SCM_SYMBOL (scm_sym_source, "source");
+
+
+SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
+ (SCM proc),
+ "Return the name of the procedure @var{proc}")
+#define FUNC_NAME s_scm_procedure_name
+{
+ SCM props, ret;
+
+ SCM_VALIDATE_PROC (1, proc);
+
+ while (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
+ proc = SCM_STRUCT_PROCEDURE (proc);
+
+ props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
+
+ if (scm_is_pair (props))
+ ret = scm_assq_ref (props, scm_sym_name);
+ else if (SCM_RTL_PROGRAM_P (proc))
+ ret = scm_i_rtl_program_name (proc);
+ else if (SCM_PROGRAM_P (proc))
+ ret = scm_assq_ref (scm_i_program_properties (proc), scm_sym_name);
+ else
+ ret = SCM_BOOL_F;
+
+ return ret;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
+ (SCM proc),
+ "Return the source of the procedure @var{proc}.")
+#define FUNC_NAME s_scm_procedure_source
+{
+ SCM src;
+ SCM_VALIDATE_PROC (1, proc);
+
+ do
+ {
+ src = scm_procedure_property (proc, scm_sym_source);
+ if (scm_is_true (src))
+ return src;
+
+ if (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc)
+ && SCM_HEAP_OBJECT_P ((proc = SCM_STRUCT_PROCEDURE (proc))))
+ continue;
+ }
+ while (0);
+
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+
+
void
scm_init_procprop ()
diff --git a/libguile/procprop.h b/libguile/procprop.h
index 88e44ec..13fbe46 100644
--- a/libguile/procprop.h
+++ b/libguile/procprop.h
@@ -3,7 +3,7 @@
#ifndef SCM_PROCPROP_H
#define SCM_PROCPROP_H
-/* Copyright (C) 1995,1996,1998,2000, 2006, 2008, 2009, 2010, 2011 Free
Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000, 2006, 2008, 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
@@ -40,6 +40,8 @@ SCM_API SCM scm_procedure_properties (SCM proc);
SCM_API SCM scm_set_procedure_properties_x (SCM proc, SCM alist);
SCM_API SCM scm_procedure_property (SCM proc, SCM key);
SCM_API SCM scm_set_procedure_property_x (SCM proc, SCM key, SCM val);
+SCM_API SCM scm_procedure_source (SCM proc);
+SCM_API SCM scm_procedure_name (SCM proc);
SCM_INTERNAL void scm_init_procprop (void);
#endif /* SCM_PROCPROP_H */
diff --git a/libguile/programs.c b/libguile/programs.c
index eb5972a..d356915 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -111,14 +111,16 @@ SCM_DEFINE (scm_rtl_program_code, "rtl-program-code", 1,
0, 0,
}
#undef FUNC_NAME
-void
-scm_i_rtl_program_print (SCM program, SCM port, scm_print_state *pstate)
+SCM
+scm_i_rtl_program_name (SCM program)
{
- scm_puts_unlocked ("#<rtl-program ", port);
- scm_uintprint (SCM_UNPACK (program), 16, port);
- scm_putc_unlocked (' ', port);
- scm_uintprint ((scm_t_uintptr) SCM_RTL_PROGRAM_CODE (program), 16, port);
- scm_putc_unlocked ('>', port);
+ static SCM rtl_program_name = SCM_BOOL_F;
+
+ if (scm_is_false (rtl_program_name) && scm_module_system_booted_p)
+ rtl_program_name =
+ scm_c_private_variable ("system vm program", "rtl-program-name");
+
+ return scm_call_1 (scm_variable_ref (rtl_program_name), program);
}
void
@@ -147,9 +149,20 @@ scm_i_program_print (SCM program, SCM port,
scm_print_state *pstate)
}
else if (scm_is_false (write_program) || print_error)
{
- scm_puts_unlocked ("#<program ", port);
- scm_uintprint (SCM_UNPACK (program), 16, port);
- scm_putc_unlocked ('>', port);
+ if (SCM_RTL_PROGRAM_P (program))
+ {
+ scm_puts_unlocked ("#<rtl-program ", port);
+ scm_uintprint (SCM_UNPACK (program), 16, port);
+ scm_putc_unlocked (' ', port);
+ scm_uintprint ((scm_t_uintptr) SCM_RTL_PROGRAM_CODE (program), 16,
port);
+ scm_putc_unlocked ('>', port);
+ }
+ else
+ {
+ scm_puts_unlocked ("#<program ", port);
+ scm_uintprint (SCM_UNPACK (program), 16, port);
+ scm_putc_unlocked ('>', port);
+ }
}
else
{
diff --git a/libguile/programs.h b/libguile/programs.h
index 732594c..fa46135 100644
--- a/libguile/programs.h
+++ b/libguile/programs.h
@@ -44,8 +44,7 @@ SCM_INTERNAL SCM scm_make_rtl_program (SCM bytevector, SCM
byte_offset, SCM free
SCM_INTERNAL SCM scm_rtl_program_p (SCM obj);
SCM_INTERNAL SCM scm_rtl_program_code (SCM program);
-SCM_INTERNAL void scm_i_rtl_program_print (SCM program, SCM port,
- scm_print_state *pstate);
+SCM_INTERNAL SCM scm_i_rtl_program_name (SCM program);
/*
* Programs
diff --git a/module/Makefile.am b/module/Makefile.am
index 0601a05..495d228 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -356,6 +356,9 @@ SYSTEM_SOURCES = \
system/vm/trace.scm \
system/vm/traps.scm \
system/vm/trap-state.scm \
+ system/vm/assembler.scm \
+ system/vm/debug.scm \
+ system/vm/disassembler.scm \
system/vm/vm.scm \
system/foreign.scm \
system/xref.scm \
diff --git a/module/language/objcode/elf.scm b/module/language/objcode/elf.scm
index 981c398..ddbd7b2 100644
--- a/module/language/objcode/elf.scm
+++ b/module/language/objcode/elf.scm
@@ -36,11 +36,7 @@
(define (bytecode->elf bv)
(let ((string-table (make-string-table)))
(define (intern-string! string)
- (call-with-values
- (lambda () (string-table-intern string-table string))
- (lambda (table idx)
- (set! string-table table)
- idx)))
+ (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
@@ -79,7 +75,7 @@
#:type SHT_DYNAMIC #:flags SHF_ALLOC))))
(define (make-string-table index)
(intern-string! ".shstrtab")
- (make-object index '.shstrtab (link-string-table string-table) '()
+ (make-object index '.shstrtab (link-string-table! string-table) '()
#:type SHT_STRTAB #:flags 0))
(let* ((word-size (target-word-size))
(endianness (target-endianness))
diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index 1a6f72a..215451e 100644
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -484,14 +484,21 @@ Run the optimizer on a piece of code and print the
result."
(define (guile:disassemble x)
((@ (language assembly disassemble) disassemble) x))
+(define (disassemble-program x)
+ ((@ (system vm disassembler) disassemble-program) x))
+
(define-meta-command (disassemble repl (form))
"disassemble EXP
Disassemble a compiled procedure."
(let ((obj (repl-eval repl (repl-parse repl form))))
- (if (or (program? obj) (objcode? obj))
- (guile:disassemble obj)
- (format #t "Argument to ,disassemble not a procedure or objcode: ~a~%"
- obj))))
+ (cond
+ ((rtl-program? obj)
+ (disassemble-program obj))
+ ((or (program? obj) (objcode? obj))
+ (guile:disassemble obj))
+ (else
+ (format #t "Argument to ,disassemble not a procedure or objcode: ~a~%"
+ obj)))))
(define-meta-command (disassemble-file repl file)
"disassemble-file FILE
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
new file mode 100644
index 0000000..0a35bdc
--- /dev/null
+++ b/module/system/vm/assembler.scm
@@ -0,0 +1,1088 @@
+;;; Guile RTL assembler
+
+;;; 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
+
+;;; Commentary:
+;;;
+;;; This module implements an assembler that creates an ELF image from
+;;; RTL assembly and macro-assembly. The input can be given in
+;;; s-expression form, like ((OP ARG ...) ...). Internally there is a
+;;; procedural interface, the emit-OP procedures, but that is not
+;;; currently exported.
+;;;
+;;; "Primitive instructions" correspond to RTL VM operations.
+;;; Assemblers for primitive instructions are generated programmatically
+;;; from (rtl-instruction-list), which itself is derived from the VM
+;;; sources. There are also "macro-instructions" like "label" or
+;;; "load-constant" that expand to 0 or more primitive instructions.
+;;;
+;;; The assembler also handles some higher-level tasks, like creating
+;;; the symbol table, other metadata sections, creating a constant table
+;;; for the whole compilation unit, and writing the dynamic section of
+;;; the ELF file along with the appropriate initialization routines.
+;;;
+;;; Most compilers will want to use the trio of make-assembler,
+;;; emit-text, and link-assembly. That will result in the creation of
+;;; an ELF image as a bytevector, which can then be loaded using
+;;; load-thunk-from-memory, or written to disk as a .go file.
+;;;
+;;; Code:
+
+(define-module (system vm assembler)
+ #:use-module (system base target)
+ #:use-module (system vm instruction)
+ #:use-module (system vm elf)
+ #:use-module (system vm linker)
+ #:use-module (system vm objcode)
+ #:use-module (rnrs bytevectors)
+ #:use-module (ice-9 vlist)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-4)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-11)
+ #:export (make-assembler
+ emit-text
+ link-assembly
+ assemble-program))
+
+
+
+
+;;; RTL code consists of 32-bit units, often subdivided in some way.
+;;; These helpers create one 32-bit unit from multiple components.
+
+(define-syntax-rule (pack-u8-u24 x y)
+ (logior x (ash y 8)))
+
+(define-syntax-rule (pack-u8-s24 x y)
+ (logior x (ash (cond
+ ((< 0 (- y) #x800000)
+ (+ y #x1000000))
+ ((<= 0 y #xffffff)
+ y)
+ (else (error "out of range" y)))
+ 8)))
+
+(define-syntax-rule (pack-u1-u7-u24 x y z)
+ (logior x (ash y 1) (ash z 8)))
+
+(define-syntax-rule (pack-u8-u12-u12 x y z)
+ (logior x (ash y 8) (ash z 20)))
+
+(define-syntax-rule (pack-u8-u8-u16 x y z)
+ (logior x (ash y 8) (ash z 16)))
+
+(define-syntax-rule (pack-u8-u8-u8-u8 x y z w)
+ (logior x (ash y 8) (ash z 16) (ash w 24)))
+
+;;; Helpers to read and write 32-bit units in a buffer.
+
+(define-syntax-rule (u32-ref buf n)
+ (bytevector-u32-native-ref buf (* n 4)))
+
+(define-syntax-rule (u32-set! buf n val)
+ (bytevector-u32-native-set! buf (* n 4) val))
+
+(define-syntax-rule (s32-ref buf n)
+ (bytevector-s32-native-ref buf (* n 4)))
+
+(define-syntax-rule (s32-set! buf n val)
+ (bytevector-s32-native-set! buf (* n 4) val))
+
+
+
+
+;;; A <meta> entry collects metadata for one procedure. Procedures are
+;;; written as contiguous ranges of RTL code.
+;;;
+(define-record-type <meta>
+ (make-meta name low-pc high-pc)
+ meta?
+ (name meta-name)
+ (low-pc meta-low-pc)
+ (high-pc meta-high-pc set-meta-high-pc!))
+
+(define-syntax *block-size* (identifier-syntax 32))
+
+;;; An assembler collects all of the words emitted during assembly, and
+;;; also maintains ancillary information such as the constant table, a
+;;; relocation list, and so on.
+;;;
+;;; RTL code consists of 32-bit units. We emit RTL code using native
+;;; endianness. If we're targeting a foreign endianness, we byte-swap
+;;; the bytevector as a whole instead of conditionalizing each access.
+;;;
+(define-record-type <asm>
+ (make-asm cur idx start prev written
+ labels relocs
+ word-size endianness
+ constants inits
+ shstrtab next-section-number
+ meta)
+ asm?
+
+ ;; We write RTL code into what is logically a growable vector,
+ ;; implemented as a list of blocks. asm-cur is the current block, and
+ ;; asm-idx is the current index into that block, in 32-bit units.
+ ;;
+ (cur asm-cur set-asm-cur!)
+ (idx asm-idx set-asm-idx!)
+
+ ;; asm-start is an absolute position, indicating the offset of the
+ ;; beginning of an instruction (in u32 units). It is updated after
+ ;; writing all the words for one primitive instruction. It models the
+ ;; position of the instruction pointer during execution, given that
+ ;; the RTL VM updates the IP only at the end of executing the
+ ;; instruction, and is thus useful for computing offsets between two
+ ;; points in a program.
+ ;;
+ (start asm-start set-asm-start!)
+
+ ;; The list of previously written blocks.
+ ;;
+ (prev asm-prev set-asm-prev!)
+
+ ;; The number of u32 words written in asm-prev, which is the same as
+ ;; the offset of the current block.
+ ;;
+ (written asm-written set-asm-written!)
+
+ ;; An alist of symbol -> position pairs, indicating the labels defined
+ ;; in this compilation unit.
+ ;;
+ (labels asm-labels set-asm-labels!)
+
+ ;; A list of relocations needed by the program text. We use an
+ ;; internal representation for relocations, and handle textualn
+ ;; relative relocations in the assembler. Other kinds of relocations
+ ;; are later reified as linker relocations and resolved by the linker.
+ ;;
+ (relocs asm-relocs set-asm-relocs!)
+
+ ;; Target information.
+ ;;
+ (word-size asm-word-size)
+ (endianness asm-endianness)
+
+ ;; The constant table, as a vhash of object -> label. All constants
+ ;; get de-duplicated and written into separate sections -- either the
+ ;; .rodata section, for read-only data, or .data, for constants that
+ ;; need initialization at load-time (like symbols). Constants can
+ ;; depend on other constants (e.g. a symbol depending on a stringbuf),
+ ;; so order in this table is important.
+ ;;
+ (constants asm-constants set-asm-constants!)
+
+ ;; A list of RTL instructions needed to initialize the constants.
+ ;; Will run in a thunk with 2 local variables.
+ ;;
+ (inits asm-inits set-asm-inits!)
+
+ ;; The shstrtab, for section names.
+ ;;
+ (shstrtab asm-shstrtab set-asm-shstrtab!)
+
+ ;; The section number for the next section to be written.
+ ;;
+ (next-section-number asm-next-section-number set-asm-next-section-number!)
+
+ ;; A list of <meta>, corresponding to procedure metadata.
+ ;;
+ (meta asm-meta set-asm-meta!))
+
+(define-inlinable (fresh-block)
+ (make-u32vector *block-size*))
+
+(define* (make-assembler #:key (word-size (target-word-size))
+ (endianness (target-endianness)))
+ "Create an assembler for a given target @var{word-size} and
address@hidden, falling back to appropriate values for the configured
+target."
+ (make-asm (fresh-block) 0 0 '() 0
+ '() '()
+ word-size endianness
+ vlist-null '()
+ (make-string-table) 1
+ '()))
+
+(define (intern-section-name! asm string)
+ "Add a string to the section name table (shstrtab)."
+ (string-table-intern! (asm-shstrtab asm) string))
+
+(define-inlinable (asm-pos asm)
+ "The offset of the next word to be written into the code buffer, in
+32-bit units."
+ (+ (asm-idx asm) (asm-written asm)))
+
+(define (allocate-new-block asm)
+ "Close off the current block, and arrange for the next word to be
+written to a fresh block."
+ (let ((new (fresh-block)))
+ (set-asm-prev! asm (cons (asm-cur asm) (asm-prev asm)))
+ (set-asm-written! asm (asm-pos asm))
+ (set-asm-cur! asm new)
+ (set-asm-idx! asm 0)))
+
+(define-inlinable (emit asm u32)
+ "Emit one 32-bit word into the instruction stream. Assumes that there
+is space for the word, and ensures that there is space for the next
+word."
+ (u32-set! (asm-cur asm) (asm-idx asm) u32)
+ (set-asm-idx! asm (1+ (asm-idx asm)))
+ (if (= (asm-idx asm) *block-size*)
+ (allocate-new-block asm)))
+
+(define-inlinable (make-reloc type label base word)
+ "Make an internal relocation of type @var{type} referencing symbol
address@hidden, @var{word} words after position @var{start}. @var{type}
+may be x8-s24, indicating a 24-bit relative label reference that can be
+fixed up by the assembler, or s32, indicating a 32-bit relative
+reference that needs to be fixed up by the linker."
+ (list type label base word))
+
+(define-inlinable (reset-asm-start! asm)
+ "Reset the asm-start after writing the words for one instruction."
+ (set-asm-start! asm (asm-pos asm)))
+
+(define (emit-exported-label asm label)
+ "Define a linker symbol associating @var{label} with the current
+asm-start."
+ (set-asm-labels! asm (acons label (asm-start asm) (asm-labels asm))))
+
+(define (record-label-reference asm label)
+ "Record an x8-s24 local label reference. This value will get patched
+up later by the assembler."
+ (let* ((start (asm-start asm))
+ (pos (asm-pos asm))
+ (reloc (make-reloc 'x8-s24 label start (- pos start))))
+ (set-asm-relocs! asm (cons reloc (asm-relocs asm)))))
+
+(define* (record-far-label-reference asm label #:optional (offset 0))
+ "Record an s32 far label reference. This value will get patched up
+later by the linker."
+ (let* ((start (- (asm-start asm) offset))
+ (pos (asm-pos asm))
+ (reloc (make-reloc 's32 label start (- pos start))))
+ (set-asm-relocs! asm (cons reloc (asm-relocs asm)))))
+
+
+
+
+;;;
+;;; Primitive assemblers are defined by expanding `assembler' for each
+;;; opcode in `(rtl-instruction-list)'.
+;;;
+
+(eval-when (expand compile load eval)
+ (define (id-append ctx a b)
+ (datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b)))))
+
+(define-syntax assembler
+ (lambda (x)
+ (define-syntax op-case
+ (lambda (x)
+ (syntax-case x ()
+ ((_ asm name ((type arg ...) code ...) clause ...)
+ #`(if (eq? name 'type)
+ (with-syntax (((arg ...) (generate-temporaries #'(arg ...))))
+ #'((arg ...)
+ code ...))
+ (op-case asm name clause ...)))
+ ((_ asm name)
+ #'(error "unmatched name" name)))))
+
+ (define (pack-first-word asm opcode type)
+ (with-syntax ((opcode opcode))
+ (op-case
+ asm type
+ ((U8_X24)
+ (emit asm opcode))
+ ((U8_U24 arg)
+ (emit asm (pack-u8-u24 opcode arg)))
+ ((U8_L24 label)
+ (record-label-reference asm label)
+ (emit asm opcode))
+ ((U8_R24 rest)
+ (emit asm (pack-u8-u24 opcode (list rest)))
+ (for-each (lambda (x) (emit asm x)) rest))
+ ((U8_U8_I16 a imm)
+ (emit asm (pack-u8-u8-u16 opcode a (object-address imm))))
+ ((U8_U12_U12 a b)
+ (emit asm (pack-u8-u12-u12 opcode a b)))
+ ((U8_U8_U8_U8 a b c)
+ (emit asm (pack-u8-u8-u8-u8 opcode a b c))))))
+
+ (define (pack-tail-word asm type)
+ (op-case
+ asm type
+ ((U8_U24 a b)
+ (emit asm (pack-u8-u24 a b)))
+ ((U8_L24 a label)
+ (record-label-reference asm label)
+ (emit asm a))
+ ((U8_R24 rest)
+ (emit asm (pack-u8-u24 a (length rest)))
+ (for-each (lambda (x) (emit asm x)) rest))
+ ((U8_U8_I16 a b imm)
+ (emit asm (pack-u8-u8-u16 a b (object-address imm))))
+ ((U8_U12_U12 a b)
+ (emit asm (pack-u8-u12-u12 a b c)))
+ ((U8_U8_U8_U8 a b c d)
+ (emit asm (pack-u8-u8-u8-u8 a b c d)))
+ ((U32 a)
+ (emit asm a))
+ ((I32 imm)
+ (let ((val (object-address imm)))
+ (unless (zero? (ash val -32))
+ (error "FIXME: enable truncation of negative fixnums when
cross-compiling"))
+ (emit asm val)))
+ ((A32 imm)
+ (unless (= (asm-word-size asm) 8)
+ (error "make-long-immediate unavailable for this target"))
+ (emit asm (ash (object-address imm) -32))
+ (emit asm (logand (object-address imm) (1- (ash 1 32)))))
+ ((B32))
+ ((N32 label)
+ (record-far-label-reference asm label)
+ (emit asm 0))
+ ((S32 label)
+ (record-far-label-reference asm label)
+ (emit asm 0))
+ ((L32 label)
+ (record-far-label-reference asm label)
+ (emit asm 0))
+ ((LO32 label offset)
+ (record-far-label-reference asm label
+ (* offset (/ (asm-word-size asm) 4)))
+ (emit asm 0))
+ ((X8_U24 a)
+ (emit asm (pack-u8-u24 0 a)))
+ ((X8_U12_U12 a b)
+ (emit asm (pack-u8-u12-u12 0 a b)))
+ ((X8_R24 rest)
+ (emit asm (pack-u8-u24 0 (length rest)))
+ (for-each (lambda (x) (emit asm x)) rest))
+ ((X8_L24 label)
+ (record-label-reference asm label)
+ (emit asm 0))
+ ((B1_X7_L24 a label)
+ (record-label-reference asm label)
+ (emit asm (pack-u1-u7-u24 (if a 1 0) 0 0)))
+ ((B1_U7_L24 a b label)
+ (record-label-reference asm label)
+ (emit asm (pack-u1-u7-u24 (if a 1 0) b 0)))))
+
+ (syntax-case x ()
+ ((_ name opcode word0 word* ...)
+ (with-syntax ((((formal0 ...)
+ code0 ...)
+ (pack-first-word #'asm
+ (syntax->datum #'opcode)
+ (syntax->datum #'word0)))
+ ((((formal* ...)
+ code* ...) ...)
+ (map (lambda (word) (pack-tail-word #'asm word))
+ (syntax->datum #'(word* ...)))))
+ #'(lambda (asm formal0 ... formal* ... ...)
+ (unless (asm? asm) (error "not an asm"))
+ code0 ...
+ code* ... ...
+ (reset-asm-start! asm)))))))
+
+(define assemblers (make-hash-table))
+
+(define-syntax define-assembler
+ (lambda (x)
+ (syntax-case x ()
+ ((_ name opcode arg ...)
+ (with-syntax ((emit (id-append #'name #'emit- #'name)))
+ #'(define emit
+ (let ((emit (assembler name opcode arg ...)))
+ (hashq-set! assemblers 'name emit)
+ emit)))))))
+
+(define-syntax visit-opcodes
+ (lambda (x)
+ (syntax-case x ()
+ ((visit-opcodes macro arg ...)
+ (with-syntax (((inst ...)
+ (map (lambda (x) (datum->syntax #'macro x))
+ (rtl-instruction-list))))
+ #'(begin
+ (macro arg ... . inst)
+ ...))))))
+
+(visit-opcodes define-assembler)
+
+(define (emit-text asm instructions)
+ "Assemble @var{instructions} using the assembler @var{asm}.
address@hidden is a sequence of RTL instructions, expressed as a
+list of lists. This procedure can be called many times before calling
address@hidden"
+ (for-each (lambda (inst)
+ (apply (or (hashq-ref assemblers (car inst))
+ (error 'bad-instruction inst))
+ asm
+ (cdr inst)))
+ instructions))
+
+
+
+;;;
+;;; The constant table records a topologically sorted set of literal
+;;; constants used by a program. For example, a pair uses its car and
+;;; cdr, a string uses its stringbuf, etc.
+;;;
+;;; Some things we want to add to the constant table are not actually
+;;; Scheme objects: for example, stringbufs, cache cells for toplevel
+;;; references, or cache cells for non-closure procedures. For these we
+;;; define special record types and add instances of those record types
+;;; to the table.
+;;;
+
+(define-inlinable (immediate? x)
+ "Return @code{#t} if @var{x} is immediate, and @code{#f} otherwise."
+ (not (zero? (logand (object-address x) 6))))
+
+(define-record-type <stringbuf>
+ (make-stringbuf string)
+ stringbuf?
+ (string stringbuf-string))
+
+(define-record-type <static-procedure>
+ (make-static-procedure code)
+ static-procedure?
+ (code static-procedure-code))
+
+(define-record-type <cache-cell>
+ (make-cache-cell scope key)
+ cache-cell?
+ (scope cache-cell-scope)
+ (key cache-cell-key))
+
+(define (statically-allocatable? x)
+ "Return @code{#t} if a non-immediate constant can be allocated
+statically, and @code{#f} if it would need some kind of runtime
+allocation."
+ (or (pair? x) (vector? x) (string? x) (stringbuf? x) (static-procedure? x)))
+
+(define (intern-constant asm obj)
+ "Add an object to the constant table, and return a label that can be
+used to reference it. If the object is already present in the constant
+table, its existing label is used directly."
+ (define (recur obj)
+ (intern-constant asm obj))
+ (define (field dst n obj)
+ (let ((src (recur obj)))
+ (if src
+ (list (if (statically-allocatable? obj)
+ `(make-non-immediate 0 ,src)
+ `(static-ref 0 ,src))
+ `(static-set! 0 ,dst ,n))
+ '())))
+ (define (intern obj label)
+ (cond
+ ((pair? obj)
+ (append (field label 0 (car obj))
+ (field label 1 (cdr obj))))
+ ((vector? obj)
+ (let lp ((i 0) (inits '()))
+ (if (< i (vector-length obj))
+ (lp (1+ i)
+ (append-reverse (field label (1+ i) (vector-ref obj i))
+ inits))
+ (reverse inits))))
+ ((stringbuf? obj) '())
+ ((static-procedure? obj)
+ `((make-non-immediate 0 ,label)
+ (link-procedure! 0 ,(static-procedure-code obj))))
+ ((cache-cell? obj) '())
+ ((symbol? obj)
+ `((make-non-immediate 0 ,(recur (symbol->string obj)))
+ (string->symbol 0 0)
+ (static-set! 0 ,label 0)))
+ ((string? obj)
+ `((make-non-immediate 0 ,(recur (make-stringbuf obj)))
+ (static-set! 0 ,label 1)))
+ ((keyword? obj)
+ `((static-ref 0 ,(recur (keyword->symbol obj)))
+ (symbol->keyword 0 0)
+ (static-set! 0 ,label 0)))
+ ((number? obj)
+ `((make-non-immediate 0 ,(recur (number->string obj)))
+ (string->number 0 0)
+ (static-set! 0 ,label 0)))
+ (else
+ (error "don't know how to intern" obj))))
+ (cond
+ ((immediate? obj) #f)
+ ((vhash-assoc obj (asm-constants asm)) => cdr)
+ (else
+ ;; Note that calling intern may mutate asm-constants and
+ ;; asm-constant-inits.
+ (let* ((label (gensym "constant"))
+ (inits (intern obj label)))
+ (set-asm-constants! asm (vhash-cons obj label (asm-constants asm)))
+ (set-asm-inits! asm (append-reverse inits (asm-inits asm)))
+ label))))
+
+(define (intern-non-immediate asm obj)
+ "Intern a non-immediate into the constant table, and return its
+label."
+ (when (immediate? obj)
+ (error "expected a non-immediate" obj))
+ (intern-constant asm obj))
+
+(define (intern-cache-cell asm scope key)
+ "Intern a cache cell into the constant table, and return its label.
+If there is already a cache cell with the given scope and key, it is
+returned instead."
+ (intern-constant asm (make-cache-cell scope key)))
+
+;; Return the label of the cell that holds the module for a scope.
+(define (intern-module-cache-cell asm scope)
+ "Intern a cache cell for a module, and return its label."
+ (intern-cache-cell asm scope #t))
+
+
+
+
+;;;
+;;; Macro assemblers bridge the gap between primitive instructions and
+;;; some higher-level operations.
+;;;
+
+(define-syntax define-macro-assembler
+ (lambda (x)
+ (syntax-case x ()
+ ((_ (name arg ...) body body* ...)
+ (with-syntax ((emit (id-append #'name #'emit- #'name)))
+ #'(define emit
+ (let ((emit (lambda (arg ...) body body* ...)))
+ (hashq-set! assemblers 'name emit)
+ emit)))))))
+
+(define-macro-assembler (load-constant asm dst obj)
+ (cond
+ ((immediate? obj)
+ (let ((bits (object-address obj)))
+ (cond
+ ((and (< dst 256) (zero? (ash bits -16)))
+ (emit-make-short-immediate asm dst obj))
+ ((zero? (ash bits -32))
+ (emit-make-long-immediate asm dst obj))
+ (else
+ (emit-make-long-long-immediate asm dst obj)))))
+ ((statically-allocatable? obj)
+ (emit-make-non-immediate asm dst (intern-non-immediate asm obj)))
+ (else
+ (emit-static-ref asm dst (intern-non-immediate asm obj)))))
+
+(define-macro-assembler (load-static-procedure asm dst label)
+ (let ((loc (intern-constant asm (make-static-procedure label))))
+ (emit-make-non-immediate asm dst loc)))
+
+(define-macro-assembler (begin-program asm label)
+ (emit-label asm label)
+ (let ((meta (make-meta label (asm-start asm) #f)))
+ (set-asm-meta! asm (cons meta (asm-meta asm)))))
+
+(define-macro-assembler (end-program asm)
+ (set-meta-high-pc! (car (asm-meta asm)) (asm-start asm)))
+
+(define-macro-assembler (label asm sym)
+ (set-asm-labels! asm (acons sym (asm-start asm) (asm-labels asm))))
+
+(define-macro-assembler (cache-current-module! asm tmp scope)
+ (let ((mod-label (intern-module-cache-cell asm scope)))
+ (emit-current-module asm tmp)
+ (emit-static-set! asm tmp mod-label 0)))
+
+(define-macro-assembler (cached-toplevel-ref asm dst scope sym)
+ (let ((sym-label (intern-non-immediate asm sym))
+ (mod-label (intern-module-cache-cell asm scope))
+ (cell-label (intern-cache-cell asm scope sym)))
+ (emit-toplevel-ref asm dst cell-label mod-label sym-label)))
+
+(define-macro-assembler (cached-toplevel-set! asm src scope sym)
+ (let ((sym-label (intern-non-immediate asm sym))
+ (mod-label (intern-module-cache-cell asm scope))
+ (cell-label (intern-cache-cell asm scope sym)))
+ (emit-toplevel-set! asm src cell-label mod-label sym-label)))
+
+(define-macro-assembler (cached-module-ref asm dst module-name public? sym)
+ (let* ((sym-label (intern-non-immediate asm sym))
+ (key (cons public? module-name))
+ (mod-name-label (intern-constant asm key))
+ (cell-label (intern-cache-cell asm key sym)))
+ (emit-module-ref asm dst cell-label mod-name-label sym-label)))
+
+(define-macro-assembler (cached-module-set! asm src module-name public? sym)
+ (let* ((sym-label (intern-non-immediate asm sym))
+ (key (cons public? module-name))
+ (mod-name-label (intern-non-immediate asm key))
+ (cell-label (intern-cache-cell asm key sym)))
+ (emit-module-set! asm src cell-label mod-name-label sym-label)))
+
+
+
+
+;;;
+;;; Helper for linking objects.
+;;;
+
+(define (make-object asm name bv relocs labels . kwargs)
+ "Make a linker object. This helper handles interning the name in the
+shstrtab, assigning the size, allocating a fresh index, and defining a
+corresponding linker symbol for the start of the section."
+ (let ((name-idx (intern-section-name! asm (symbol->string name)))
+ (index (asm-next-section-number asm)))
+ (set-asm-next-section-number! asm (1+ index))
+ (make-linker-object (apply make-elf-section
+ #:index index
+ #:name name-idx
+ #:size (bytevector-length bv)
+ kwargs)
+ bv relocs
+ (cons (make-linker-symbol name 0) labels))))
+
+
+
+
+;;;
+;;; Linking the constant table. This code is somewhat intertwingled
+;;; with the intern-constant code above, as that procedure also
+;;; residualizes instructions to initialize constants at load time.
+;;;
+
+(define (write-immediate asm buf pos x)
+ (let ((val (object-address x))
+ (endianness (asm-endianness asm)))
+ (case (asm-word-size asm)
+ ((4) (bytevector-u32-set! buf pos val endianness))
+ ((8) (bytevector-u64-set! buf pos val endianness))
+ (else (error "bad word size" asm)))))
+
+(define (emit-init-constants asm)
+ "If there is writable data that needs initialization at runtime, emit
+a procedure to do that and return its label. Otherwise return
address@hidden"
+ (let ((inits (asm-inits asm)))
+ (and (not (null? inits))
+ (let ((label (gensym "init-constants")))
+ (emit-text asm
+ `((begin-program ,label)
+ (assert-nargs-ee/locals 0 1)
+ ,@(reverse inits)
+ (load-constant 0 ,*unspecified*)
+ (return 0)
+ (end-program)))
+ label))))
+
+(define (link-data asm data name)
+ "Link the static data for a program into the @var{name} section (which
+should be .data or .rodata), and return the resulting linker object.
address@hidden should be a vhash mapping objects to labels."
+ (define (align address alignment)
+ (+ address
+ (modulo (- alignment (modulo address alignment)) alignment)))
+
+ (define tc7-vector 13)
+ (define tc7-narrow-stringbuf 39)
+ (define tc7-wide-stringbuf (+ 39 #x400))
+ (define tc7-ro-string (+ 21 #x200))
+ (define tc7-rtl-program 69)
+
+ (let ((word-size (asm-word-size asm))
+ (endianness (asm-endianness asm)))
+ (define (byte-length x)
+ (cond
+ ((stringbuf? x)
+ (let ((x (stringbuf-string x)))
+ (+ (* 2 word-size)
+ (case (string-bytes-per-char x)
+ ((1) (1+ (string-length x)))
+ ((4) (* (1+ (string-length x)) 4))
+ (else (error "bad string bytes per char" x))))))
+ ((static-procedure? x)
+ (* 2 word-size))
+ ((string? x)
+ (* 4 word-size))
+ ((pair? x)
+ (* 2 word-size))
+ ((vector? x)
+ (* (1+ (vector-length x)) word-size))
+ (else
+ word-size)))
+
+ (define (write-constant-reference buf pos x)
+ ;; The asm-inits will fix up any reference to a non-immediate.
+ (write-immediate asm buf pos (if (immediate? x) x #f)))
+
+ (define (write buf pos obj)
+ (cond
+ ((stringbuf? obj)
+ (let* ((x (stringbuf-string obj))
+ (len (string-length x))
+ (tag (if (= (string-bytes-per-char x) 1)
+ tc7-narrow-stringbuf
+ tc7-wide-stringbuf)))
+ (case word-size
+ ((4)
+ (bytevector-u32-set! buf pos tag endianness)
+ (bytevector-u32-set! buf (+ pos 4) len endianness))
+ ((8)
+ (bytevector-u64-set! buf pos tag endianness)
+ (bytevector-u64-set! buf (+ pos 8) len endianness))
+ (else
+ (error "bad word size" asm)))
+ (let ((pos (+ pos (* word-size 2))))
+ (case (string-bytes-per-char x)
+ ((1)
+ (let lp ((i 0))
+ (if (< i len)
+ (let ((u8 (char->integer (string-ref x i))))
+ (bytevector-u8-set! buf (+ pos i) u8)
+ (lp (1+ i)))
+ (bytevector-u8-set! buf (+ pos i) 0))))
+ ((4)
+ (let lp ((i 0))
+ (if (< i len)
+ (let ((u32 (char->integer (string-ref x i))))
+ (bytevector-u32-set! buf (+ pos (* i 4)) u32 endianness)
+ (lp (1+ i)))
+ (bytevector-u32-set! buf (+ pos (* i 4)) 0 endianness))))
+ (else (error "bad string bytes per char" x))))))
+
+ ((static-procedure? obj)
+ (case word-size
+ ((4)
+ (bytevector-u32-set! buf pos tc7-rtl-program endianness)
+ (bytevector-u32-set! buf (+ pos 4) 0 endianness))
+ ((8)
+ (bytevector-u64-set! buf pos tc7-rtl-program endianness)
+ (bytevector-u64-set! buf (+ pos 8) 0 endianness))
+ (else (error "bad word size"))))
+
+ ((cache-cell? obj)
+ (write-immediate asm buf pos #f))
+
+ ((string? obj)
+ (let ((tag (logior tc7-ro-string (ash (string-length obj) 8))))
+ (case word-size
+ ((4)
+ (bytevector-u32-set! buf pos tc7-ro-string endianness)
+ (write-immediate asm buf (+ pos 4) #f) ; stringbuf
+ (bytevector-u32-set! buf (+ pos 8) 0 endianness)
+ (bytevector-u32-set! buf (+ pos 12) (string-length obj)
endianness))
+ ((8)
+ (bytevector-u64-set! buf pos tc7-ro-string endianness)
+ (write-immediate asm buf (+ pos 8) #f) ; stringbuf
+ (bytevector-u64-set! buf (+ pos 16) 0 endianness)
+ (bytevector-u64-set! buf (+ pos 24) (string-length obj)
endianness))
+ (else (error "bad word size")))))
+
+ ((pair? obj)
+ (write-constant-reference buf pos (car obj))
+ (write-constant-reference buf (+ pos word-size) (cdr obj)))
+
+ ((vector? obj)
+ (let* ((len (vector-length obj))
+ (tag (logior tc7-vector (ash len 8))))
+ (case word-size
+ ((4) (bytevector-u32-set! buf pos tag endianness))
+ ((8) (bytevector-u64-set! buf pos tag endianness))
+ (else (error "bad word size")))
+ (let lp ((i 0))
+ (when (< i (vector-length obj))
+ (let ((pos (+ pos word-size (* i word-size)))
+ (elt (vector-ref obj i)))
+ (write-constant-reference buf pos elt)
+ (lp (1+ i)))))))
+
+ ((symbol? obj)
+ (write-immediate asm buf pos #f))
+
+ ((keyword? obj)
+ (write-immediate asm buf pos #f))
+
+ ((number? obj)
+ (write-immediate asm buf pos #f))
+
+ (else
+ (error "unrecognized object" obj))))
+
+ (cond
+ ((vlist-null? data) #f)
+ (else
+ (let* ((byte-len (vhash-fold (lambda (k v len)
+ (+ (byte-length k) (align len 8)))
+ 0 data))
+ (buf (make-bytevector byte-len 0)))
+ (let lp ((i 0) (pos 0) (labels '()))
+ (if (< i (vlist-length data))
+ (let* ((pair (vlist-ref data i))
+ (obj (car pair))
+ (obj-label (cdr pair)))
+ (write buf pos obj)
+ (lp (1+ i)
+ (align (+ (byte-length obj) pos) 8)
+ (cons (make-linker-symbol obj-label pos) labels)))
+ (make-object asm name buf '() labels))))))))
+
+(define (link-constants asm)
+ "Link sections to hold constants needed by the program text emitted
+using @var{asm}.
+
+Returns three values: an object for the .rodata section, an object for
+the .data section, and a label for an initialization procedure. Any of
+these may be @code{#f}."
+ (define (shareable? x)
+ (cond
+ ((stringbuf? x) #t)
+ ((pair? x)
+ (and (immediate? (car x)) (immediate? (cdr x))))
+ ((vector? x)
+ (let lp ((i 0))
+ (or (= i (vector-length x))
+ (and (immediate? (vector-ref x i))
+ (lp (1+ i))))))
+ (else #f)))
+ (let* ((constants (asm-constants asm))
+ (len (vlist-length constants)))
+ (let lp ((i 0)
+ (ro vlist-null)
+ (rw vlist-null))
+ (if (= i len)
+ (values (link-data asm ro '.rodata)
+ (link-data asm rw '.data)
+ (emit-init-constants asm))
+ (let ((pair (vlist-ref constants i)))
+ (if (shareable? (car pair))
+ (lp (1+ i) (vhash-consq (car pair) (cdr pair) ro) rw)
+ (lp (1+ i) ro (vhash-consq (car pair) (cdr pair) rw))))))))
+
+
+
+;;;
+;;; Linking program text.
+;;;
+
+(define (process-relocs buf relocs labels)
+ "Patch up internal x8-s24 relocations, and any s32 relocations that
+reference symbols in the text section. Return a list of linker
+relocations for references to symbols defined outside the text section."
+ (fold
+ (lambda (reloc tail)
+ (match reloc
+ ((type label base word)
+ (let ((abs (assq-ref labels label))
+ (dst (+ base word)))
+ (case type
+ ((s32)
+ (if abs
+ (let ((rel (- abs base)))
+ (s32-set! buf dst rel)
+ tail)
+ (cons (make-linker-reloc 'rel32/4 (* dst 4) word label)
+ tail)))
+ ((x8-s24)
+ (unless abs
+ (error "unbound near relocation" reloc))
+ (let ((rel (- abs base))
+ (u32 (u32-ref buf dst)))
+ (u32-set! buf dst (pack-u8-s24 (logand u32 #xff) rel))
+ tail))
+ (else (error "bad relocation kind" reloc)))))))
+ '()
+ relocs))
+
+(define (process-labels labels)
+ "Define linker symbols for the label-offset pairs in @var{labels}.
+The offsets are expected to be expressed in words."
+ (map (lambda (pair)
+ (make-linker-symbol (car pair) (* (cdr pair) 4)))
+ labels))
+
+(define (swap-bytes! buf)
+ "Patch up the text buffer @var{buf}, swapping the endianness of each
+32-bit unit."
+ (unless (zero? (modulo (bytevector-length buf) 4))
+ (error "unexpected length"))
+ (let ((byte-len (bytevector-length buf)))
+ (let lp ((pos 0))
+ (unless (= pos byte-len)
+ (bytevector-u32-set!
+ buf pos
+ (bytevector-u32-ref buf pos (endianness big))
+ (endianness little))
+ (lp (+ pos 4))))))
+
+(define (link-text-object asm)
+ "Link the .rtl-text section, swapping the endianness of the bytes if
+needed."
+ (let ((buf (make-u32vector (asm-pos asm))))
+ (let lp ((pos 0) (prev (reverse (asm-prev asm))))
+ (if (null? prev)
+ (let ((byte-size (* (asm-idx asm) 4)))
+ (bytevector-copy! (asm-cur asm) 0 buf pos byte-size)
+ (unless (eq? (asm-endianness asm) (native-endianness))
+ (swap-bytes! buf))
+ (make-object asm '.rtl-text
+ buf
+ (process-relocs buf (asm-relocs asm)
+ (asm-labels asm))
+ (process-labels (asm-labels asm))))
+ (let ((len (* *block-size* 4)))
+ (bytevector-copy! (car prev) 0 buf pos len)
+ (lp (+ pos len) (cdr prev)))))))
+
+
+
+
+;;;
+;;; Linking other sections of the ELF file, like the dynamic segment,
+;;; the symbol table, etc.
+;;;
+
+(define (link-dynamic-section asm text rw rw-init)
+ "Link the dynamic section for an ELF image with RTL text, given the
+writable data section @var{rw} needing fixup from the procedure with
+label @var{rw-init}. @var{rw-init} may be false. If @var{rw} is true,
+it will be added to the GC roots at runtime."
+ (define-syntax-rule (emit-dynamic-section word-size %set-uword! reloc-type)
+ (let* ((endianness (asm-endianness asm))
+ (bv (make-bytevector (* word-size (if rw (if rw-init 12 10) 6)) 0))
+ (set-uword!
+ (lambda (i uword)
+ (%set-uword! bv (* i word-size) uword endianness)))
+ (relocs '())
+ (set-label!
+ (lambda (i label)
+ (set! relocs (cons (make-linker-reloc 'reloc-type
+ (* i word-size) 0 label)
+ relocs))
+ (%set-uword! bv (* i word-size) 0 endianness))))
+ (set-uword! 0 DT_GUILE_RTL_VERSION)
+ (set-uword! 1 #x02020000)
+ (set-uword! 2 DT_GUILE_ENTRY)
+ (set-label! 3 '.rtl-text)
+ (cond
+ (rw
+ ;; Add roots to GC.
+ (set-uword! 4 DT_GUILE_GC_ROOT)
+ (set-label! 5 '.data)
+ (set-uword! 6 DT_GUILE_GC_ROOT_SZ)
+ (set-uword! 7 (bytevector-length (linker-object-bv rw)))
+ (cond
+ (rw-init
+ (set-uword! 8 DT_INIT) ; constants
+ (set-label! 9 rw-init)
+ (set-uword! 10 DT_NULL)
+ (set-uword! 11 0))
+ (else
+ (set-uword! 8 DT_NULL)
+ (set-uword! 9 0))))
+ (else
+ (set-uword! 4 DT_NULL)
+ (set-uword! 5 0)))
+ (make-object asm '.dynamic bv relocs '()
+ #:type SHT_DYNAMIC #:flags SHF_ALLOC)))
+ (case (asm-word-size asm)
+ ((4) (emit-dynamic-section 4 bytevector-u32-set! abs32/1))
+ ((8) (emit-dynamic-section 8 bytevector-u64-set! abs64/1))
+ (else (error "bad word size" asm))))
+
+(define (link-shstrtab asm)
+ "Link the string table for the section headers."
+ (intern-section-name! asm ".shstrtab")
+ (make-object asm '.shstrtab
+ (link-string-table! (asm-shstrtab asm))
+ '() '()
+ #:type SHT_STRTAB #:flags 0))
+
+(define (link-symtab text-section asm)
+ (let* ((endianness (asm-endianness asm))
+ (word-size (asm-word-size asm))
+ (size (elf-symbol-len word-size))
+ (meta (reverse (asm-meta asm)))
+ (n (length meta))
+ (strtab (make-string-table))
+ (bv (make-bytevector (* n size) 0)))
+ (define (intern-string! name)
+ (string-table-intern! strtab (symbol->string name)))
+ (for-each
+ (lambda (meta n)
+ (let ((name (intern-string! (meta-name meta))))
+ (write-elf-symbol bv (* n size) endianness word-size
+ (make-elf-symbol
+ #:name name
+ ;; Symbol value and size are measured in
+ ;; bytes, not u32s.
+ #:value (* 4 (meta-low-pc meta))
+ #:size (* 4 (- (meta-high-pc meta)
+ (meta-low-pc meta)))
+ #:type STT_FUNC
+ #:visibility STV_HIDDEN
+ #:shndx (elf-section-index text-section)))))
+ meta (iota n))
+ (let ((strtab (make-object asm '.strtab
+ (link-string-table! strtab)
+ '() '()
+ #:type SHT_STRTAB #:flags 0)))
+ (values (make-object asm '.symtab
+ bv
+ '() '()
+ #:type SHT_SYMTAB #:flags 0 #:entsize size
+ #:link (elf-section-index
+ (linker-object-section strtab)))
+ strtab))))
+
+(define (link-objects asm)
+ (let*-values (((ro rw rw-init) (link-constants asm))
+ ;; Link text object after constants, so that the
+ ;; constants initializer gets included.
+ ((text) (link-text-object asm))
+ ((dt) (link-dynamic-section asm text rw rw-init))
+ ((symtab strtab) (link-symtab (linker-object-section text)
asm))
+ ;; This needs to be linked last, because linking other
+ ;; sections adds entries to the string table.
+ ((shstrtab) (link-shstrtab asm)))
+ (filter identity (list text ro rw dt symtab strtab shstrtab))))
+
+
+
+
+;;;
+;;; High-level public interfaces.
+;;;
+
+(define* (link-assembly asm #:key (page-aligned? #t))
+ "Produce an ELF image from the code and data emitted into @var{asm}.
+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
new file mode 100644
index 0000000..9522d62
--- /dev/null
+++ b/module/system/vm/debug.scm
@@ -0,0 +1,161 @@
+;;; Guile runtime debug information
+
+;;; Copyright (C) 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
+
+;;; Commentary:
+;;;
+;;; Guile's RTL compiler and linker serialize debugging information into
+;;; separate sections of the ELF image. This module reads those
+;;; sections.
+;;;
+;;; Code:
+
+(define-module (system vm debug)
+ #:use-module (system vm elf)
+ #:use-module (system vm objcode)
+ #:use-module (system foreign)
+ #:use-module (rnrs bytevectors)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-9)
+ #:export (debug-context-image
+ debug-context-base
+
+ program-debug-info-name
+ program-debug-info-context
+ program-debug-info-image
+ program-debug-info-offset
+ program-debug-info-addr
+ program-debug-info-u32-offset
+ program-debug-info-u32-offset-end
+
+ find-debug-context
+ find-program-debug-info))
+
+;;; A compiled procedure comes from a specific loaded ELF image. A
+;;; debug context identifies that image.
+;;;
+(define-record-type <debug-context>
+ (make-debug-context elf base text-base)
+ debug-context?
+ (elf debug-context-elf)
+ ;; Address at which this image is loaded in memory, in bytes.
+ (base debug-context-base)
+ ;; Offset of the text section relative to the image start, in bytes.
+ (text-base debug-context-text-base))
+
+(define (debug-context-image context)
+ "Return the bytevector aliasing the mapped ELF image corresponding to
address@hidden"
+ (elf-bytes (debug-context-elf context)))
+
+;;; A program debug info (PDI) is a handle on debugging meta-data for a
+;;; particular program.
+;;;
+(define-record-type <program-debug-info>
+ (make-program-debug-info context name offset size)
+ program-debug-info?
+ (context program-debug-info-context)
+ (name program-debug-info-name)
+ ;; Offset of the procedure in the text section, in bytes.
+ (offset program-debug-info-offset)
+ (size program-debug-info-size))
+
+(define (program-debug-info-addr pdi)
+ "Return the address in memory of the entry of the program represented
+by the debugging info @var{pdi}."
+ (+ (program-debug-info-offset pdi)
+ (debug-context-text-base (program-debug-info-context pdi))
+ (debug-context-base (program-debug-info-context pdi))))
+
+(define (program-debug-info-image pdi)
+ "Return the ELF image containing @var{pdi}, as a bytevector."
+ (debug-context-image (program-debug-info-context pdi)))
+
+(define (program-debug-info-u32-offset pdi)
+ "Return the start address of the program represented by @var{pdi}, as
+an offset from the beginning of the ELF image in 32-bit units."
+ (/ (+ (program-debug-info-offset pdi)
+ (debug-context-text-base (program-debug-info-context pdi)))
+ 4))
+
+(define (program-debug-info-u32-offset-end pdi)
+ "Return the end address of the program represented by @var{pdi}, as an
+offset from the beginning of the ELF image in 32-bit units."
+ (/ (+ (program-debug-info-size pdi)
+ (program-debug-info-offset pdi)
+ (debug-context-text-base (program-debug-info-context pdi)))
+ 4))
+
+(define (find-debug-context addr)
+ "Find and return the debugging context corresponding to the ELF image
+containing the address @var{addr}. @var{addr} is an integer."
+ (let* ((bv (find-mapped-elf-image addr))
+ (elf (parse-elf bv))
+ (base (pointer-address (bytevector->pointer (elf-bytes elf))))
+ (text-base (elf-section-offset
+ (or (elf-section-by-name elf ".rtl-text")
+ (error "ELF object has no text section")))))
+ (make-debug-context elf base text-base)))
+
+(define (find-elf-symbol elf text-offset)
+ "Search the symbol table of @var{elf} for the ELF symbol containing
address@hidden @var{text-offset} is a byte offset in the text
+section of the ELF image. Returns an ELF symbol, or @code{#f}."
+ (and=>
+ (elf-section-by-name elf ".symtab")
+ (lambda (symtab)
+ (let ((len (elf-symbol-table-len symtab))
+ (strtab (elf-section elf (elf-section-link symtab))))
+ ;; The symbols should be sorted, but maybe somehow that fails
+ ;; (for example if multiple objects are relinked together). So,
+ ;; a modicum of tolerance.
+ (define (bisect)
+ ;; FIXME: Implement.
+ #f)
+ (define (linear-search)
+ (let lp ((n 0))
+ (and (< n len)
+ (let ((sym (elf-symbol-table-ref elf symtab n strtab)))
+ (if (and (<= (elf-symbol-value sym) text-offset)
+ (< text-offset (+ (elf-symbol-value sym)
+ (elf-symbol-size sym))))
+ sym
+ (lp (1+ n)))))))
+ (or (bisect) (linear-search))))))
+
+(define* (find-program-debug-info addr #:optional
+ (context (find-debug-context addr)))
+ "Find and return the @code{<program-debug-info>} containing
address@hidden, or @code{#f}."
+ (cond
+ ((find-elf-symbol (debug-context-elf context)
+ (- addr
+ (debug-context-base context)
+ (debug-context-text-base context)))
+ => (lambda (sym)
+ (make-program-debug-info context
+ (and=> (elf-symbol-name sym)
+ ;; The name might be #f if
+ ;; the string table was
+ ;; stripped somehow.
+ (lambda (x)
+ (and (string? x)
+ (not (string-null? x))
+ (string->symbol x))))
+ (elf-symbol-value sym)
+ (elf-symbol-size sym))))
+ (else #f)))
diff --git a/module/system/vm/disassembler.scm
b/module/system/vm/disassembler.scm
new file mode 100644
index 0000000..b815c1e
--- /dev/null
+++ b/module/system/vm/disassembler.scm
@@ -0,0 +1,350 @@
+;;; Guile RTL disassembler
+
+;;; 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 (system vm disassembler)
+ #:use-module (system vm instruction)
+ #:use-module (system vm elf)
+ #:use-module (system vm debug)
+ #:use-module (system vm program)
+ #:use-module (system vm objcode)
+ #:use-module (system foreign)
+ #:use-module (rnrs bytevectors)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 vlist)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-4)
+ #:export (disassemble-program))
+
+(define-syntax-rule (u32-ref buf n)
+ (bytevector-u32-native-ref buf (* n 4)))
+
+(define-syntax-rule (s32-ref buf n)
+ (bytevector-s32-native-ref buf (* n 4)))
+
+(define-syntax visit-opcodes
+ (lambda (x)
+ (syntax-case x ()
+ ((visit-opcodes macro arg ...)
+ (with-syntax (((inst ...)
+ (map (lambda (x) (datum->syntax #'macro x))
+ (rtl-instruction-list))))
+ #'(begin
+ (macro arg ... . inst)
+ ...))))))
+
+(eval-when (expand compile load eval)
+ (define (id-append ctx a b)
+ (datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b)))))
+
+(define (unpack-scm n)
+ (pointer->scm (make-pointer n)))
+
+(define (unpack-s24 s)
+ (if (zero? (logand s (ash 1 23)))
+ s
+ (- s (ash 1 24))))
+
+(define (unpack-s32 s)
+ (if (zero? (logand s (ash 1 31)))
+ s
+ (- s (ash 1 32))))
+
+(define-syntax disassembler
+ (lambda (x)
+ (define (parse-first-word word type)
+ (with-syntax ((word word))
+ (case type
+ ((U8_X24)
+ #'())
+ ((U8_U24)
+ #'((ash word -8)))
+ ((U8_L24)
+ #'((unpack-s24 (ash word -8))))
+ ((U8_R24)
+ #'(#:rest (ash word -8)))
+ ((U8_U8_I16)
+ #'((logand (ash word -8) #xff)
+ (ash word -16)))
+ ((U8_U12_U12)
+ #'((logand (ash word -8) #xfff)
+ (ash word -20)))
+ ((U8_U8_U8_U8)
+ #'((logand (ash word -8) #xff)
+ (logand (ash word -16) #xff)
+ (ash word -24)))
+ (else
+ (error "bad kind" type)))))
+
+ (define (parse-tail-word word type)
+ (with-syntax ((word word))
+ (case type
+ ((U8_X24)
+ #'((logand word #ff)))
+ ((U8_U24)
+ #'((logand word #xff)
+ (ash word -8)))
+ ((U8_L24)
+ #'((logand word #xff)
+ (unpack-s24 (ash word -8))))
+ ((U8_R24)
+ #'((logand word #xff)
+ #:rest (ash word -8)))
+ ((U8_U8_I16)
+ #'((logand word #xff)
+ (logand (ash word -8) #xff)
+ (ash word -16)))
+ ((U8_U12_U12)
+ #'((logand word #xff)
+ (logand (ash word -8) #xfff)
+ (ash word -20)))
+ ((U8_U8_U8_U8)
+ #'((logand word #xff)
+ (logand (ash word -8) #xff)
+ (logand (ash word -16) #xff)
+ (ash word -24)))
+ ((U32)
+ #'(word))
+ ((I32)
+ #'(word))
+ ((A32)
+ #'(word))
+ ((B32)
+ #'(word))
+ ((N32)
+ #'((unpack-s32 word)))
+ ((S32)
+ #'((unpack-s32 word)))
+ ((L32)
+ #'((unpack-s32 word)))
+ ((LO32)
+ #'((unpack-s32 word)))
+ ((X8_U24)
+ #'((ash word -8)))
+ ((X8_U12_U12)
+ #'((logand (ash word -8) #xfff)
+ (ash word -20)))
+ ((X8_R24)
+ #'(#:rest (ash word -8)))
+ ((X8_L24)
+ #'((unpack-s24 (ash word -8))))
+ ((B1_X7_L24)
+ #'((not (zero? (logand word #x1)))
+ (unpack-s24 (ash word -8))))
+ ((B1_U7_L24)
+ #'((not (zero? (logand word #x1)))
+ (logand (ash word -1) #x7f)
+ (unpack-s24 (ash word -8))))
+ (else
+ (error "bad kind" type)))))
+
+ (syntax-case x ()
+ ((_ name opcode word0 word* ...)
+ (let ((vars (generate-temporaries #'(word* ...))))
+ (with-syntax (((word* ...) vars)
+ ((n ...) (map 1+ (iota (length #'(word* ...)))))
+ ((asm ...)
+ (parse-first-word #'first (syntax->datum #'word0)))
+ (((asm* ...) ...)
+ (map (lambda (word type)
+ (parse-tail-word word type))
+ vars
+ (syntax->datum #'(word* ...)))))
+ #'(lambda (buf offset first)
+ (let ((word* (u32-ref buf (+ offset n)))
+ ...)
+ (values (+ 1 (length '(word* ...)))
+ (list 'name asm ... asm* ... ...))))))))))
+
+(define (disasm-invalid buf offset first)
+ (error "bad instruction" (logand first #xff) first buf offset))
+
+(define disassemblers (make-vector 256 disasm-invalid))
+
+(define-syntax define-disassembler
+ (lambda (x)
+ (syntax-case x ()
+ ((_ name opcode arg ...)
+ (with-syntax ((parse (id-append #'name #'parse- #'name)))
+ #'(let ((parse (disassembler name opcode arg ...)))
+ (vector-set! disassemblers opcode parse)))))))
+
+(visit-opcodes define-disassembler)
+
+;; -> len list
+(define (disassemble-one buf offset)
+ (let ((first (u32-ref buf offset)))
+ (call-with-values
+ (lambda ()
+ ((vector-ref disassemblers (logand first #xff)) buf offset first))
+ (lambda (len list)
+ (match list
+ ((head ... #:rest rest)
+ (let lp ((n 0) (rhead (reverse head)))
+ (if (= n rest)
+ (values (+ len n) (reverse rhead))
+ (lp (1+ n)
+ (cons (u32-ref buf (+ offset len n)) rhead)))))
+ (_ (values len list)))))))
+
+(define (u32-offset->addr offset context)
+ "Given an offset into an image in 32-bit units, return the absolute
+address of that offset."
+ (+ (debug-context-base context) (* offset 4)))
+
+(define (code-annotation code len offset start labels context)
+ ;; FIXME: Print names for register loads and stores that correspond to
+ ;; access to named locals.
+ (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 'br
+ 'br-if-nargs-ne 'br-if-nargs-lt 'br-if-nargs-gt
+ 'br-if-true 'br-if-null 'br-if-nil 'br-if-pair 'br-if-struct
+ 'br-if-char 'br-if-tc7 'br-if-eq 'br-if-eqv 'br-if-equal
+ 'br-if-= 'br-if-< 'br-if-<= 'br-if-> 'br-if->=) _ ... target)
+ (list "-> ~A" (vector-ref labels (- (+ offset target) start))))
+ (('prompt tag flags handler)
+ ;; The H is for handler.
+ (list "H -> ~A" (vector-ref labels (- (+ offset handler) start))))
+ (((or 'make-short-immediate 'make-long-immediate) _ imm)
+ (list "~S" (unpack-scm imm)))
+ (('make-long-long-immediate _ high low)
+ (list "~S" (unpack-scm (logior (ash high 32) low))))
+ (('assert-nargs-ee/locals nargs locals)
+ (list "~a arg~:p, ~a local~:p" nargs locals))
+ (('tail-call nargs proc)
+ (list "~a arg~:p" nargs))
+ (('make-closure dst target free ...)
+ (let* ((addr (u32-offset->addr (+ offset target) context))
+ (pdi (find-program-debug-info addr context)))
+ ;; FIXME: Disassemble embedded closures as well.
+ (list "~A at 0x~X"
+ (or (and pdi (program-debug-info-name pdi))
+ "(anonymous procedure)")
+ addr)))
+ (('make-non-immediate dst target)
+ (list "address@hidden" (reference-scm target)))
+ (((or 'static-ref 'static-set!) _ target)
+ (list "address@hidden" (dereference-scm target)))
+ (('link-procedure! src target)
+ (let* ((addr (u32-offset->addr (+ offset target) context))
+ (pdi (find-program-debug-info addr context)))
+ (list "~A at 0x~X"
+ (or (and pdi (program-debug-info-name pdi))
+ "(anonymous procedure)")
+ addr)))
+ (('resolve-module dst name public)
+ (list "~a" (if (zero? public) "private" "public")))
+ (((or 'toplevel-ref 'toplevel-set!) _ var-offset mod-offset sym-offset)
+ (list "`~A'" (dereference-scm sym-offset)))
+ (((or 'module-ref 'module-set!) _ var-offset mod-name-offset sym-offset)
+ (let ((mod-name (reference-scm mod-name-offset)))
+ (list "`(~A ~A ~A)'" (if (car mod-name) '@ '@@) (cdr mod-name)
+ (dereference-scm sym-offset))))
+ (('load-typed-array dst type shape target len)
+ (let ((addr (u32-offset->addr (+ offset target) context)))
+ (list "~a bytes from #x~X" len addr)))
+ (_ #f)))
+
+(define (compute-labels bv start end)
+ (let ((labels (make-vector (- end start) #f)))
+ (define (add-label! pos header)
+ (unless (vector-ref labels (- pos start))
+ (vector-set! labels (- pos start) header)))
+
+ (let lp ((offset start))
+ (when (< offset end)
+ (call-with-values (lambda () (disassemble-one bv offset))
+ (lambda (len elt)
+ (match elt
+ ((inst arg ...)
+ (case inst
+ ((br
+ br-if-nargs-ne br-if-nargs-lt br-if-nargs-gt
+ br-if-true br-if-null br-if-nil br-if-pair br-if-struct
+ br-if-char br-if-tc7 br-if-eq br-if-eqv br-if-equal
+ br-if-= br-if-< br-if-<= br-if-> br-if->=)
+ (match arg
+ ((_ ... target)
+ (add-label! (+ offset target) "L"))))
+ ((prompt)
+ (match arg
+ ((_ ... target)
+ (add-label! (+ offset target) "H"))))
+ ((call call/values)
+ (let* ((MVRA (+ offset len))
+ (RA (+ MVRA 1)))
+ (add-label! MVRA "MVRA")
+ (add-label! RA "RA"))))))
+ (lp (+ offset len))))))
+ (let lp ((offset start) (n 1))
+ (when (< offset end)
+ (let* ((pos (- offset start))
+ (label (vector-ref labels pos)))
+ (if label
+ (begin
+ (vector-set! labels
+ pos
+ (string->symbol
+ (string-append label (number->string n))))
+ (lp (1+ offset) (1+ n)))
+ (lp (1+ offset) n)))))
+ labels))
+
+(define (print-info port addr label info extra src)
+ (when label
+ (format port "~A:\n" label))
+ (format port "address@hidden address@hidden;; address@hidden@[~61t at
~a~]\n"
+ addr info extra src))
+
+(define (disassemble-buffer port bv start end context)
+ (let ((labels (compute-labels bv start end)))
+ (let lp ((offset start))
+ (when (< offset end)
+ (call-with-values (lambda () (disassemble-one bv offset))
+ (lambda (len elt)
+ (let ((pos (- offset start))
+ (annotation (code-annotation elt len offset start labels
+ context)))
+ (print-info port pos (vector-ref labels pos) elt annotation #f)
+ (lp (+ offset len)))))))))
+
+(define* (disassemble-program program #:optional (port (current-output-port)))
+ (cond
+ ((find-program-debug-info (rtl-program-code program))
+ => (lambda (pdi)
+ (format port "Disassembly of ~S at #x~X:\n\n" program
+ (program-debug-info-addr pdi))
+ (disassemble-buffer port
+ (program-debug-info-image pdi)
+ (program-debug-info-u32-offset pdi)
+ (program-debug-info-u32-offset-end pdi)
+ (program-debug-info-context pdi))))
+ (else
+ (format port "Debugging information unavailable.~%")))
+ (values))
diff --git a/module/system/vm/elf.scm b/module/system/vm/elf.scm
index b59970c..5167459 100644
--- a/module/system/vm/elf.scm
+++ b/module/system/vm/elf.scm
@@ -77,11 +77,14 @@
elf-section-header-offset-offset
write-elf-section-header
- make-elf-symbol elf-symbol?
+ (make-elf-symbol* . make-elf-symbol)
+ elf-symbol?
elf-symbol-name elf-symbol-value elf-symbol-size
elf-symbol-info elf-symbol-other elf-symbol-shndx
elf-symbol-binding elf-symbol-type elf-symbol-visibility
+ elf-symbol-len write-elf-symbol
+
SHN_UNDEF
SHT_NULL SHT_PROGBITS SHT_SYMTAB SHT_STRTAB SHT_RELA
@@ -120,8 +123,8 @@
parse-elf
elf-segment elf-segments
- elf-section elf-sections elf-sections-by-name
- elf-symbol-table-ref
+ elf-section elf-sections elf-section-by-name elf-sections-by-name
+ elf-symbol-table-len elf-symbol-table-ref
parse-elf-note
elf-note-name elf-note-desc elf-note-type))
@@ -793,6 +796,17 @@
(utf8->string out))
(lp (1+ end)))))
+(define (elf-section-by-name elf name)
+ (let ((off (elf-section-offset (elf-section elf (elf-shstrndx elf)))))
+ (let lp ((n (elf-shnum elf)))
+ (and (> n 0)
+ (let ((section (elf-section elf (1- n))))
+ (if (equal? (string-table-ref (elf-bytes elf)
+ (+ off (elf-section-name section)))
+ name)
+ section
+ (lp (1- n))))))))
+
(define (elf-sections-by-name elf)
(let* ((sections (elf-sections elf))
(off (elf-section-offset (list-ref sections (elf-shstrndx elf)))))
@@ -812,6 +826,13 @@
(other elf-symbol-other)
(shndx elf-symbol-shndx))
+(define* (make-elf-symbol* #:key (name 0) (value 0) (size 0)
+ (binding STB_LOCAL) (type STT_NOTYPE)
+ (info (logior (ash binding 4) type))
+ (visibility STV_DEFAULT) (other visibility)
+ (shndx SHN_UNDEF))
+ (make-elf-symbol name value size info other shndx))
+
;; typedef struct {
;; uint32_t st_name;
;; Elf32_Addr st_value;
@@ -821,6 +842,12 @@
;; uint16_t st_shndx;
;; } Elf32_Sym;
+(define (elf-symbol-len word-size)
+ (case word-size
+ ((4) 16)
+ ((8) 24)
+ (else (error "bad word size" word-size))))
+
(define (parse-elf32-symbol bv offset stroff byte-order)
(if (<= (+ offset 16) (bytevector-length bv))
(make-elf-symbol (let ((name (bytevector-u32-ref bv offset byte-order)))
@@ -834,6 +861,14 @@
(bytevector-u16-ref bv (+ offset 14) byte-order))
(error "corrupt ELF (offset out of range)" offset)))
+(define (write-elf32-symbol bv offset byte-order sym)
+ (bytevector-u32-set! bv offset (elf-symbol-name sym) byte-order)
+ (bytevector-u32-set! bv (+ offset 4) (elf-symbol-value sym) byte-order)
+ (bytevector-u32-set! bv (+ offset 8) (elf-symbol-size sym) byte-order)
+ (bytevector-u8-set! bv (+ offset 12) (elf-symbol-info sym))
+ (bytevector-u8-set! bv (+ offset 13) (elf-symbol-other sym))
+ (bytevector-u16-set! bv (+ offset 14) (elf-symbol-shndx sym) byte-order))
+
;; typedef struct {
;; uint32_t st_name;
;; unsigned char st_info;
@@ -856,6 +891,28 @@
(bytevector-u16-ref bv (+ offset 6) byte-order))
(error "corrupt ELF (offset out of range)" offset)))
+(define (write-elf64-symbol bv offset byte-order sym)
+ (bytevector-u32-set! bv offset (elf-symbol-name sym) byte-order)
+ (bytevector-u8-set! bv (+ offset 4) (elf-symbol-info sym))
+ (bytevector-u8-set! bv (+ offset 5) (elf-symbol-other sym))
+ (bytevector-u16-set! bv (+ offset 6) (elf-symbol-shndx sym) byte-order)
+ (bytevector-u64-set! bv (+ offset 8) (elf-symbol-value sym) byte-order)
+ (bytevector-u64-set! bv (+ offset 16) (elf-symbol-size sym) byte-order))
+
+(define (write-elf-symbol bv offset byte-order word-size sym)
+ ((case word-size
+ ((4) write-elf32-symbol)
+ ((8) write-elf64-symbol)
+ (else (error "invalid word size" word-size)))
+ bv offset byte-order sym))
+
+(define (elf-symbol-table-len section)
+ (let ((len (elf-section-size section))
+ (entsize (elf-section-entsize section)))
+ (unless (and (not (zero? entsize)) (zero? (modulo len entsize)))
+ (error "bad symbol table" section))
+ (/ len entsize)))
+
(define* (elf-symbol-table-ref elf section n #:optional strtab)
(let ((bv (elf-bytes elf))
(byte-order (elf-byte-order elf))
diff --git a/module/system/vm/linker.scm b/module/system/vm/linker.scm
index a5d43f2..9a51778 100644
--- a/module/system/vm/linker.scm
+++ b/module/system/vm/linker.scm
@@ -85,8 +85,8 @@
(linker-object-symbols* . linker-object-symbols)
make-string-table
- string-table-intern
- link-string-table
+ string-table-intern!
+ link-string-table!
link-elf))
@@ -156,40 +156,52 @@
"Return the linker symbols defined by the user for this this section."
(cdr (linker-object-symbols object)))
+(define-record-type <string-table>
+ (%make-string-table strings linked?)
+ string-table?
+ (strings string-table-strings set-string-table-strings!)
+ (linked? string-table-linked? set-string-table-linked?!))
+
(define (make-string-table)
- "Return a functional string table with one entry: the empty string."
- '(("" 0 #vu8())))
-
-(define (string-table-length table)
- "Return the number of bytes needed for the string table @var{table}."
- (let ((last (car table)))
- ;; The + 1 is for the trailing NUL byte.
- (+ (cadr last) (bytevector-length (caddr last)) 1)))
-
-(define (string-table-intern table str)
- "Add @var{str} to the string table @var{table}. Yields two values: a
-possibly newly allocated string table, and the byte index of the string
-in that table."
- (cond
- ((assoc str table)
- => (lambda (ent)
- (values table (cadr ent))))
- (else
- (let* ((next (string-table-length table)))
- (values (cons (list str next (string->utf8 str))
- table)
- next)))))
-
-(define (link-string-table table)
+ "Return a string table with one entry: the empty string."
+ (%make-string-table '(("" 0 #vu8())) #f))
+
+(define (string-table-length strings)
+ "Return the number of bytes needed for the @var{strings}."
+ (match strings
+ (((str pos bytes) . _)
+ ;; The + 1 is for the trailing NUL byte.
+ (+ pos (bytevector-length bytes) 1))))
+
+(define (string-table-intern! table str)
+ "Ensure that @var{str} is present in the string table @var{table}.
+Returns the byte index of the string in that table."
+ (match table
+ (($ <string-table> strings linked?)
+ (match (assoc str strings)
+ ((_ pos _) pos)
+ (#f
+ (let ((next (string-table-length strings)))
+ (when linked?
+ (error "string table already linked, can't intern" table str))
+ (set-string-table-strings! table
+ (cons (list str next (string->utf8 str))
+ strings))
+ next))))))
+
+(define (link-string-table! table)
"Link the functional string table @var{table} into a sequence of
bytes, suitable for use as the contents of an ELF string table section."
- (let ((out (make-bytevector (string-table-length table) 0)))
- (for-each
- (lambda (ent)
- (let ((bytes (caddr ent)))
- (bytevector-copy! bytes 0 out (cadr ent) (bytevector-length bytes))))
- table)
- out))
+ (match table
+ (($ <string-table> strings #f)
+ (let ((out (make-bytevector (string-table-length strings) 0)))
+ (for-each
+ (match-lambda
+ ((_ pos bytes)
+ (bytevector-copy! bytes 0 out pos (bytevector-length bytes))))
+ strings)
+ (set-string-table-linked?! table #t)
+ out))))
(define (segment-kind section)
"Return the type of segment needed to store @var{section}, as a pair.
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index 1875093..fdfc9a8 100644
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -22,6 +22,7 @@
#:use-module (system base pmatch)
#:use-module (system vm instruction)
#:use-module (system vm objcode)
+ #:use-module (system vm debug)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
@@ -53,6 +54,13 @@
(load-extension (string-append "libguile-" (effective-version))
"scm_init_programs")
+;; This procedure is called by programs.c.
+(define (rtl-program-name program)
+ (unless (rtl-program? program)
+ (error "shouldn't get here"))
+ (and=> (find-program-debug-info (rtl-program-code program))
+ program-debug-info-name))
+
(define (make-binding name boxed? index start end)
(list name boxed? index start end))
(define (binding:name b) (list-ref b 0))
@@ -271,7 +279,7 @@
(define (write-program prog port)
(format port "#<procedure ~a~a>"
(or (procedure-name prog)
- (and=> (program-source prog 0)
+ (and=> (and (program? prog) (program-source prog 0))
(lambda (s)
(format #f "~a at ~a:~a:~a"
(number->string (object-address prog) 16)
@@ -279,7 +287,7 @@
(if s "<current input>" "<unknown port>"))
(source:line-for-user s) (source:column s))))
(number->string (object-address prog) 16))
- (let ((arities (program-arities prog)))
+ (let ((arities (and (program? prog) (program-arities prog))))
(if (or (not arities) (null? arities))
""
(string-append
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index b78f599..fad64b7 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -114,6 +114,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/reader.test \
tests/receive.test \
tests/regexp.test \
+ tests/rtl.test \
tests/session.test \
tests/signals.test \
tests/srcprop.test \
diff --git a/test-suite/tests/rtl.test b/test-suite/tests/rtl.test
new file mode 100644
index 0000000..8429512
--- /dev/null
+++ b/test-suite/tests/rtl.test
@@ -0,0 +1,280 @@
+;;;; Low-level tests of the RTL assembler -*- 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 rtl)
+ #:use-module (test-suite lib)
+ #:use-module (system vm assembler)
+ #:use-module (system vm program)
+ #:use-module (system vm debug))
+
+(define-syntax-rule (assert-equal val expr)
+ (let ((x val))
+ (pass-if (object->string x) (equal? expr x))))
+
+(define (return-constant val)
+ (assemble-program `((begin-program foo)
+ (assert-nargs-ee/locals 0 1)
+ (load-constant 0 ,val)
+ (return 0)
+ (end-program))))
+
+(define-syntax-rule (assert-constants val ...)
+ (begin
+ (assert-equal val ((return-constant val)))
+ ...))
+
+(with-test-prefix "load-constant"
+ (assert-constants
+ 1
+ -1
+ 0
+ most-positive-fixnum
+ most-negative-fixnum
+ #t
+ #\c
+ (integer->char 16000)
+ 3.14
+ "foo"
+ 'foo
+ #:foo
+ "æ" ;; a non-ASCII Latin-1 string
+ "λ" ;; non-ascii, non-latin-1
+ '(1 . 2)
+ '(1 2 3 4)
+ #(1 2 3)
+ #("foo" "bar" 'baz)
+ ;; FIXME: Add tests for arrays (uniform and otherwise)
+ ))
+
+(with-test-prefix "static procedure"
+ (assert-equal 42
+ (((assemble-program `((begin-program foo)
+ (assert-nargs-ee/locals 0 1)
+ (load-static-procedure 0 bar)
+ (return 0)
+ (end-program)
+ (begin-program bar)
+ (assert-nargs-ee/locals 0 1)
+ (load-constant 0 42)
+ (return 0)
+ (end-program)))))))
+
+(with-test-prefix "loop"
+ (assert-equal (* 999 500)
+ (let ((sumto
+ (assemble-program
+ ;; 0: limit
+ ;; 1: n
+ ;; 2: accum
+ '((begin-program countdown)
+ (assert-nargs-ee/locals 1 2)
+ (br fix-body)
+ (label loop-head)
+ (br-if-= 1 0 out)
+ (add 2 1 2)
+ (add1 1 1)
+ (br loop-head)
+ (label fix-body)
+ (load-constant 1 0)
+ (load-constant 2 0)
+ (br loop-head)
+ (label out)
+ (return 2)
+ (end-program)))))
+ (sumto 1000))))
+
+(with-test-prefix "accum"
+ (assert-equal (+ 1 2 3)
+ (let ((make-accum
+ (assemble-program
+ ;; 0: elt
+ ;; 1: tail
+ ;; 2: head
+ '((begin-program make-accum)
+ (assert-nargs-ee/locals 0 2)
+ (load-constant 0 0)
+ (box 0 0)
+ (make-closure 1 accum (0))
+ (return 1)
+ (end-program)
+ (begin-program accum)
+ (assert-nargs-ee/locals 1 2)
+ (free-ref 1 0)
+ (box-ref 2 1)
+ (add 2 2 0)
+ (box-set! 1 2)
+ (return 2)
+ (end-program)))))
+ (let ((accum (make-accum)))
+ (accum 1)
+ (accum 2)
+ (accum 3)))))
+
+(with-test-prefix "call"
+ (assert-equal 42
+ (let ((call ;; (lambda (x) (x))
+ (assemble-program
+ '((begin-program call)
+ (assert-nargs-ee/locals 1 0)
+ (call 1 0 ())
+ (return 1) ;; MVRA from call
+ (return 1) ;; RA from call
+ (end-program)))))
+ (call (lambda () 42))))
+
+ (assert-equal 6
+ (let ((call-with-3 ;; (lambda (x) (x 3))
+ (assemble-program
+ '((begin-program call-with-3)
+ (assert-nargs-ee/locals 1 1)
+ (load-constant 1 3)
+ (call 2 0 (1))
+ (return 2) ;; MVRA from call
+ (return 2) ;; RA from call
+ (end-program)))))
+ (call-with-3 (lambda (x) (* x 2))))))
+
+(with-test-prefix "tail-call"
+ (assert-equal 3
+ (let ((call ;; (lambda (x) (x))
+ (assemble-program
+ '((begin-program call)
+ (assert-nargs-ee/locals 1 0)
+ (tail-call 0 0)
+ (end-program)))))
+ (call (lambda () 3))))
+
+ (assert-equal 6
+ (let ((call-with-3 ;; (lambda (x) (x 3))
+ (assemble-program
+ '((begin-program call-with-3)
+ (assert-nargs-ee/locals 1 1)
+ (mov 1 0) ;; R1 <- R0
+ (load-constant 0 3) ;; R0 <- 3
+ (tail-call 1 1)
+ (end-program)))))
+ (call-with-3 (lambda (x) (* x 2))))))
+
+(with-test-prefix "cached-toplevel-ref"
+ (assert-equal 5.0
+ (let ((get-sqrt-trampoline
+ (assemble-program
+ '((begin-program get-sqrt-trampoline)
+ (assert-nargs-ee/locals 0 1)
+ (cache-current-module! 0 sqrt-scope)
+ (load-static-procedure 0 sqrt-trampoline)
+ (return 0)
+ (end-program)
+
+ (begin-program sqrt-trampoline)
+ (assert-nargs-ee/locals 1 1)
+ (cached-toplevel-ref 1 sqrt-scope sqrt)
+ (tail-call 1 1)
+ (end-program)))))
+ ((get-sqrt-trampoline) 25.0))))
+
+(define *top-val* 0)
+
+(with-test-prefix "cached-toplevel-set!"
+ (let ((prev *top-val*))
+ (assert-equal (1+ prev)
+ (let ((make-top-incrementor
+ (assemble-program
+ '((begin-program make-top-incrementor)
+ (assert-nargs-ee/locals 0 1)
+ (cache-current-module! 0 top-incrementor)
+ (load-static-procedure 0 top-incrementor)
+ (return 0)
+ (end-program)
+
+ (begin-program top-incrementor)
+ (assert-nargs-ee/locals 0 1)
+ (cached-toplevel-ref 0 top-incrementor *top-val*)
+ (add1 0 0)
+ (cached-toplevel-set! 0 top-incrementor *top-val*)
+ (return/values 0)
+ (end-program)))))
+ ((make-top-incrementor))
+ *top-val*))))
+
+(with-test-prefix "cached-module-ref"
+ (assert-equal 5.0
+ (let ((get-sqrt-trampoline
+ (assemble-program
+ '((begin-program get-sqrt-trampoline)
+ (assert-nargs-ee/locals 0 1)
+ (load-static-procedure 0 sqrt-trampoline)
+ (return 0)
+ (end-program)
+
+ (begin-program sqrt-trampoline)
+ (assert-nargs-ee/locals 1 1)
+ (cached-module-ref 1 (guile) #t sqrt)
+ (tail-call 1 1)
+ (end-program)))))
+ ((get-sqrt-trampoline) 25.0))))
+
+(with-test-prefix "cached-module-set!"
+ (let ((prev *top-val*))
+ (assert-equal (1+ prev)
+ (let ((make-top-incrementor
+ (assemble-program
+ '((begin-program make-top-incrementor)
+ (assert-nargs-ee/locals 0 1)
+ (load-static-procedure 0 top-incrementor)
+ (return 0)
+ (end-program)
+
+ (begin-program top-incrementor)
+ (assert-nargs-ee/locals 0 1)
+ (cached-module-ref 0 (tests rtl) #f *top-val*)
+ (add1 0 0)
+ (cached-module-set! 0 (tests rtl) #f *top-val*)
+ (return 0)
+ (end-program)))))
+ ((make-top-incrementor))
+ *top-val*))))
+
+(with-test-prefix "debug contexts"
+ (let ((return-3 (assemble-program
+ '((begin-program return-3)
+ (assert-nargs-ee/locals 0 1)
+ (load-constant 0 3)
+ (return 0)
+ (end-program)))))
+ (pass-if "program name"
+ (and=> (find-program-debug-info (rtl-program-code return-3))
+ (lambda (pdi)
+ (equal? (program-debug-info-name pdi)
+ 'return-3))))
+
+ (pass-if "program address"
+ (and=> (find-program-debug-info (rtl-program-code return-3))
+ (lambda (pdi)
+ (equal? (program-debug-info-addr pdi)
+ (rtl-program-code return-3)))))))
+
+(with-test-prefix "procedure name"
+ (pass-if-equal 'foo
+ (procedure-name
+ (assemble-program
+ '((begin-program foo)
+ (assert-nargs-ee/locals 0 1)
+ (load-constant 0 42)
+ (return 0)
+ (end-program))))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-25-g82e299f,
Andy Wingo <=