[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, wip-case-lambda, updated. release_1-9-
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, wip-case-lambda, updated. release_1-9-3-50-gb9b666f |
|
Date: |
Fri, 09 Oct 2009 13:38:50 +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=b9b666f860e003a28a5ab79c108bbd944c1a3602
The branch, wip-case-lambda has been updated
via b9b666f860e003a28a5ab79c108bbd944c1a3602 (commit)
via 86941378cde1ac8c27834b5483deb305519029a2 (commit)
from 827be0eb86ae0a8d12bdcd1e46ff4bc20607f7a8 (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 b9b666f860e003a28a5ab79c108bbd944c1a3602
Author: Andy Wingo <address@hidden>
Date: Fri Oct 9 13:03:19 2009 +0200
de-nargs struct scm_objcode; remove GHIL; procedure-property refactor
* libguile/objcodes.h (struct scm_objcode): Remove nargs, nrest, and
nlocs, as they are no longer needed. Also obviates the need for a
padding word.
* libguile/procs.c (scm_thunk_p): Use scm_i_program_arity for programs.
* libguile/procprop.c (scm_i_procedure_arity): Use scm_i_program_arity
for programs.
(scm_procedure_properties, scm_set_procedure_properties_x)
(scm_procedure_property, scm_set_procedure_property_x): Rework so that
non-closure properties are stored directly in a weak hash, instead of
needing a weak hash of "stand-in" closures to hold the properties. Fix
docstrings also.
* libguile/root.h (scm_stand_in_procs): Remove from the scm_sys_protects
set. Actually with libGC, we should be able to store the elements of
scm_sys_protects directly as global variables.
* libguile/gc.c (scm_init_storage): Remove scm_stand_in_procs
initialization.
* libguile/programs.c (scm_i_program_arity): New private accessor, tries
to determine the "minimum arity" of a program.
* libguile/vm.c (really_make_boot_program): Adapt to changes in
struct scm_objcode.
* module/Makefile.am:
* module/language/ghil.scm:
* module/language/ghil/compile-glil.scm:
* module/language/ghil/spec.scm:
* module/language/scheme/compile-ghil.scm: Remove GHIL. About time!
* module/language/assembly.scm (*program-header-len*, byte-length):
* module/language/assembly/compile-bytecode.scm (write-bytecode):
* module/language/assembly/decompile-bytecode.scm (decode-load-program):
* module/language/assembly/disassemble.scm (disassemble-load-program):
Adapt to changes in objcode.
* module/system/xref.scm (program-callee-rev-vars): Adapt to changes in
assembly.
* module/language/glil.scm: Remove nargs, nrest, and nlocs from
glil-program.
* module/language/glil/compile-assembly.scm (make-meta, glil->assembly):
* module/language/glil/decompile-assembly.scm (decompile-toplevel):
(decompile-load-program): Adapt to changes in GLIL and assembly.
* module/language/tree-il/compile-glil.scm (flatten-lambda): Adapt to
changes in GLIL.
commit 86941378cde1ac8c27834b5483deb305519029a2
Author: Andy Wingo <address@hidden>
Date: Mon Oct 5 21:58:04 2009 +0200
various callee-parses-args fixes
* libguile/vm-engine.c (vm_engine): Fix miscommented "ra" and "mvra"
pushes. Push the vp->ip as the first ra...
* libguile/vm-i-system.c (halt): Because here we can restore the vp->ip
instead of setting ip to 0. Allows us to introspect ips all down the
stack, including in recursive VM invocations.
(new_frame): More commenting.
* module/language/tree-il/compile-glil.scm (flatten-lambda): Some very
ghetto arglist serializing. Needs help, but at least we get arities
for procedures.
* module/system/vm/program.scm (program-property): Fix typo.
(program-bindings-for-ip): Fix implementation.
(program-arglists): Use program-property.
(program-lambda-list, arglist->lambda-list)
(arguments->lambda-list, write-program): Fix implementation.
-----------------------------------------------------------------------
Summary of changes:
libguile/gc.c | 1 -
libguile/objcodes.h | 7 -
libguile/procprop.c | 115 ++---
libguile/procprop.h | 8 +-
libguile/procs.c | 14 +-
libguile/programs.c | 24 +
libguile/programs.h | 1 +
libguile/root.h | 15 +-
libguile/vm-engine.c | 4 +-
libguile/vm-i-system.c | 6 +-
libguile/vm.c | 4 -
module/Makefile.am | 5 -
module/language/assembly.scm | 6 +-
module/language/assembly/compile-bytecode.scm | 6 +-
module/language/assembly/decompile-bytecode.scm | 8 +-
module/language/assembly/disassemble.scm | 6 +-
module/language/ghil.scm | 478 ------------------
module/language/ghil/compile-glil.scm | 592 -----------------------
module/language/ghil/spec.scm | 62 ---
module/language/glil.scm | 11 +-
module/language/glil/compile-assembly.scm | 6 +-
module/language/glil/decompile-assembly.scm | 13 +-
module/language/scheme/compile-ghil.scm | 494 -------------------
module/language/tree-il/compile-glil.scm | 14 +-
module/system/vm/program.scm | 33 +-
module/system/xref.scm | 2 +-
26 files changed, 162 insertions(+), 1773 deletions(-)
delete mode 100644 module/language/ghil.scm
delete mode 100644 module/language/ghil/compile-glil.scm
delete mode 100644 module/language/ghil/spec.scm
delete mode 100644 module/language/scheme/compile-ghil.scm
diff --git a/libguile/gc.c b/libguile/gc.c
index 7c508af..9c56d04 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -680,7 +680,6 @@ scm_init_storage ()
#endif
- scm_stand_in_procs = scm_make_weak_key_hash_table (scm_from_int (257));
scm_protects = scm_c_make_hash_table (31);
return 0;
diff --git a/libguile/objcodes.h b/libguile/objcodes.h
index 2bb4e60..ab4db3d 100644
--- a/libguile/objcodes.h
+++ b/libguile/objcodes.h
@@ -23,13 +23,9 @@
/* objcode data should be directly mappable to this C structure. */
struct scm_objcode {
- scm_t_uint8 nargs;
- scm_t_uint8 nrest;
- scm_t_uint16 nlocs;
scm_t_uint32 len; /* the maximum index of base[] */
scm_t_uint32 metalen; /* well, i lie. this many bytes at the end of
base[] for metadata */
- scm_t_uint32 unused; /* pad so that `base' is 8-byte aligned */
scm_t_uint8 base[0];
};
@@ -46,9 +42,6 @@ SCM_API scm_t_bits scm_tc16_objcode;
#define SCM_OBJCODE_LEN(x) (SCM_OBJCODE_DATA (x)->len)
#define SCM_OBJCODE_META_LEN(x) (SCM_OBJCODE_DATA (x)->metalen)
#define SCM_OBJCODE_TOTAL_LEN(x) (SCM_OBJCODE_LEN (x) + SCM_OBJCODE_META_LEN
(x))
-#define SCM_OBJCODE_NARGS(x) (SCM_OBJCODE_DATA (x)->nargs)
-#define SCM_OBJCODE_NREST(x) (SCM_OBJCODE_DATA (x)->nrest)
-#define SCM_OBJCODE_NLOCS(x) (SCM_OBJCODE_DATA (x)->nlocs)
#define SCM_OBJCODE_BASE(x) (SCM_OBJCODE_DATA (x)->base)
#define SCM_OBJCODE_IS_MMAP(x) (SCM_SMOB_FLAGS (x) & SCM_F_OBJCODE_IS_MMAP)
diff --git a/libguile/procprop.c b/libguile/procprop.c
index 5054291..4f18dff 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -42,6 +42,9 @@
SCM_GLOBAL_SYMBOL (scm_sym_system_procedure, "system-procedure");
SCM_GLOBAL_SYMBOL (scm_sym_arity, "arity");
+static SCM non_closure_props;
+static scm_i_pthread_mutex_t non_closure_props_lock =
SCM_I_PTHREAD_MUTEX_INITIALIZER;
+
SCM
scm_i_procedure_arity (SCM proc)
{
@@ -74,10 +77,10 @@ scm_i_procedure_arity (SCM proc)
r = 1;
break;
case scm_tc7_program:
- a += SCM_PROGRAM_DATA (proc)->nargs;
- r = SCM_PROGRAM_DATA (proc)->nrest;
- a -= r;
- break;
+ if (scm_i_program_arity (proc, &a, &o, &r))
+ break;
+ else
+ return SCM_BOOL_F;
case scm_tc7_lsubr_2:
a += 2;
r = 1;
@@ -137,92 +140,77 @@ scm_i_procedure_arity (SCM proc)
return scm_list_3 (scm_from_int (a), scm_from_int (o), scm_from_bool(r));
}
-/* XXX - instead of using a stand-in value for everything except
- closures, we should find other ways to store the procedure
- properties for those other kinds of procedures. For example, subrs
- have their own property slot, which is unused at present.
-*/
-
-static SCM
-scm_stand_in_scm_proc(SCM proc)
-{
- SCM handle, answer;
- handle = scm_hashq_get_handle (scm_stand_in_procs, proc);
- if (scm_is_false (handle))
- {
- answer = scm_closure (scm_list_2 (SCM_EOL, SCM_BOOL_F), SCM_EOL);
- scm_hashq_set_x (scm_stand_in_procs, proc, answer);
- }
- else
- answer = SCM_CDR (handle);
- return answer;
-}
+/* FIXME: instead of the weak hash, perhaps for some kinds of procedures, use
+ other means; for example subrs have their own property slot, which is unused
+ at present. */
SCM_DEFINE (scm_procedure_properties, "procedure-properties", 1, 0, 0,
(SCM proc),
"Return @var{obj}'s property list.")
#define FUNC_NAME s_scm_procedure_properties
{
+ SCM props;
+
SCM_VALIDATE_PROC (1, proc);
- return scm_acons (scm_sym_arity, scm_i_procedure_arity (proc),
- SCM_PROCPROPS (SCM_CLOSUREP (proc)
- ? proc
- : scm_stand_in_scm_proc (proc)));
+ if (SCM_CLOSUREP (proc))
+ props = SCM_PROCPROPS (proc);
+ else
+ {
+ scm_i_pthread_mutex_lock (&non_closure_props_lock);
+ props = scm_hashq_ref (non_closure_props, proc, SCM_EOL);
+ scm_i_pthread_mutex_unlock (&non_closure_props_lock);
+ }
+ return scm_acons (scm_sym_arity, scm_i_procedure_arity (proc), props);
}
#undef FUNC_NAME
SCM_DEFINE (scm_set_procedure_properties_x, "set-procedure-properties!", 2, 0,
0,
- (SCM proc, SCM new_val),
- "Set @var{obj}'s property list to @var{alist}.")
+ (SCM proc, SCM alist),
+ "Set @var{proc}'s property list to @var{alist}.")
#define FUNC_NAME s_scm_set_procedure_properties_x
{
- if (!SCM_CLOSUREP (proc))
- proc = scm_stand_in_scm_proc(proc);
- SCM_VALIDATE_CLOSURE (1, proc);
- SCM_SETPROCPROPS (proc, new_val);
+ SCM_VALIDATE_PROC (1, proc);
+
+ if (SCM_CLOSUREP (proc))
+ SCM_SETPROCPROPS (proc, alist);
+ else
+ {
+ scm_i_pthread_mutex_lock (&non_closure_props_lock);
+ scm_hashq_set_x (non_closure_props, proc, alist);
+ scm_i_pthread_mutex_unlock (&non_closure_props_lock);
+ }
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_procedure_property, "procedure-property", 2, 0, 0,
- (SCM p, SCM k),
- "Return the property of @var{obj} with name @var{key}.")
+ (SCM proc, SCM key),
+ "Return the property of @var{proc} with name @var{key}.")
#define FUNC_NAME s_scm_procedure_property
{
- SCM assoc;
- if (scm_is_eq (k, scm_sym_arity))
- {
- SCM arity;
- SCM_ASSERT (scm_is_true (arity = scm_i_procedure_arity (p)),
- p, SCM_ARG1, FUNC_NAME);
- return arity;
- }
- SCM_VALIDATE_PROC (1, p);
- assoc = scm_sloppy_assq (k,
- SCM_PROCPROPS (SCM_CLOSUREP (p)
- ? p
- : scm_stand_in_scm_proc (p)));
- return (SCM_NIMP (assoc) ? SCM_CDR (assoc) : SCM_BOOL_F);
+ SCM_VALIDATE_PROC (1, proc);
+
+ if (scm_is_eq (key, scm_sym_arity))
+ /* avoid a cons in this case */
+ return scm_i_procedure_arity (proc);
+ else
+ return scm_assq_ref (scm_procedure_properties (proc), key);
}
#undef FUNC_NAME
SCM_DEFINE (scm_set_procedure_property_x, "set-procedure-property!", 3, 0, 0,
- (SCM p, SCM k, SCM v),
- "In @var{obj}'s property list, set the property named @var{key}
to\n"
- "@var{value}.")
+ (SCM proc, SCM key, SCM val),
+ "In @var{proc}'s property list, set the property named @var{key}
to\n"
+ "@var{val}.")
#define FUNC_NAME s_scm_set_procedure_property_x
{
- SCM assoc;
- if (!SCM_CLOSUREP (p))
- p = scm_stand_in_scm_proc(p);
- SCM_VALIDATE_CLOSURE (1, p);
- if (scm_is_eq (k, scm_sym_arity))
+ SCM_VALIDATE_PROC (1, proc);
+
+ if (scm_is_eq (key, scm_sym_arity))
SCM_MISC_ERROR ("arity is a read-only property", SCM_EOL);
- assoc = scm_sloppy_assq (k, SCM_PROCPROPS (p));
- if (SCM_NIMP (assoc))
- SCM_SETCDR (assoc, v);
- else
- SCM_SETPROCPROPS (p, scm_acons (k, v, SCM_PROCPROPS (p)));
+ scm_set_procedure_properties_x
+ (proc,
+ scm_assq_set_x (scm_procedure_properties (proc), key, val));
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -233,6 +221,7 @@ SCM_DEFINE (scm_set_procedure_property_x,
"set-procedure-property!", 3, 0, 0,
void
scm_init_procprop ()
{
+ non_closure_props = scm_make_doubly_weak_hash_table (SCM_UNDEFINED);
#include "libguile/procprop.x"
}
diff --git a/libguile/procprop.h b/libguile/procprop.h
index 04cd384..7a11314 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 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000, 2006, 2008, 2009 Free Software
Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -35,9 +35,9 @@ SCM_API SCM scm_sym_system_procedure;
SCM_INTERNAL SCM scm_i_procedure_arity (SCM proc);
SCM_API SCM scm_procedure_properties (SCM proc);
-SCM_API SCM scm_set_procedure_properties_x (SCM proc, SCM new_val);
-SCM_API SCM scm_procedure_property (SCM p, SCM k);
-SCM_API SCM scm_set_procedure_property_x (SCM p, SCM k, SCM v);
+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_INTERNAL void scm_init_procprop (void);
#endif /* SCM_PROCPROP_H */
diff --git a/libguile/procs.c b/libguile/procs.c
index 40d6231..5de2f33 100644
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -144,16 +144,18 @@ SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0,
case scm_tc7_gsubr:
return scm_from_bool (SCM_GSUBR_REQ (SCM_GSUBR_TYPE (obj)) == 0);
case scm_tc7_program:
- return scm_from_bool (SCM_PROGRAM_DATA (obj)->nargs == 0
- || (SCM_PROGRAM_DATA (obj)->nargs == 1
- && SCM_PROGRAM_DATA (obj)->nrest));
+ {
+ int a, o, r;
+ if (scm_i_program_arity (obj, &a, &o, &r))
+ return scm_from_bool (a == 0);
+ else
+ return SCM_BOOL_F;
+ }
case scm_tc7_pws:
obj = SCM_PROCEDURE (obj);
goto again;
default:
- if (SCM_PROGRAM_P (obj) && SCM_PROGRAM_DATA (obj)->nargs == 0)
- return SCM_BOOL_T;
- /* otherwise fall through */
+ return SCM_BOOL_F;
}
}
return SCM_BOOL_F;
diff --git a/libguile/programs.c b/libguile/programs.c
index d91aa05..82adac5 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -265,11 +265,35 @@ SCM_DEFINE (scm_program_objcode, "program-objcode", 1, 0,
0,
}
#undef FUNC_NAME
+/* This one is a shim to pre-case-lambda internal interfaces. Avoid it if you
+ can -- use program-arguments or the like. */
+static SCM sym_arglist;
+int
+scm_i_program_arity (SCM program, int *req, int *opt, int *rest)
+{
+ SCM arglists, x;
+
+ arglists = scm_assq_ref (scm_program_properties (program), sym_arglist);
+ if (!scm_is_pair (arglists))
+ return 0;
+ /* take the last arglist, it will be least specific */
+ while (scm_is_pair (scm_cdr (arglists)))
+ arglists = scm_cdr (arglists);
+ x = scm_car (arglists);
+ *req = scm_ilength (scm_car (x));
+ *opt = scm_ilength (scm_cadr (x));
+ *rest = scm_is_true (scm_car (scm_cddddr (x)));
+ return 1;
+}
+
void
scm_bootstrap_programs (void)
{
+ /* arglist can't be snarfed, because snarfage is only loaded when (system vm
+ program) is loaded. perhaps static-alloc will fix this. */
+ sym_arglist = scm_from_locale_symbol ("arglist");
scm_c_register_extension ("libguile", "scm_init_programs",
(scm_t_extension_init_func)scm_init_programs,
NULL);
}
diff --git a/libguile/programs.h b/libguile/programs.h
index 6799de5..c969ede 100644
--- a/libguile/programs.h
+++ b/libguile/programs.h
@@ -53,6 +53,7 @@ SCM_API SCM scm_program_objcode (SCM program);
SCM_API SCM scm_c_program_source (SCM program, size_t ip);
+SCM_INTERNAL int scm_i_program_arity (SCM program, int *req, int *opt, int
*rest);
SCM_INTERNAL void scm_i_program_print (SCM program, SCM port,
scm_print_state *pstate);
SCM_INTERNAL void scm_bootstrap_programs (void);
diff --git a/libguile/root.h b/libguile/root.h
index 676a7b4..46b9be0 100644
--- a/libguile/root.h
+++ b/libguile/root.h
@@ -3,7 +3,7 @@
#ifndef SCM_ROOT_H
#define SCM_ROOT_H
-/* Copyright (C) 1996,1998,2000,2001, 2002, 2006, 2008 Free Software
Foundation, Inc.
+/* Copyright (C) 1996,1998,2000,2001, 2002, 2006, 2008, 2009 Free Software
Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -34,13 +34,12 @@
#define scm_nullvect scm_sys_protects[2]
#define scm_nullstr scm_sys_protects[3]
#define scm_keyword_obarray scm_sys_protects[4]
-#define scm_stand_in_procs scm_sys_protects[5]
-#define scm_object_whash scm_sys_protects[6]
-#define scm_asyncs scm_sys_protects[7]
-#define scm_protects scm_sys_protects[8]
-#define scm_properties_whash scm_sys_protects[9]
-#define scm_source_whash scm_sys_protects[10]
-#define SCM_NUM_PROTECTS 11
+#define scm_object_whash scm_sys_protects[5]
+#define scm_asyncs scm_sys_protects[6]
+#define scm_protects scm_sys_protects[7]
+#define scm_properties_whash scm_sys_protects[8]
+#define scm_source_whash scm_sys_protects[9]
+#define SCM_NUM_PROTECTS 10
SCM_API SCM scm_sys_protects[];
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 07ea3aa..f86a498 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -107,16 +107,16 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int
nargs)
/* Initial frame */
CACHE_REGISTER ();
PUSH ((SCM)fp); /* dynamic link */
- PUSH (0); /* ra */
PUSH (0); /* mvra */
+ PUSH ((SCM)ip); /* ra */
CACHE_PROGRAM ();
PUSH (program);
fp = sp + 1;
ip = bp->base;
/* MV-call frame, function & arguments */
PUSH ((SCM)fp); /* dynamic link */
- PUSH (0); /* ra */
PUSH (0); /* mvra */
+ PUSH (0); /* ra */
PUSH (prog);
if (SCM_UNLIKELY (sp + nargs >= stack_limit))
goto vm_error_too_many_args;
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index c51b102..71d0666 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -52,7 +52,10 @@ VM_DEFINE_INSTRUCTION (1, halt, "halt", 0, 0, 0)
/* Restore registers */
sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
- ip = NULL;
+ /* Setting the ip here doesn't actually affect control flow, as the calling
+ code will restore its own registers, but it does help when walking the
+ stack */
+ ip = SCM_FRAME_RETURN_ADDRESS (fp);
fp = SCM_FRAME_DYNAMIC_LINK (fp);
NULLSTACK (old_sp - sp);
}
@@ -525,6 +528,7 @@ VM_DEFINE_INSTRUCTION (41, reserve_locals,
"reserve-locals", 2, -1, -1)
VM_DEFINE_INSTRUCTION (42, new_frame, "new-frame", 0, 0, 3)
{
/* NB: if you change this, see frames.c:vm-frame-num-locals */
+ /* and frames.h, vm-engine.c, etc of course */
PUSH ((SCM)fp); /* dynamic link */
PUSH (0); /* mvra */
PUSH (0); /* ra */
diff --git a/libguile/vm.c b/libguile/vm.c
index cd73051..df02f05 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -191,12 +191,8 @@ really_make_boot_program (long nargs)
bp = scm_malloc (sizeof (struct scm_objcode) + sizeof (text));
memcpy (bp->base, text, sizeof (text));
- bp->nargs = 0;
- bp->nrest = 0;
- bp->nlocs = 0;
bp->len = sizeof(text);
bp->metalen = 0;
- bp->unused = 0;
u8vec = scm_take_u8vector ((scm_t_uint8*)bp,
sizeof (struct scm_objcode) + sizeof (text));
diff --git a/module/Makefile.am b/module/Makefile.am
index 668b8a5..ffef560 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -51,7 +51,6 @@ SOURCES =
\
$(OOP_SOURCES) \
$(SYSTEM_SOURCES) \
$(SCRIPTS_SOURCES) \
- $(GHIL_LANG_SOURCES) \
$(ECMASCRIPT_LANG_SOURCES) \
$(BRAINFUCK_LANG_SOURCES)
@@ -69,7 +68,6 @@ ice-9/psyntax-pp.scm: ice-9/psyntax.scm
$(srcdir)/ice-9/psyntax.scm $(srcdir)/ice-9/psyntax-pp.scm
SCHEME_LANG_SOURCES = \
- language/scheme/compile-ghil.scm \
language/scheme/spec.scm \
language/scheme/compile-tree-il.scm \
language/scheme/decompile-tree-il.scm \
@@ -84,9 +82,6 @@ TREE_IL_LANG_SOURCES =
\
language/tree-il/compile-glil.scm \
language/tree-il/spec.scm
-GHIL_LANG_SOURCES = \
- language/ghil.scm language/ghil/spec.scm language/ghil/compile-glil.scm
-
GLIL_LANG_SOURCES = \
language/glil/spec.scm language/glil/compile-assembly.scm \
language/glil/decompile-assembly.scm
diff --git a/module/language/assembly.scm b/module/language/assembly.scm
index 2b22fd8..a7c4749 100644
--- a/module/language/assembly.scm
+++ b/module/language/assembly.scm
@@ -28,8 +28,8 @@
assembly-pack assembly-unpack
object->assembly assembly->object))
-;; nargs, nrest, nlocs, len, metalen, padding
-(define *program-header-len* (+ 1 1 2 4 4 4))
+;; len, metalen
+(define *program-header-len* (+ 4 4))
;; lengths are encoded in 3 bytes
(define *len-len* 3)
@@ -49,7 +49,7 @@
(+ 1 *len-len* (string-length str)))
((load-array ,bv)
(+ 1 *len-len* (bytevector-length bv)))
- ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,code)
+ ((load-program ,labels ,len ,meta . ,code)
(+ 1 *program-header-len* len (if meta (1- (byte-length meta)) 0)))
((,inst . _) (guard (>= (instruction-length inst) 0))
(+ 1 (instruction-length inst)))
diff --git a/module/language/assembly/compile-bytecode.scm
b/module/language/assembly/compile-bytecode.scm
index 5a80981..d92821c 100644
--- a/module/language/assembly/compile-bytecode.scm
+++ b/module/language/assembly/compile-bytecode.scm
@@ -104,13 +104,9 @@
(len (instruction-length inst)))
(write-byte opcode)
(pmatch asm
- ((load-program ,nargs ,nrest ,nlocs ,labels ,length ,meta . ,code)
- (write-byte nargs)
- (write-byte nrest)
- (write-uint16 nlocs)
+ ((load-program ,labels ,length ,meta . ,code)
(write-uint32 length)
(write-uint32 (if meta (1- (byte-length meta)) 0))
- (write-uint32 0) ; padding
(letrec ((i 0)
(write (lambda (x) (set! i (1+ i)) (write-byte x)))
(get-addr (lambda () i)))
diff --git a/module/language/assembly/decompile-bytecode.scm
b/module/language/assembly/decompile-bytecode.scm
index 559abea..6c929cb 100644
--- a/module/language/assembly/decompile-bytecode.scm
+++ b/module/language/assembly/decompile-bytecode.scm
@@ -51,13 +51,10 @@
;; FIXME: this is a little-endian disassembly!!!
(define (decode-load-program pop)
- (let* ((nargs (pop)) (nrest (pop)) (nlocs0 (pop)) (nlocs1 (pop))
- (nlocs (+ nlocs0 (ash nlocs1 8)))
- (a (pop)) (b (pop)) (c (pop)) (d (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)))
- (%unused-pad (begin (pop) (pop) (pop) (pop)))
(labels '())
(i 0))
(define (ensure-label rel1 rel2 rel3)
@@ -77,8 +74,7 @@
(cond ((> i len)
(error "error decoding program -- read too many bytes" out))
((= i len)
- `(load-program ,nargs ,nrest ,nlocs
- ,(map (lambda (x) (cons (cdr x) (car x)))
+ `(load-program ,(map (lambda (x) (cons (cdr x) (car x)))
(reverse labels))
,len
,(if (zero? metalen) #f (decode-load-program pop))
diff --git a/module/language/assembly/disassemble.scm
b/module/language/assembly/disassemble.scm
index ed2a82f..6b0be39 100644
--- a/module/language/assembly/disassemble.scm
+++ b/module/language/assembly/disassemble.scm
@@ -35,7 +35,7 @@
(define (disassemble-load-program asm env)
(pmatch asm
- ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,code)
+ ((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)))
@@ -64,7 +64,9 @@
(lp (+ pos (byte-length asm)) (cdr code) programs))
(else
(print-info pos asm
- (code-annotation end asm objs nargs blocs
+ ;; 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)))))))
diff --git a/module/language/ghil.scm b/module/language/ghil.scm
deleted file mode 100644
index 84cc83d..0000000
--- a/module/language/ghil.scm
+++ /dev/null
@@ -1,478 +0,0 @@
-;;; Guile High Intermediate Language
-
-;; 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 ghil)
- #:use-module (system base syntax)
- #:use-module (system base pmatch)
- #:use-module (ice-9 regex)
- #:export
- (ghil-env ghil-loc
-
- <ghil-void> make-ghil-void ghil-void?
- ghil-void-env ghil-void-loc
-
- <ghil-quote> make-ghil-quote ghil-quote?
- ghil-quote-env ghil-quote-loc ghil-quote-obj
-
- <ghil-quasiquote> make-ghil-quasiquote ghil-quasiquote?
- ghil-quasiquote-env ghil-quasiquote-loc ghil-quasiquote-exp
-
- <ghil-unquote> make-ghil-unquote ghil-unquote?
- ghil-unquote-env ghil-unquote-loc ghil-unquote-exp
-
- <ghil-unquote-splicing> make-ghil-unquote-splicing ghil-unquote-splicing?
- ghil-unquote-splicing-env ghil-unquote-splicing-loc
ghil-unquote-splicing-exp
-
- <ghil-ref> make-ghil-ref ghil-ref?
- ghil-ref-env ghil-ref-loc ghil-ref-var
-
- <ghil-set> make-ghil-set ghil-set?
- ghil-set-env ghil-set-loc ghil-set-var ghil-set-val
-
- <ghil-define> make-ghil-define ghil-define?
- ghil-define-env ghil-define-loc ghil-define-var ghil-define-val
-
- <ghil-if> make-ghil-if ghil-if?
- ghil-if-env ghil-if-loc ghil-if-test ghil-if-then ghil-if-else
-
- <ghil-and> make-ghil-and ghil-and?
- ghil-and-env ghil-and-loc ghil-and-exps
-
- <ghil-or> make-ghil-or ghil-or?
- ghil-or-env ghil-or-loc ghil-or-exps
-
- <ghil-begin> make-ghil-begin ghil-begin?
- ghil-begin-env ghil-begin-loc ghil-begin-exps
-
- <ghil-bind> make-ghil-bind ghil-bind?
- ghil-bind-env ghil-bind-loc ghil-bind-vars ghil-bind-vals ghil-bind-body
-
- <ghil-mv-bind> make-ghil-mv-bind ghil-mv-bind?
- ghil-mv-bind-env ghil-mv-bind-loc ghil-mv-bind-producer ghil-mv-bind-vars
ghil-mv-bind-rest ghil-mv-bind-body
-
- <ghil-lambda> make-ghil-lambda ghil-lambda?
- ghil-lambda-env ghil-lambda-loc ghil-lambda-vars ghil-lambda-rest
- ghil-lambda-meta ghil-lambda-body
-
- <ghil-inline> make-ghil-inline ghil-inline?
- ghil-inline-env ghil-inline-loc ghil-inline-inline ghil-inline-args
-
- <ghil-call> make-ghil-call ghil-call?
- ghil-call-env ghil-call-loc ghil-call-proc ghil-call-args
-
- <ghil-mv-call> make-ghil-mv-call ghil-mv-call?
- ghil-mv-call-env ghil-mv-call-loc ghil-mv-call-producer
ghil-mv-call-consumer
-
- <ghil-values> make-ghil-values ghil-values?
- ghil-values-env ghil-values-loc ghil-values-values
-
- <ghil-values*> make-ghil-values* ghil-values*?
- ghil-values*-env ghil-values*-loc ghil-values*-values
-
- <ghil-var> make-ghil-var ghil-var?
- ghil-var-env ghil-var-name ghil-var-kind ghil-var-index
-
- <ghil-toplevel-env> make-ghil-toplevel-env ghil-toplevel-env?
- ghil-toplevel-env-table
-
- <ghil-env> make-ghil-env ghil-env?
- ghil-env-parent ghil-env-table ghil-env-variables
-
- <ghil-reified-env> make-ghil-reified-env ghil-reified-env?
- ghil-reified-env-env ghil-reified-env-loc
-
- ghil-env-add!
- ghil-env-reify ghil-env-dereify
- ghil-var-is-bound? ghil-var-for-ref! ghil-var-for-set! ghil-var-define!
- ghil-var-at-module!
- call-with-ghil-environment call-with-ghil-bindings
-
- parse-ghil unparse-ghil))
-
-
-;;;
-;;; Parse tree
-;;;
-
-(define (print-ghil x port)
- (format port "#<ghil ~s>" (unparse-ghil x)))
-
-(define-type (<ghil> #:printer print-ghil
- #:common-slots (env loc))
- ;; Objects
- (<ghil-void>)
- (<ghil-quote> obj)
- (<ghil-quasiquote> exp)
- (<ghil-unquote> exp)
- (<ghil-unquote-splicing> exp)
- ;; Variables
- (<ghil-ref> var)
- (<ghil-set> var val)
- (<ghil-define> var val)
- ;; Controls
- (<ghil-if> test then else)
- (<ghil-and> exps)
- (<ghil-or> exps)
- (<ghil-begin> exps)
- (<ghil-bind> vars vals body)
- (<ghil-mv-bind> producer vars rest body)
- (<ghil-lambda> vars rest meta body)
- (<ghil-call> proc args)
- (<ghil-mv-call> producer consumer)
- (<ghil-inline> inline args)
- (<ghil-values> values)
- (<ghil-values*> values)
- (<ghil-reified-env>))
-
-
-
-;;;
-;;; Variables
-;;;
-
-(define-record <ghil-var> env name kind (index #f))
-
-
-;;;
-;;; Modules
-;;;
-
-
-;;;
-;;; Environments
-;;;
-
-(define-record <ghil-env> parent (table '()) (variables '()))
-(define-record <ghil-toplevel-env> (table '()))
-
-(define (ghil-env-ref env sym)
- (assq-ref (ghil-env-table env) sym))
-
-(define-macro (push! item loc)
- `(set! ,loc (cons ,item ,loc)))
-(define-macro (apush! k v loc)
- `(set! ,loc (acons ,k ,v ,loc)))
-(define-macro (apopq! k loc)
- `(set! ,loc (assq-remove! ,loc ,k)))
-
-(define (ghil-env-add! env var)
- (apush! (ghil-var-name var) var (ghil-env-table env))
- (push! var (ghil-env-variables env)))
-
-(define (ghil-env-remove! env var)
- (apopq! (ghil-var-name var) (ghil-env-table env)))
-
-(define (force-heap-allocation! var)
- (set! (ghil-var-kind var) 'external))
-
-
-
-;;;
-;;; Public interface
-;;;
-
-;; The following four functions used to be one, in ghil-lookup. Now they
-;; are four, to reflect the different intents. A bit of duplication, but
-;; that's OK. The common current is to find out where a variable will be
-;; stored at runtime.
-;;
-;; These functions first search the lexical environments. If the
-;; variable is not in the innermost environment, make sure the variable
-;; is marked as being "external" so that it goes on the heap. If the
-;; variable is being modified (via a set!), also make sure it's on the
-;; heap, so that other continuations see the changes to the var.
-;;
-;; If the variable is not found lexically, it is a toplevel variable,
-;; which will be looked up at runtime with respect to the module that
-;; was current when the lambda was bound, at runtime. The variable will
-;; be resolved when it is first used.
-(define (ghil-var-is-bound? env sym)
- (let loop ((e env))
- (record-case e
- ((<ghil-toplevel-env> table)
- (let ((key (cons (module-name (current-module)) sym)))
- (assoc-ref table key)))
- ((<ghil-env> parent table variables)
- (and (not (assq-ref table sym))
- (loop parent))))))
-
-(define (ghil-var-for-ref! env sym)
- (let loop ((e env))
- (record-case e
- ((<ghil-toplevel-env> table)
- (let ((key (cons (module-name (current-module)) sym)))
- (or (assoc-ref table key)
- (let ((var (make-ghil-var (car key) (cdr key) 'toplevel)))
- (apush! key var (ghil-toplevel-env-table e))
- var))))
- ((<ghil-env> parent table variables)
- (cond
- ((assq-ref table sym)
- => (lambda (var)
- (or (eq? e env)
- (force-heap-allocation! var))
- var))
- (else
- (loop parent)))))))
-
-(define (ghil-var-for-set! env sym)
- (let loop ((e env))
- (record-case e
- ((<ghil-toplevel-env> table)
- (let ((key (cons (module-name (current-module)) sym)))
- (or (assoc-ref table key)
- (let ((var (make-ghil-var (car key) (cdr key) 'toplevel)))
- (apush! key var (ghil-toplevel-env-table e))
- var))))
- ((<ghil-env> parent table variables)
- (cond
- ((assq-ref table sym)
- => (lambda (var)
- (force-heap-allocation! var)
- var))
- (else
- (loop parent)))))))
-
-(define (ghil-var-at-module! env modname sym interface?)
- (let loop ((e env))
- (record-case e
- ((<ghil-toplevel-env> table)
- (let ((key (list modname sym interface?)))
- (or (assoc-ref table key)
- (let ((var (make-ghil-var modname sym
- (if interface? 'public 'private))))
- (apush! key var (ghil-toplevel-env-table e))
- var))))
- ((<ghil-env> parent table variables)
- (loop parent)))))
-
-(define (ghil-var-define! toplevel sym)
- (let ((key (cons (module-name (current-module)) sym)))
- (or (assoc-ref (ghil-toplevel-env-table toplevel) key)
- (let ((var (make-ghil-var (car key) (cdr key) 'toplevel)))
- (apush! key var (ghil-toplevel-env-table toplevel))
- var))))
-
-(define (call-with-ghil-environment e syms func)
- (let* ((e (make-ghil-env e))
- (vars (map (lambda (s)
- (let ((v (make-ghil-var e s 'argument)))
- (ghil-env-add! e v) v))
- syms)))
- (func e vars)))
-
-(define (call-with-ghil-bindings e syms func)
- (let* ((vars (map (lambda (s)
- (let ((v (make-ghil-var e s 'local)))
- (ghil-env-add! e v) v))
- syms))
- (ret (func vars)))
- (for-each (lambda (v) (ghil-env-remove! e v)) vars)
- ret))
-
-(define (ghil-env-reify env)
- (let loop ((e env) (out '()))
- (record-case e
- ((<ghil-toplevel-env> table)
- (map (lambda (v)
- (cons (ghil-var-name v)
- (or (ghil-var-index v)
- (error "reify called before indices finalized"))))
- out))
- ((<ghil-env> parent table variables)
- (loop parent
- (append out
- (filter (lambda (v) (eq? (ghil-var-kind v) 'external))
- variables)))))))
-
-(define (ghil-env-dereify name-index-alist)
- (let* ((e (make-ghil-env (make-ghil-toplevel-env)))
- (vars (map (lambda (pair)
- (make-ghil-var e (car pair) 'external (cdr pair)))
- name-index-alist)))
- (set! (ghil-env-table e)
- (map (lambda (v) (cons (ghil-var-name v) v)) vars))
- (set! (ghil-env-variables e) vars)
- e))
-
-
-;;;
-;;; Parser
-;;;
-
-(define (location x)
- (and (pair? x)
- (let ((props (source-properties x)))
- (and (not (null? props))
- (vector (assq-ref props 'line)
- (assq-ref props 'column)
- (assq-ref props 'filename))))))
-
-(define (parse-quasiquote e x level)
- (cond ((not (pair? x)) x)
- ((memq (car x) '(unquote unquote-splicing))
- (let ((l (location x)))
- (pmatch (cdr x)
- ((,obj)
- (cond
- ((zero? level)
- (if (eq? (car x) 'unquote)
- (make-ghil-unquote e l (parse-ghil e obj))
- (make-ghil-unquote-splicing e l (parse-ghil e obj))))
- (else
- (list (car x) (parse-quasiquote e obj (1- level))))))
- (else (syntax-error l (format #f "bad ~A" (car x)) x)))))
- ((eq? (car x) 'quasiquote)
- (let ((l (location x)))
- (pmatch (cdr x)
- ((,obj) (list 'quasiquote (parse-quasiquote e obj (1+ level))))
- (else (syntax-error l (format #f "bad ~A" (car x)) x)))))
- (else (cons (parse-quasiquote e (car x) level)
- (parse-quasiquote e (cdr x) level)))))
-
-(define (parse-ghil env exp)
- (let ((loc (location exp))
- (retrans (lambda (x) (parse-ghil env x))))
- (pmatch exp
- ((ref ,sym) (guard (symbol? sym))
- (make-ghil-ref env #f (ghil-var-for-ref! env sym)))
-
- (('quote ,exp) (make-ghil-quote env loc exp))
-
- ((void) (make-ghil-void env loc))
-
- ((lambda ,syms ,rest ,meta . ,body)
- (call-with-ghil-environment env syms
- (lambda (env vars)
- (make-ghil-lambda env loc vars rest meta
- (parse-ghil env `(begin ,@body))))))
-
- ((begin . ,body)
- (make-ghil-begin env loc (map retrans body)))
-
- ((bind ,syms ,exprs . ,body)
- (let ((vals (map retrans exprs)))
- (call-with-ghil-bindings env syms
- (lambda (vars)
- (make-ghil-bind env loc vars vals (retrans `(begin ,@body)))))))
-
- ((bindrec ,syms ,exprs . ,body)
- (call-with-ghil-bindings env syms
- (lambda (vars)
- (let ((vals (map (lambda (exp) (parse-ghil env exp)) exprs)))
- (make-ghil-bind env loc vars vals (retrans `(begin ,@body)))))))
-
- ((set ,sym ,val)
- (make-ghil-set env loc (ghil-var-for-set! env sym) (retrans val)))
-
- ((define ,sym ,val)
- (make-ghil-define env loc (ghil-var-define! env sym) (retrans val)))
-
- ((if ,test ,then ,else)
- (make-ghil-if env loc (retrans test) (retrans then) (retrans else)))
-
- ((and . ,exps)
- (make-ghil-and env loc (map retrans exps)))
-
- ((or . ,exps)
- (make-ghil-or env loc (map retrans exps)))
-
- ((mv-bind ,syms ,rest ,producer . ,body)
- (call-with-ghil-bindings env syms
- (lambda (vars)
- (make-ghil-mv-bind env loc (retrans producer) vars rest
- (map retrans body)))))
-
- ((call ,proc . ,args)
- (make-ghil-call env loc (retrans proc) (map retrans args)))
-
- ((mv-call ,producer ,consumer)
- (make-ghil-mv-call env loc (retrans producer) (retrans consumer)))
-
- ((inline ,op . ,args)
- (make-ghil-inline env loc op (map retrans args)))
-
- ((values . ,values)
- (make-ghil-values env loc (map retrans values)))
-
- ((values* . ,values)
- (make-ghil-values* env loc (map retrans values)))
-
- ((compile-time-environment)
- (make-ghil-reified-env env loc))
-
- ((quasiquote ,exp)
- (make-ghil-quasiquote env loc (parse-quasiquote env exp 0)))
-
- (else
- (error "unrecognized GHIL" exp)))))
-
-(define (unparse-ghil ghil)
- (record-case ghil
- ((<ghil-void> env loc)
- '(void))
- ((<ghil-quote> env loc obj)
- `(,'quote ,obj))
- ((<ghil-quasiquote> env loc exp)
- `(,'quasiquote ,(let lp ((x exp))
- (cond ((struct? x) (unparse-ghil x))
- ((pair? x) (cons (lp (car x)) (lp (cdr x))))
- (else x)))))
- ((<ghil-unquote> env loc exp)
- `(,'unquote ,(unparse-ghil exp)))
- ((<ghil-unquote-splicing> env loc exp)
- `(,'unquote-splicing ,(unparse-ghil exp)))
- ;; Variables
- ((<ghil-ref> env loc var)
- `(ref ,(ghil-var-name var)))
- ((<ghil-set> env loc var val)
- `(set ,(ghil-var-name var) ,(unparse-ghil val)))
- ((<ghil-define> env loc var val)
- `(define ,(ghil-var-name var) ,(unparse-ghil val)))
- ;; Controls
- ((<ghil-if> env loc test then else)
- `(if ,(unparse-ghil test) ,(unparse-ghil then) ,(unparse-ghil else)))
- ((<ghil-and> env loc exps)
- `(and ,@(map unparse-ghil exps)))
- ((<ghil-or> env loc exps)
- `(or ,@(map unparse-ghil exps)))
- ((<ghil-begin> env loc exps)
- `(begin ,@(map unparse-ghil exps)))
- ((<ghil-bind> env loc vars vals body)
- `(bind ,(map ghil-var-name vars) ,(map unparse-ghil vals)
- ,(unparse-ghil body)))
- ((<ghil-mv-bind> env loc producer vars rest body)
- `(mv-bind ,(map ghil-var-name vars) ,rest
- ,(unparse-ghil producer) ,(unparse-ghil body)))
- ((<ghil-lambda> env loc vars rest meta body)
- `(lambda ,(map ghil-var-name vars) ,rest ,meta
- ,(unparse-ghil body)))
- ((<ghil-call> env loc proc args)
- `(call ,(unparse-ghil proc) ,@(map unparse-ghil args)))
- ((<ghil-mv-call> env loc producer consumer)
- `(mv-call ,(unparse-ghil producer) ,(unparse-ghil consumer)))
- ((<ghil-inline> env loc inline args)
- `(inline ,inline ,@(map unparse-ghil args)))
- ((<ghil-values> env loc values)
- `(values ,@(map unparse-ghil values)))
- ((<ghil-values*> env loc values)
- `(values* ,@(map unparse-ghil values)))
- ((<ghil-reified-env> env loc)
- `(compile-time-environment))))
diff --git a/module/language/ghil/compile-glil.scm
b/module/language/ghil/compile-glil.scm
deleted file mode 100644
index 47e15c7..0000000
--- a/module/language/ghil/compile-glil.scm
+++ /dev/null
@@ -1,592 +0,0 @@
-;;; GHIL -> GLIL compiler
-
-;; 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 ghil compile-glil)
- #:use-module (system base syntax)
- #:use-module (language glil)
- #:use-module (language ghil)
- #:use-module (ice-9 common-list)
- #:export (compile-glil))
-
-(define (compile-glil x e opts)
- (if (memq #:O opts) (set! x (optimize x)))
- (values (codegen x)
- (and e (cons (car e) (cddr e)))
- e))
-
-
-;;;
-;;; Stage 2: Optimization
-;;;
-
-(define (lift-variables! env)
- (let ((parent-env (ghil-env-parent env)))
- (for-each (lambda (v)
- (case (ghil-var-kind v)
- ((argument) (set! (ghil-var-kind v) 'local)))
- (set! (ghil-var-env v) parent-env)
- (ghil-env-add! parent-env v))
- (ghil-env-variables env))))
-
-;; The premise of this, unused, approach to optimization is that you can
-;; determine the environment of a variable lexically, because they have
-;; been alpha-renamed. It makes the transformations *much* easier.
-;; Unfortunately it doesn't work yet.
-(define (optimize* x)
- (transform-record (<ghil> env loc) x
- ((quasiquote exp)
- (define (optimize-qq x)
- (cond ((list? x) (map optimize-qq x))
- ((pair? x) (cons (optimize-qq (car x)) (optimize-qq (cdr x))))
- ((record? x) (optimize x))
- (else x)))
- (-> (quasiquote (optimize-qq x))))
-
- ((unquote exp)
- (-> (unquote (optimize exp))))
-
- ((unquote-splicing exp)
- (-> (unquote-splicing (optimize exp))))
-
- ((set var val)
- (-> (set var (optimize val))))
-
- ((define var val)
- (-> (define var (optimize val))))
-
- ((if test then else)
- (-> (if (optimize test) (optimize then) (optimize else))))
-
- ((and exps)
- (-> (and (map optimize exps))))
-
- ((or exps)
- (-> (or (map optimize exps))))
-
- ((begin exps)
- (-> (begin (map optimize exps))))
-
- ((bind vars vals body)
- (-> (bind vars (map optimize vals) (optimize body))))
-
- ((mv-bind producer vars rest body)
- (-> (mv-bind (optimize producer) vars rest (optimize body))))
-
- ((inline inst args)
- (-> (inline inst (map optimize args))))
-
- ((call (proc (lambda vars (rest #f) meta body)) args)
- (-> (bind vars (optimize args) (optimize body))))
-
- ((call proc args)
- (-> (call (optimize proc) (map optimize args))))
-
- ((lambda vars rest meta body)
- (-> (lambda vars rest meta (optimize body))))
-
- ((mv-call producer (consumer (lambda vars rest meta body)))
- (-> (mv-bind (optimize producer) vars rest (optimize body))))
-
- ((mv-call producer consumer)
- (-> (mv-call (optimize producer) (optimize consumer))))
-
- ((values values)
- (-> (values (map optimize values))))
-
- ((values* values)
- (-> (values* (map optimize values))))
-
- (else
- (error "unrecognized GHIL" x))))
-
-(define (optimize x)
- (record-case x
- ((<ghil-set> env loc var val)
- (make-ghil-set env var (optimize val)))
-
- ((<ghil-define> env loc var val)
- (make-ghil-define env var (optimize val)))
-
- ((<ghil-if> env loc test then else)
- (make-ghil-if env loc (optimize test) (optimize then) (optimize else)))
-
- ((<ghil-and> env loc exps)
- (make-ghil-and env loc (map optimize exps)))
-
- ((<ghil-or> env loc exps)
- (make-ghil-or env loc (map optimize exps)))
-
- ((<ghil-begin> env loc exps)
- (make-ghil-begin env loc (map optimize exps)))
-
- ((<ghil-bind> env loc vars vals body)
- (make-ghil-bind env loc vars (map optimize vals) (optimize body)))
-
- ((<ghil-lambda> env loc vars rest meta body)
- (make-ghil-lambda env loc vars rest meta (optimize body)))
-
- ((<ghil-inline> env loc instruction args)
- (make-ghil-inline env loc instruction (map optimize args)))
-
- ((<ghil-call> env loc proc args)
- (let ((parent-env env))
- (record-case proc
- ;; ((@lambda (VAR...) BODY...) ARG...) =>
- ;; (@let ((VAR ARG) ...) BODY...)
- ((<ghil-lambda> env loc vars rest meta body)
- (cond
- ((not rest)
- (lift-variables! env)
- (make-ghil-bind parent-env loc (map optimize args)))
- (else
- (make-ghil-call parent-env loc (optimize proc) (map optimize
args)))))
- (else
- (make-ghil-call parent-env loc (optimize proc) (map optimize
args))))))
-
- ((<ghil-mv-call> env loc producer consumer)
- (record-case consumer
- ;; (mv-call PRODUCER (lambda ARGS BODY...)) =>
- ;; (mv-let PRODUCER ARGS BODY...)
- ((<ghil-lambda> env loc vars rest meta body)
- (lift-variables! env)
- (make-ghil-mv-bind producer vars rest body))
- (else
- (make-ghil-mv-call env loc (optimize producer) (optimize consumer)))))
-
- (else x)))
-
-
-;;;
-;;; Stage 3: Code generation
-;;;
-
-(define *ia-void* (make-glil-void))
-(define *ia-drop* (make-glil-call 'drop 1))
-(define *ia-return* (make-glil-call 'return 1))
-
-(define (make-label) (gensym ":L"))
-
-(define (make-glil-var op env var)
- (case (ghil-var-kind var)
- ((argument)
- (make-glil-local op (ghil-var-index var)))
- ((local)
- (make-glil-local op (ghil-var-index var)))
- ((external)
- (do ((depth 0 (1+ depth))
- (e env (ghil-env-parent e)))
- ((eq? e (ghil-var-env var))
- (make-glil-external op depth (ghil-var-index var)))))
- ((toplevel)
- (make-glil-toplevel op (ghil-var-name var)))
- ((public private)
- (make-glil-module op (ghil-var-env var) (ghil-var-name var)
- (eq? (ghil-var-kind var) 'public)))
- (else (error "Unknown kind of variable:" var))))
-
-(define (constant? x)
- (cond ((or (number? x) (string? x) (symbol? x) (keyword? x) (boolean? x)) #t)
- ((pair? x) (and (constant? (car x))
- (constant? (cdr x))))
- ((vector? x) (let lp ((i (vector-length x)))
- (or (zero? i)
- (and (constant? (vector-ref x (1- i)))
- (lp (1- i))))))))
-
-(define (codegen ghil)
- (let ((stack '()))
- (define (push-code! loc code)
- (set! stack (cons code stack))
- (if loc (set! stack (cons (make-glil-source loc) stack))))
- (define (var->binding var)
- (list (ghil-var-name var) (let ((kind (ghil-var-kind var)))
- (case kind ((argument) 'local) (else kind)))
- (ghil-var-index var)))
- (define (push-bindings! loc vars)
- (if (not (null? vars))
- (push-code! loc (make-glil-bind (map var->binding vars)))))
- (define (comp tree tail drop)
- (define (push-label! label)
- (push-code! #f (make-glil-label label)))
- (define (push-branch! loc inst label)
- (push-code! loc (make-glil-branch inst label)))
- (define (push-call! loc inst args)
- (for-each comp-push args)
- (push-code! loc (make-glil-call inst (length args))))
- ;; possible tail position
- (define (comp-tail tree) (comp tree tail drop))
- ;; push the result
- (define (comp-push tree) (comp tree #f #f))
- ;; drop the result
- (define (comp-drop tree) (comp tree #f #t))
- ;; drop the result if unnecessary
- (define (maybe-drop)
- (if drop (push-code! #f *ia-drop*)))
- ;; return here if necessary
- (define (maybe-return)
- (if tail (push-code! #f *ia-return*)))
- ;; return this code if necessary
- (define (return-code! loc code)
- (if (not drop) (push-code! loc code))
- (maybe-return))
- ;; return void if necessary
- (define (return-void!)
- (return-code! #f *ia-void*))
- ;; return object if necessary
- (define (return-object! loc obj)
- (return-code! loc (make-glil-const obj)))
- ;;
- ;; dispatch
- (record-case tree
- ((<ghil-void>)
- (return-void!))
-
- ((<ghil-quote> env loc obj)
- (return-object! loc obj))
-
- ((<ghil-quasiquote> env loc exp)
- (let loop ((x exp) (in-car? #f))
- (cond
- ((list? x)
- (push-call! #f 'mark '())
- (for-each (lambda (x) (loop x #t)) x)
- (push-call! #f 'list-mark '()))
- ((pair? x)
- (push-call! #f 'mark '())
- (loop (car x) #t)
- (loop (cdr x) #f)
- (push-call! #f 'cons-mark '()))
- ((record? x)
- (record-case x
- ((<ghil-unquote> env loc exp)
- (comp-push exp))
- ((<ghil-unquote-splicing> env loc exp)
- (if (not in-car?)
- (error "unquote-splicing in the cdr of a pair" exp))
- (comp-push exp)
- (push-call! #f 'list-break '()))))
- ((constant? x)
- (push-code! #f (make-glil-const x)))
- (else
- (error "element of quasiquote can't be compiled" x))))
- (maybe-drop)
- (maybe-return))
-
- ((<ghil-unquote> env loc exp)
- (error "unquote outside of quasiquote" exp))
-
- ((<ghil-unquote-splicing> env loc exp)
- (error "unquote-splicing outside of quasiquote" exp))
-
- ((<ghil-ref> env loc var)
- (return-code! loc (make-glil-var 'ref env var)))
-
- ((<ghil-set> env loc var val)
- (comp-push val)
- (push-code! loc (make-glil-var 'set env var))
- (return-void!))
-
- ((<ghil-define> env loc var val)
- (comp-push val)
- (push-code! loc (make-glil-var 'define env var))
- (return-void!))
-
- ((<ghil-if> env loc test then else)
- ;; TEST
- ;; (br-if-not L1)
- ;; THEN
- ;; (br L2)
- ;; L1: ELSE
- ;; L2:
- (let ((L1 (make-label)) (L2 (make-label)))
- (comp-push test)
- (push-branch! loc 'br-if-not L1)
- (comp-tail then)
- (if (not tail) (push-branch! #f 'br L2))
- (push-label! L1)
- (comp-tail else)
- (if (not tail) (push-label! L2))))
-
- ((<ghil-and> env loc exps)
- ;; EXP
- ;; (br-if-not L1)
- ;; ...
- ;; TAIL
- ;; (br L2)
- ;; L1: (const #f)
- ;; L2:
- (cond ((null? exps) (return-object! loc #t))
- ((null? (cdr exps)) (comp-tail (car exps)))
- (else
- (let ((L1 (make-label)) (L2 (make-label)))
- (let lp ((exps exps))
- (cond ((null? (cdr exps))
- (comp-tail (car exps))
- (push-branch! #f 'br L2)
- (push-label! L1)
- (return-object! #f #f)
- (push-label! L2)
- (maybe-return))
- (else
- (comp-push (car exps))
- (push-branch! #f 'br-if-not L1)
- (lp (cdr exps)))))))))
-
- ((<ghil-or> env loc exps)
- ;; EXP
- ;; (dup)
- ;; (br-if L1)
- ;; (drop)
- ;; ...
- ;; TAIL
- ;; L1:
- (cond ((null? exps) (return-object! loc #f))
- ((null? (cdr exps)) (comp-tail (car exps)))
- (else
- (let ((L1 (make-label)))
- (let lp ((exps exps))
- (cond ((null? (cdr exps))
- (comp-tail (car exps))
- (push-label! L1)
- (maybe-return))
- (else
- (comp-push (car exps))
- (if (not drop)
- (push-call! #f 'dup '()))
- (push-branch! #f 'br-if L1)
- (if (not drop)
- (push-code! loc (make-glil-call 'drop 1)))
- (lp (cdr exps)))))))))
-
- ((<ghil-begin> env loc exps)
- ;; EXPS...
- ;; TAIL
- (if (null? exps)
- (return-void!)
- (do ((exps exps (cdr exps)))
- ((null? (cdr exps))
- (comp-tail (car exps)))
- (comp-drop (car exps)))))
-
- ((<ghil-bind> env loc vars vals body)
- ;; VALS...
- ;; (set VARS)...
- ;; BODY
- (for-each comp-push vals)
- (push-bindings! loc vars)
- (for-each (lambda (var) (push-code! #f (make-glil-var 'set env var)))
- (reverse vars))
- (comp-tail body)
- (push-code! #f (make-glil-unbind)))
-
- ((<ghil-mv-bind> env loc producer vars rest body)
- ;; VALS...
- ;; (set VARS)...
- ;; BODY
- (let ((MV (make-label)))
- (comp-push producer)
- (push-code! loc (make-glil-mv-call 0 MV))
- (push-code! #f (make-glil-const 1))
- (push-label! MV)
- (push-code! #f (make-glil-mv-bind (map var->binding vars) rest))
- (for-each (lambda (var) (push-code! #f (make-glil-var 'set env
var)))
- (reverse vars)))
- (comp-tail body)
- (push-code! #f (make-glil-unbind)))
-
- ((<ghil-lambda> env loc vars rest meta body)
- (return-code! loc (codegen tree)))
-
- ((<ghil-inline> env loc inline args)
- ;; ARGS...
- ;; (INST NARGS)
- (let ((tail-table '((call . goto/args)
- (apply . goto/apply)
- (call/cc . goto/cc))))
- (cond ((and tail (assq-ref tail-table inline))
- => (lambda (tail-inst)
- (push-call! loc tail-inst args)))
- (else
- (push-call! loc inline args)
- (maybe-drop)
- (maybe-return)))))
-
- ((<ghil-values> env loc values)
- (cond (tail ;; (lambda () (values 1 2))
- (push-call! loc 'return/values values))
- (drop ;; (lambda () (values 1 2) 3)
- (for-each comp-drop values))
- (else ;; (lambda () (list (values 10 12) 1))
- (push-code! #f (make-glil-const 'values))
- (push-code! #f (make-glil-call 'link-now 1))
- (push-code! #f (make-glil-call 'variable-ref 0))
- (push-call! loc 'call values))))
-
- ((<ghil-values*> env loc values)
- (cond (tail ;; (lambda () (apply values '(1 2)))
- (push-call! loc 'return/values* values))
- (drop ;; (lambda () (apply values '(1 2)) 3)
- (for-each comp-drop values))
- (else ;; (lambda () (list (apply values '(10 12)) 1))
- (push-code! #f (make-glil-const 'values))
- (push-code! #f (make-glil-call 'link-now 1))
- (push-code! #f (make-glil-call 'variable-ref 0))
- (push-call! loc 'apply values))))
-
- ((<ghil-call> env loc proc args)
- ;; PROC
- ;; ARGS...
- ;; ([tail-]call NARGS)
- (comp-push proc)
- (let ((nargs (length args)))
- (cond ((< nargs 255)
- (push-call! loc (if tail 'goto/args 'call) args))
- (else
- (push-call! loc 'mark '())
- (for-each comp-push args)
- (push-call! loc 'list-mark '())
- (push-code! loc (make-glil-call (if tail 'goto/apply 'apply)
2)))))
- (maybe-drop))
-
- ((<ghil-mv-call> env loc producer consumer)
- ;; CONSUMER
- ;; PRODUCER
- ;; (mv-call MV)
- ;; ([tail]-call 1)
- ;; goto POST
- ;; MV: [tail-]call/nargs
- ;; POST: (maybe-drop)
- (let ((MV (make-label)) (POST (make-label)))
- (comp-push consumer)
- (comp-push producer)
- (push-code! loc (make-glil-mv-call 0 MV))
- (push-code! loc (make-glil-call (if tail 'goto/args 'call) 1))
- (cond ((not tail)
- (push-branch! #f 'br POST)))
- (push-label! MV)
- (push-code! loc (make-glil-call (if tail 'goto/nargs 'call/nargs)
0))
- (cond ((not tail)
- (push-label! POST)
- (maybe-drop)))))
-
- ((<ghil-reified-env> env loc)
- (return-object! loc (ghil-env-reify env)))))
-
- ;;
- ;; main
- (record-case ghil
- ((<ghil-lambda> env loc vars rest meta body)
- (let* ((evars (ghil-env-variables env))
- (locs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) evars))
- (exts (pick (lambda (v) (eq? (ghil-var-kind v) 'external)) evars))
- (nargs (allocate-indices-linearly! vars))
- (nlocs (allocate-locals! locs body nargs))
- (nexts (allocate-indices-linearly! exts)))
- ;; meta bindings
- (push-bindings! #f vars)
- ;; push on definition source location
- (if loc (set! stack (cons (make-glil-source loc) stack)))
- ;; copy args to the heap if they're marked as external
- (do ((n 0 (1+ n))
- (l vars (cdr l)))
- ((null? l))
- (let ((v (car l)))
- (case (ghil-var-kind v)
- ((external)
- (push-code! #f (make-glil-local 'ref n))
- (push-code! #f (make-glil-external 'set 0 (ghil-var-index
v)))))))
- ;; compile body
- (comp body #t #f)
- ;; create GLIL
- (make-glil-program nargs (if rest 1 0) nlocs nexts meta
- (reverse! stack)))))))
-
-(define (allocate-indices-linearly! vars)
- (do ((n 0 (1+ n))
- (l vars (cdr l)))
- ((null? l) n)
- (let ((v (car l))) (set! (ghil-var-index v) n))))
-
-(define (allocate-locals! vars body nargs)
- (let ((free '()) (nlocs nargs))
- (define (allocate! var)
- (cond
- ((pair? free)
- (set! (ghil-var-index var) (car free))
- (set! free (cdr free)))
- (else
- (set! (ghil-var-index var) nlocs)
- (set! nlocs (1+ nlocs)))))
- (define (deallocate! var)
- (set! free (cons (ghil-var-index var) free)))
- (let lp ((x body))
- (record-case x
- ((<ghil-void>))
- ((<ghil-quote>))
- ((<ghil-quasiquote> exp)
- (let qlp ((x exp))
- (cond ((list? x) (for-each qlp x))
- ((pair? x) (qlp (car x)) (qlp (cdr x)))
- ((record? x)
- (record-case x
- ((<ghil-unquote> exp) (lp exp))
- ((<ghil-unquote-splicing> exp) (lp exp)))))))
- ((<ghil-unquote> exp)
- (lp exp))
- ((<ghil-unquote-splicing> exp)
- (lp exp))
- ((<ghil-reified-env>))
- ((<ghil-set> val)
- (lp val))
- ((<ghil-ref>))
- ((<ghil-define> val)
- (lp val))
- ((<ghil-if> test then else)
- (lp test) (lp then) (lp else))
- ((<ghil-and> exps)
- (for-each lp exps))
- ((<ghil-or> exps)
- (for-each lp exps))
- ((<ghil-begin> exps)
- (for-each lp exps))
- ((<ghil-bind> vars vals body)
- (for-each allocate! vars)
- (for-each lp vals)
- (lp body)
- (for-each deallocate! vars))
- ((<ghil-mv-bind> vars producer body)
- (lp producer)
- (for-each allocate! vars)
- (lp body)
- (for-each deallocate! vars))
- ((<ghil-inline> args)
- (for-each lp args))
- ((<ghil-call> proc args)
- (lp proc)
- (for-each lp args))
- ((<ghil-lambda>))
- ((<ghil-mv-call> producer consumer)
- (lp producer)
- (lp consumer))
- ((<ghil-values> values)
- (for-each lp values))
- ((<ghil-values*> values)
- (for-each lp values))))
- nlocs))
diff --git a/module/language/ghil/spec.scm b/module/language/ghil/spec.scm
deleted file mode 100644
index f2bc19b..0000000
--- a/module/language/ghil/spec.scm
+++ /dev/null
@@ -1,62 +0,0 @@
-;;; Guile High Intermediate Language
-
-;; 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 ghil spec)
- #:use-module (system base language)
- #:use-module (language glil)
- #:use-module (language ghil)
- #:use-module (language ghil compile-glil)
- #:export (ghil))
-
-(define (write-ghil exp . port)
- (apply write (unparse-ghil exp) port))
-
-(define (parse x)
- (call-with-ghil-environment (make-ghil-toplevel-env (current-module)) '()
- (lambda (env vars)
- (make-ghil-lambda env #f vars #f '() (parse-ghil env x)))))
-
-(define (join exps env)
- (if (or-map (lambda (x)
- (or (not (ghil-lambda? x))
- (ghil-lambda-rest x)
- (memq 'argument
- (map ghil-var-kind
- (ghil-env-variables (ghil-lambda-env x))))))
- exps)
- (error "GHIL expressions to join must be thunks"))
-
- (let ((env (make-ghil-env env '()
- (apply append
- (map ghil-env-variables
- (map ghil-lambda-env exps))))))
- (make-ghil-lambda env #f '() #f '()
- (make-ghil-begin env #f
- (map ghil-lambda-body exps)))))
-
-(define-language ghil
- #:title "Guile High Intermediate Language (GHIL)"
- #:version "0.3"
- #:reader read
- #:printer write-ghil
- #:parser parse
- #:joiner join
- #:compilers `((glil . ,compile-glil))
- )
diff --git a/module/language/glil.scm b/module/language/glil.scm
index f4e54eb..e8249ac 100644
--- a/module/language/glil.scm
+++ b/module/language/glil.scm
@@ -24,7 +24,6 @@
#:use-module ((srfi srfi-1) #:select (fold))
#:export
(<glil-program> make-glil-program glil-program?
- glil-program-nargs glil-program-nrest glil-program-nlocs
glil-program-meta glil-program-body
<glil-arity> make-glil-arity glil-arity?
@@ -74,7 +73,7 @@
(define-type (<glil> #:printer print-glil)
;; Meta operations
- (<glil-program> nargs nrest nlocs meta body)
+ (<glil-program> meta body)
(<glil-arity> nargs nrest label)
(<glil-bind> vars)
(<glil-mv-bind> vars rest)
@@ -97,8 +96,8 @@
(define (parse-glil x)
(pmatch x
- ((program ,nargs ,nrest ,nlocs ,meta . ,body)
- (make-glil-program nargs nrest nlocs meta (map parse-glil body)))
+ ((program ,meta . ,body)
+ (make-glil-program meta (map parse-glil body)))
((arity ,nargs ,nrest ,label) (make-glil-arity nargs nrest label))
((bind . ,vars) (make-glil-bind vars))
((mv-bind ,vars ,rest) (make-glil-mv-bind vars rest))
@@ -119,8 +118,8 @@
(define (unparse-glil glil)
(record-case glil
;; meta
- ((<glil-program> nargs nrest nlocs meta body)
- `(program ,nargs ,nrest ,nlocs ,meta ,@(map unparse-glil body)))
+ ((<glil-program> meta body)
+ `(program ,meta ,@(map unparse-glil body)))
((<glil-arity> nargs nrest label) `(arity ,nargs ,nrest ,label))
((<glil-bind> vars) `(bind ,@vars))
((<glil-mv-bind> vars rest) `(mv-bind ,vars ,rest))
diff --git a/module/language/glil/compile-assembly.scm
b/module/language/glil/compile-assembly.scm
index dc42649..7a1a0a2 100644
--- a/module/language/glil/compile-assembly.scm
+++ b/module/language/glil/compile-assembly.scm
@@ -72,7 +72,7 @@
(if (and (null? bindings) (null? sources) (null? tail))
#f
(compile-assembly
- (make-glil-program 0 0 0 '()
+ (make-glil-program '()
(list
(make-glil-const `(,bindings ,sources ,@tail))
(make-glil-call 'return 1))))))
@@ -142,7 +142,7 @@
(values x bindings source-alist label-alist object-alist))
(record-case glil
- ((<glil-program> nargs nrest nlocs meta body)
+ ((<glil-program> meta body)
(define (process-body)
(let lp ((body body) (code '()) (bindings '(())) (source-alist '())
(label-alist '()) (object-alist (if toplevel? #f '())) (addr
0))
@@ -166,7 +166,7 @@
(process-body)
(let* ((meta (make-meta bindings sources meta))
(meta-pad (if meta (modulo (- 8 (modulo len 8)) 8) 0))
- (prog `(load-program ,nargs ,nrest ,nlocs ,labels
+ (prog `(load-program ,labels
,(+ len meta-pad)
,meta
,@code
diff --git a/module/language/glil/decompile-assembly.scm
b/module/language/glil/decompile-assembly.scm
index 3cb887d..937a678 100644
--- a/module/language/glil/decompile-assembly.scm
+++ b/module/language/glil/decompile-assembly.scm
@@ -31,9 +31,8 @@
(define (decompile-toplevel x)
(pmatch x
- ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,body)
- (decompile-load-program nargs nrest nlocs
- (decompile-meta meta)
+ ((load-program ,labels ,len ,meta . ,body)
+ (decompile-load-program (decompile-meta meta)
body labels #f))
(else
(error "invalid assembly" x))))
@@ -56,7 +55,7 @@
((glil-program? (car in)) (lp (cdr in) (cons (car in) out)))
(else (lp (cdr in) (cons (make-glil-const (car l)) out))))))
-(define (decompile-load-program nargs nrest nlocs meta body labels
+(define (decompile-load-program meta body labels
objects)
(let ((glil-labels (sort (map (lambda (x)
(cons (cdr x) (make-glil-label (car x))))
@@ -100,7 +99,7 @@
(cond
((null? in)
(or (null? stack) (error "leftover stack insts" stack body))
- (make-glil-program nargs nrest nlocs props (reverse out) #f))
+ (make-glil-program props (reverse out)))
((pop-bindings! pos)
=> (lambda (bindings)
(lp in stack
@@ -123,9 +122,9 @@
(lp (cdr in) stack out (1+ pos)))
((make-false)
(lp (cdr in) (cons #f stack) out (1+ pos)))
- ((load-program ,a ,b ,c ,d ,labels ,sublen ,meta . ,body)
+ ((load-program ,labels ,sublen ,meta . ,body)
(lp (cdr in)
- (cons (decompile-load-program a b c d (decompile-meta meta)
+ (cons (decompile-load-program (decompile-meta meta)
body labels (car stack))
(cdr stack))
out
diff --git a/module/language/scheme/compile-ghil.scm
b/module/language/scheme/compile-ghil.scm
deleted file mode 100644
index dc03af6..0000000
--- a/module/language/scheme/compile-ghil.scm
+++ /dev/null
@@ -1,494 +0,0 @@
-;;; Guile Scheme specification
-
-;; 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 scheme compile-ghil)
- #:use-module (system base pmatch)
- #:use-module (system base language)
- #:use-module (language ghil)
- #:use-module (language scheme inline)
- #:use-module (system vm objcode)
- #:use-module (ice-9 receive)
- #:use-module (ice-9 optargs)
- #:use-module (language tree-il)
- #:use-module ((system base compile) #:select (syntax-error))
- #:export (compile-ghil translate-1
- *translate-table* define-scheme-translator))
-
-;;; environment := #f
-;;; | MODULE
-;;; | COMPILE-ENV
-;;; compile-env := (MODULE LEXICALS|GHIL-ENV . EXTERNALS)
-(define (cenv-module env)
- (cond ((not env) #f)
- ((module? env) env)
- ((and (pair? env) (module? (car env))) (car env))
- (else (error "bad environment" env))))
-
-(define (cenv-ghil-env env)
- (cond ((not env) (make-ghil-toplevel-env))
- ((module? env) (make-ghil-toplevel-env))
- ((pair? env)
- (if (struct? (cadr env))
- (cadr env)
- (ghil-env-dereify (cadr env))))
- (else (error "bad environment" env))))
-
-(define (cenv-externals env)
- (cond ((not env) '())
- ((module? env) '())
- ((pair? env) (cddr env))
- (else (error "bad environment" env))))
-
-(define (make-cenv module lexicals externals)
- (cons module (cons lexicals externals)))
-
-
-
-(define (compile-ghil x e opts)
- (save-module-excursion
- (lambda ()
- (and=> (cenv-module e) set-current-module)
- (call-with-ghil-environment (cenv-ghil-env e) '()
- (lambda (env vars)
- (let ((x (tree-il->scheme
- (sc-expand x 'c '(compile load eval)))))
- (let ((x (make-ghil-lambda env #f vars #f '()
- (translate-1 env #f x)))
- (cenv (make-cenv (current-module)
- (ghil-env-parent env)
- (if e (cenv-externals e) '()))))
- (values x cenv cenv))))))))
-
-
-;;;
-;;; Translator
-;;;
-
-(define *forbidden-primitives*
- ;; Guile's `procedure->macro' family is evil because it crosses the
- ;; compilation boundary. One solution might be to evaluate calls to
- ;; `procedure->memoizing-macro' at compilation time, but it may be more
- ;; compicated than that.
- '(procedure->syntax procedure->macro))
-
-;; Looks up transformers relative to the current module at
-;; compilation-time. See also the discussion of ghil-lookup in ghil.scm.
-;;
-;; FIXME shadowing lexicals?
-(define (lookup-transformer head retrans)
- (define (module-ref/safe mod sym)
- (and mod
- (and=> (module-variable mod sym)
- (lambda (var)
- ;; unbound vars can happen if the module
- ;; definition forward-declared them
- (and (variable-bound? var) (variable-ref var))))))
- (let* ((mod (current-module))
- (val (cond
- ((symbol? head) (module-ref/safe mod head))
- ((pmatch head
- ((@ ,modname ,sym)
- (module-ref/safe (resolve-interface modname) sym))
- ((@@ ,modname ,sym)
- (module-ref/safe (resolve-module modname) sym))
- (else #f)))
- (else #f))))
- (cond
- ((hashq-ref *translate-table* val))
-
- ((macro? val)
- (syntax-error #f "unknown kind of macro" head))
-
- (else #f))))
-
-(define (translate-1 e l x)
- (let ((l (or l (location x))))
- (define (retrans x) (translate-1 e #f x))
- (define (retrans/loc x) (translate-1 e (or (location x) l) x))
- (cond ((pair? x)
- (let ((head (car x)) (tail (cdr x)))
- (cond
- ((lookup-transformer head retrans/loc)
- => (lambda (t) (t e l x)))
-
- ;; FIXME: lexical/module overrides of forbidden primitives
- ((memq head *forbidden-primitives*)
- (syntax-error l (format #f "`~a' is forbidden" head)
- (cons head tail)))
-
- (else
- (let ((tail (map retrans tail)))
- (or (and (symbol? head)
- (try-inline-with-env e l (cons head tail)))
- (make-ghil-call e l (retrans head) tail)))))))
-
- ((symbol? x)
- (make-ghil-ref e l (ghil-var-for-ref! e x)))
-
- ;; fixme: non-self-quoting objects like #<foo>
- (else
- (make-ghil-quote e l x)))))
-
-(define (valid-bindings? bindings . it-is-for-do)
- (define (valid-binding? b)
- (pmatch b
- ((,sym ,var) (guard (symbol? sym)) #t)
- ((,sym ,var ,update) (guard (pair? it-is-for-do) (symbol? sym)) #t)
- (else #f)))
- (and (list? bindings) (and-map valid-binding? bindings)))
-
-(define *translate-table* (make-hash-table))
-
-(define-macro (-> form)
- `(,(symbol-append 'make-ghil- (car form)) e l . ,(cdr form)))
-
-(define-macro (define-scheme-translator sym . clauses)
- `(hashq-set! (@ (language scheme compile-ghil) *translate-table*)
- (module-ref (current-module) ',sym)
- (lambda (e l exp)
- (define (retrans x)
- ((@ (language scheme compile-ghil) translate-1)
- e
- (or ((@@ (language scheme compile-ghil) location) x) l)
- x))
- (define syntax-error (@ (system base compile) syntax-error))
- (pmatch (cdr exp)
- ,@clauses
- ,@(if (assq 'else clauses) '()
- `((else
- (syntax-error l (format #f "bad ~A" ',sym)
exp))))))))
-
-(define-scheme-translator quote
- ;; (quote OBJ)
- ((,obj)
- (-> (quote obj))))
-
-(define-scheme-translator quasiquote
- ;; (quasiquote OBJ)
- ((,obj)
- (-> (quasiquote (trans-quasiquote e l obj 0)))))
-
-(define-scheme-translator define
- ;; (define NAME VAL)
- ((,name ,val) (guard (symbol? name)
- (ghil-toplevel-env? (ghil-env-parent e)))
- (-> (define (ghil-var-define! (ghil-env-parent e) name)
- (maybe-name-value! (retrans val) name))))
- ;; (define (NAME FORMALS...) BODY...)
- (((,name . ,formals) . ,body) (guard (symbol? name))
- ;; -> (define NAME (lambda FORMALS BODY...))
- (retrans `(define ,name (lambda ,formals ,@body)))))
-
-(define-scheme-translator set!
- ;; (set! NAME VAL)
- ((,name ,val) (guard (symbol? name))
- (-> (set (ghil-var-for-set! e name) (retrans val))))
-
- ;; FIXME: Would be nice to verify the values of @ and @@ relative
- ;; to imported modules...
- (((@ ,modname ,name) ,val) (guard (symbol? name)
- (list? modname)
- (and-map symbol? modname)
- (not (ghil-var-is-bound? e '@)))
- (-> (set (ghil-var-at-module! e modname name #t) (retrans val))))
-
- (((@@ ,modname ,name) ,val) (guard (symbol? name)
- (list? modname)
- (and-map symbol? modname)
- (not (ghil-var-is-bound? e '@@)))
- (-> (set (ghil-var-at-module! e modname name #f) (retrans val))))
-
- ;; (set! (NAME ARGS...) VAL)
- (((,name . ,args) ,val) (guard (symbol? name))
- ;; -> ((setter NAME) ARGS... VAL)
- (retrans `((setter ,name) . (,@args ,val)))))
-
-(define-scheme-translator if
- ;; (if TEST THEN [ELSE])
- ((,test ,then)
- (-> (if (retrans test) (retrans then) (retrans '(begin)))))
- ((,test ,then ,else)
- (-> (if (retrans test) (retrans then) (retrans else)))))
-
-(define-scheme-translator and
- ;; (and EXPS...)
- (,tail
- (-> (and (map retrans tail)))))
-
-(define-scheme-translator or
- ;; (or EXPS...)
- (,tail
- (-> (or (map retrans tail)))))
-
-(define-scheme-translator begin
- ;; (begin EXPS...)
- (,tail
- (-> (begin (map retrans tail)))))
-
-(define-scheme-translator let
- ;; (let NAME ((SYM VAL) ...) BODY...)
- ((,name ,bindings . ,body) (guard (symbol? name)
- (valid-bindings? bindings))
- ;; -> (letrec ((NAME (lambda (SYM...) BODY...))) (NAME VAL...))
- (retrans `(letrec ((,name (lambda ,(map car bindings) ,@body)))
- (,name ,@(map cadr bindings)))))
-
- ;; (let () BODY...)
- ((() . ,body)
- ;; Note: this differs from `begin'
- (-> (begin (list (trans-body e l body)))))
-
- ;; (let ((SYM VAL) ...) BODY...)
- ((,bindings . ,body) (guard (valid-bindings? bindings))
- (let ((vals (map (lambda (b)
- (maybe-name-value! (retrans (cadr b)) (car b)))
- bindings)))
- (call-with-ghil-bindings e (map car bindings)
- (lambda (vars)
- (-> (bind vars vals (trans-body e l body))))))))
-
-(define-scheme-translator let*
- ;; (let* ((SYM VAL) ...) BODY...)
- ((() . ,body)
- (retrans `(let () ,@body)))
- ((((,sym ,val) . ,rest) . ,body) (guard (symbol? sym))
- (retrans `(let ((,sym ,val)) (let* ,rest ,@body)))))
-
-(define-scheme-translator letrec
- ;; (letrec ((SYM VAL) ...) BODY...)
- ((,bindings . ,body) (guard (valid-bindings? bindings))
- (call-with-ghil-bindings e (map car bindings)
- (lambda (vars)
- (let ((vals (map (lambda (b)
- (maybe-name-value!
- (retrans (cadr b)) (car b)))
- bindings)))
- (-> (bind vars vals (trans-body e l body))))))))
-
-(define-scheme-translator cond
- ;; (cond (CLAUSE BODY...) ...)
- (() (retrans '(begin)))
- (((else . ,body)) (retrans `(begin ,@body)))
- (((,test) . ,rest) (retrans `(or ,test (cond ,@rest))))
- (((,test => ,proc) . ,rest)
- ;; FIXME hygiene!
- (retrans `(let ((_t ,test)) (if _t (,proc _t) (cond ,@rest)))))
- (((,test . ,body) . ,rest)
- (retrans `(if ,test (begin ,@body) (cond ,@rest)))))
-
-(define-scheme-translator case
- ;; (case EXP ((KEY...) BODY...) ...)
- ((,exp . ,clauses)
- (retrans
- ;; FIXME hygiene!
- `(let ((_t ,exp))
- ,(let loop ((ls clauses))
- (cond ((null? ls) '(begin))
- ((eq? (caar ls) 'else) `(begin ,@(cdar ls)))
- (else `(if (memv _t ',(caar ls))
- (begin ,@(cdar ls))
- ,(loop (cdr ls))))))))))
-
-(define-scheme-translator do
- ;; (do ((SYM VAL [UPDATE]) ...) (TEST RESULT...) BODY...)
- ((,bindings (,test . ,result) . ,body)
- (let ((sym (map car bindings))
- (val (map cadr bindings))
- (update (map cddr bindings)))
- (define (next s x) (if (pair? x) (car x) s))
- (retrans
- ;; FIXME hygiene!
- `(letrec ((_l (lambda ,sym
- (if ,test
- (begin ,@result)
- (begin ,@body
- (_l ,@(map next sym update)))))))
- (_l ,@val))))))
-
-(define-scheme-translator lambda
- ;; (lambda FORMALS BODY...)
- ((,formals . ,body)
- (receive (syms rest) (parse-formals formals)
- (call-with-ghil-environment e syms
- (lambda (e vars)
- (receive (meta body) (parse-lambda-meta body)
- (-> (lambda vars rest meta (trans-body e l body)))))))))
-
-(define-scheme-translator delay
- ;; FIXME not hygienic
- ((,expr)
- (retrans `(make-promise (lambda () ,expr)))))
-
-(define-scheme-translator @
- ((,modname ,sym)
- (-> (ref (ghil-var-at-module! e modname sym #t)))))
-
-(define-scheme-translator @@
- ((,modname ,sym)
- (-> (ref (ghil-var-at-module! e modname sym #f)))))
-
-(define *the-compile-toplevel-symbol* 'compile-toplevel)
-(define-scheme-translator eval-when
- ((,when . ,body) (guard (list? when) (and-map symbol? when))
- (if (memq 'compile when)
- (primitive-eval `(begin . ,body)))
- (if (memq 'load when)
- (retrans `(begin . ,body))
- (retrans `(begin)))))
-
-(define-scheme-translator apply
- ;; FIXME: not hygienic, relies on @apply not being shadowed
- (,args (retrans `(@apply ,@args))))
-
-;; FIXME: we could add inliners for `list' and `vector'
-
-(define-scheme-translator @apply
- ((,proc ,arg1 . ,args)
- (let ((args (cons (retrans arg1) (map retrans args))))
- (cond ((and (symbol? proc)
- (not (ghil-var-is-bound? e proc))
- (and=> (module-variable (current-module) proc)
- (lambda (var)
- (and (variable-bound? var)
- (lookup-apply-transformer (variable-ref
var))))))
- ;; that is, a variable, not part of this compilation
- ;; unit, but defined in the toplevel environment, and has
- ;; an apply transformer registered
- => (lambda (t) (t e l args)))
- (else
- (-> (inline 'apply (cons (retrans proc) args))))))))
-
-(define-scheme-translator call-with-values
- ;; FIXME: not hygienic, relies on @call-with-values not being shadowed
- ((,producer ,consumer)
- (retrans `(@call-with-values ,producer ,consumer)))
- (else #f))
-
-(define-scheme-translator @call-with-values
- ((,producer ,consumer)
- (-> (mv-call (retrans producer) (retrans consumer)))))
-
-(define-scheme-translator call-with-current-continuation
- ;; FIXME: not hygienic, relies on @call-with-current-continuation
- ;; not being shadowed
- ((,proc)
- (retrans `(@call-with-current-continuation ,proc)))
- (else #f))
-
-(define-scheme-translator @call-with-current-continuation
- ((,proc)
- (-> (inline 'call/cc (list (retrans proc))))))
-
-(define-scheme-translator receive
- ((,formals ,producer-exp . ,body)
- ;; Lovely, self-referential usage. Not strictly necessary, the
- ;; macro would do the trick; but it's good to test the mv-bind
- ;; code.
- (receive (syms rest) (parse-formals formals)
- (let ((producer (retrans `(lambda () ,producer-exp))))
- (call-with-ghil-bindings e syms
- (lambda (vars)
- (-> (mv-bind producer vars rest
- (trans-body e l body)))))))))
-
-(define-scheme-translator values
- ((,x) (retrans x))
- (,args
- (-> (values (map retrans args)))))
-
-(define (lookup-apply-transformer proc)
- (cond ((eq? proc values)
- (lambda (e l args)
- (-> (values* args))))
- (else #f)))
-
-(define (trans-quasiquote e l x level)
- (cond ((not (pair? x)) x)
- ((memq (car x) '(unquote unquote-splicing))
- (let ((l (location x)))
- (pmatch (cdr x)
- ((,obj)
- (cond
- ((zero? level)
- (if (eq? (car x) 'unquote)
- (-> (unquote (translate-1 e l obj)))
- (-> (unquote-splicing (translate-1 e l obj)))))
- (else
- (list (car x) (trans-quasiquote e l obj (1- level))))))
- (else (syntax-error l (format #f "bad ~A" (car x)) x)))))
- ((eq? (car x) 'quasiquote)
- (let ((l (location x)))
- (pmatch (cdr x)
- ((,obj) (list 'quasiquote (trans-quasiquote e l obj (1+ level))))
- (else (syntax-error l (format #f "bad ~A" (car x)) x)))))
- (else (cons (trans-quasiquote e l (car x) level)
- (trans-quasiquote e l (cdr x) level)))))
-
-(define (trans-body e l body)
- (define (define->binding df)
- (pmatch (cdr df)
- ((,name ,val) (guard (symbol? name)) (list name val))
- (((,name . ,formals) . ,body) (guard (symbol? name))
- (list name `(lambda ,formals ,@body)))
- (else (syntax-error (location df) "bad define" df))))
- ;; main
- (let loop ((ls body) (ds '()))
- (pmatch ls
- (() (syntax-error l "bad body" body))
- (((define . _) . _)
- (loop (cdr ls) (cons (car ls) ds)))
- (else
- (if (null? ds)
- (translate-1 e l `(begin ,@ls))
- (translate-1 e l `(letrec ,(map define->binding ds) ,@ls)))))))
-
-(define (parse-formals formals)
- (cond
- ;; (lambda x ...)
- ((symbol? formals) (values (list formals) #t))
- ;; (lambda (x y z) ...)
- ((list? formals) (values formals #f))
- ;; (lambda (x y . z) ...)
- ((pair? formals)
- (let loop ((l formals) (v '()))
- (if (pair? l)
- (loop (cdr l) (cons (car l) v))
- (values (reverse! (cons l v)) #t))))
- (else (syntax-error (location formals) "bad formals" formals))))
-
-(define (parse-lambda-meta body)
- (cond ((or (null? body) (null? (cdr body))) (values '() body))
- ((string? (car body))
- (values `((documentation . ,(car body))) (cdr body)))
- (else (values '() body))))
-
-(define (maybe-name-value! val name)
- (cond
- ((ghil-lambda? val)
- (if (not (assq-ref (ghil-lambda-meta val) 'name))
- (set! (ghil-lambda-meta val)
- (acons 'name name (ghil-lambda-meta val))))))
- val)
-
-(define (location x)
- (and (pair? x)
- (let ((props (source-properties x)))
- (and (not (null? props))
- props))))
diff --git a/module/language/tree-il/compile-glil.scm
b/module/language/tree-il/compile-glil.scm
index d36b91f..22adf73 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -171,6 +171,17 @@
(proc emit-code)
(reverse out)))
+(define (args->arglist args)
+ (let lp ((args args) (req '()) (rest #f))
+ (cond ((null? args) `(,(reverse req) () () #f ,rest))
+ ((pair? args) (lp (cdr args) (cons (car args) req) rest))
+ (else (lp '() req args)))))
+
+(define (decorate-arglist meta x)
+ (if (assq 'arglist meta)
+ meta
+ `(,@meta (arglist ,x))))
+
(define (flatten-lambda x self-label allocation)
(receive (ids vars nargs nrest)
(let lp ((ids (lambda-names x)) (vars (lambda-vars x))
@@ -185,7 +196,8 @@
(let ((nlocs (car (hashq-ref allocation x)))
(labels (cadr (hashq-ref allocation x))))
(make-glil-program
- nargs nrest nlocs (lambda-meta x)
+ (decorate-arglist (lambda-meta x)
+ (args->arglist (lambda-names x)))
(with-output-to-code
(lambda (emit-code)
;; write source info for proc
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index 78de8e8..53f276f 100644
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -58,7 +58,7 @@
(cdddr source))
(define (program-property prog prop)
- (assq-ref (program-properties proc) prop))
+ (assq-ref (program-properties prog) prop))
(define (program-documentation prog)
(assq-ref (program-properties prog) 'documentation))
@@ -96,12 +96,11 @@
(binding:end (car binds)))
(car binds))
(else (lp (cdr binds)))))
- out))))
- (and=> (program-bindings prog) collapse-locals))
+ out)))))
;; returns a list of arglists
(define (program-arglists prog)
- (or (assq-ref (program-properties prog) 'arglist)) '())
+ (or (program-property prog 'arglist) '()))
(define (arglist->arguments arglist)
(pmatch arglist
@@ -135,16 +134,26 @@
(lp args)))))
(define* (program-lambda-list prog #:optional ip)
- (and=> (program-arguments prog ip) arglist->lambda-list))
+ (and=> (program-arguments prog ip) arguments->lambda-list))
(define (arglist->lambda-list arglist)
+ (pmatch arglist
+ ((,req ,opt ,key _ ,rest . _)
+ `(,@req
+ ,@(if (pair? opt) (cons #:optional opt) '())
+ ,@(if (pair? key) (cons #:key key) '())
+ . ,(or rest '())))
+ (else (error "what" arglist))))
+
+(define (arguments->lambda-list arguments)
(let ((req (or (assq-ref arguments 'required) '()))
- (opt (assq-ref arguments 'optional))
- (key (assq-ref arguments 'keyword))
+ (opt (or (assq-ref arguments 'optional) '()))
+ (key (or (assq-ref arguments 'keyword) '()))
(rest (or (assq-ref arguments 'rest) '())))
- `(,@req ,@(if opt (cons #:optional opt) '())
- ,@(if key (cons #:key key) '())
- . ,rest)))
+ `(,@req
+ ,@(if (pair? opt) (cons #:optional opt) '())
+ ,@(if (pair? key) (cons #:key key) '())
+ . ,rest)))
(define (write-program prog port)
(format port "#<program ~a~a>"
@@ -160,7 +169,7 @@
(if (null? arglists)
""
(string-append
- " " (string-join (map ->string (map arglist->lambda-list
- arglists))
+ " " (string-join (map object->string (map arglist->lambda-list
+ arglists))
" | "))))))
diff --git a/module/system/xref.scm b/module/system/xref.scm
index 906ec8e..94ecb5b 100644
--- a/module/system/xref.scm
+++ b/module/system/xref.scm
@@ -35,7 +35,7 @@
(progv (make-vector (vector-length objects) #f))
(asm (decompile (program-objcode prog) #:to 'assembly)))
(pmatch asm
- ((load-program ,nargs ,nrest ,nlocs ,labels ,len . ,body)
+ ((load-program ,labels ,len . ,body)
(for-each
(lambda (x)
(pmatch x
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, wip-case-lambda, updated. release_1-9-3-50-gb9b666f,
Andy Wingo <=