dmbcs/guile
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge.

Browse source
This commit is contained in:
Dale Mellor 2020-05-13 08:01:12 +01:00
commit 38745ce13f
33 changed files with 1052 additions and 774 deletions
Download patch file Download diff file Expand all files Collapse all files

3
.dir-locals.el
View file

@ -10,6 +10,7 @@
(eval . (put 'pass-if-exception 'scheme-indent-function 2))
(eval . (put 'pass-if-equal 'scheme-indent-function 2))
(eval . (put 'with-test-prefix 'scheme-indent-function 1))
(eval . (put 'with-test-prefix/c&e 'scheme-indent-function 1))
(eval . (put 'with-code-coverage 'scheme-indent-function 1))
(eval . (put 'with-statprof 'scheme-indent-function 1))
(eval . (put 'let-gensyms 'scheme-indent-function 1))
@ -41,7 +42,7 @@
(eval . (put '$letrec 'scheme-indent-function 3))
(eval . (put '$kclause 'scheme-indent-function 1))
(eval . (put '$fun 'scheme-indent-function 1))
(eval . (put 'syntax-parameterize 'scheme-indent-function 1))))))
(eval . (put 'syntax-parameterize 'scheme-indent-function 1))))
(emacs-lisp-mode . ((indent-tabs-mode . nil)))
(texinfo-mode . ((indent-tabs-mode . nil)
(fill-column . 72))))

105
NEWS
View file

@ -9,84 +9,121 @@ Changes in 3.0.3 (since 3.0.2)
* New interfaces and functionality
** New bitvector-count, bitvector-count-bits, bitvector-position
procedures
** New baseline compiler
Guile's CPS-based compiler generates good code, but it takes time and
memory to do so. For users that prioritize speed of compilation over
speed of generated code, Guile now has a new baseline compiler that goes
directly from the high-level Tree-IL to bytecode, skipping CPS and all
of its optimizations. This compiler is used for `guild compile -O0',
and generally runs around ten times as fast as the CPS compiler.
*** New VM intrinsics to support baseline compiler
See "Intrinsic Call Instructions" in the manual.
*** Compiler support for warning and lowering passes
*** Compiler support for choosing different compilation orders
See "Compiler Tower" in the manual. The new per-language "compiler
chooser" facility can choose different compilers based on optimization
level.
*** Better support for specifying optimization and warning levels
The procedural compilation interfaces (`compile', `compile-file', and so
on) now have #:optimization-level and #:warning-level keyword arguments,
which default to corresponding `default-optimization-level' and
`default-warning-level' parameters. You can still specify warning and
optimization passes manually, but we think most users will find the
higher-level interfaces more robust to use.
** Faster Guile build from source
Guile now uses the baseline compiler for its bootstrap, when building
the first Scheme compiler. Because the baseline compiler runs faster
and includes less code than the CPS compiler, Guile takes less time to
build.
** Refreshed bitvector facility
See "Bit Vectors" in the manual, for more on all of these.
*** New bitvector-count, bitvector-count-bits, bitvector-position
procedures
These replace the wonky "bit-count", "bit-count*", and "bit-position"
procedures. See "Bit Vectors" in the manual, for more.
procedures.
** New bitvector-bit-set?, bitvector-bit-clear? procedures
*** New bitvector-bit-set?, bitvector-bit-clear? procedures
These replace bitvector-ref. The reason to migrate is that it's an
opportunity be more efficient in 3.0 (because no generic array support),
easier to read (no need for 'not' when checking for false bits), and
more consistent with other bitvector procedures.
opportunity be more efficient in 3.0 (because the new procedures only
work on true bitvectors, and not generic bit arrays), easier to read (no
need for 'not' when checking for false bits), and more consistent with
other bitvector procedures.
** New bitvector-set-bit!, bitvector-clear-bit! procedures
*** New bitvector-set-bit!, bitvector-clear-bit! procedures
These replace bitvector-set!, for similar reasons as the bitvector-ref
replacement above.
** New bitvector-set-all-bits!, bitvector-clear-all-bits! procedures
*** New bitvector-set-all-bits!, bitvector-clear-all-bits! procedures
These replace bitvector-fill!.
** New bitvector-flip-all-bits! procedure
*** New bitvector-flip-all-bits! procedure
This replaces bit-invert!.
** New bitvector-set-bits!, bitvector-clear-bits! procedures
*** New bitvector-set-bits!, bitvector-clear-bits! procedures
These replace the wonky "bit-set*!" procedure. See "Bit Vectors" in the
manual, for more.
These replace the wonky "bit-set*!" procedure.
* New deprecations
** bit-count, bit-position deprecated
** Old bitvector interfaces deprecated
Use bitvector-count or bitvector-position instead. See "Bit Vectors" in
the manual.
See "Bit Vectors" in the manual, for details on all of these
replacements.
** 'bitvector-ref' deprecated
*** bit-count, bit-position
Use bitvector-count or bitvector-position instead.
*** bitvector-ref
Use 'bitvector-bit-set?' or 'bitvector-bit-clear?' instead.
** 'bitvector-set!' deprecated
*** bitvector-set!
Use 'bitvector-set-bit!' or 'bitvector-clear-bit!' instead.
** 'bitvector-fill!' deprecated
*** bitvector-fill!
Use 'bitvector-set-all-bits!' or 'bitvector-clear-all-bits!' instead.
** 'bit-invert!' deprecated
*** bit-invert!
Use 'bitvector-flip-all-bits! instead.
** 'bit-set*!' deprecated
*** bit-set*!
Use 'bitvector-set-bits!' or 'bitvector-clear-bits!' instead.
** 'bit-count*' deprecated
*** bit-count*
Use 'bitvector-count-bits' instead, subtracting from 'bitvector-count'
on the mask bitvector if you are counting unset bits.
** Passing a u32vector to 'bit-set*!' and 'bit-count*' deprecated
These functions had an interface that allowed the second bit-selection
argument to be a u32vector of bit indices to select. This added only
complexity and no efficiency compared to just calling 'bitvector-set!'
or 'bitvector-ref' in a loop.
** Accessing generic arrays using the bitvector procedures deprecated
*** Accessing generic arrays using the bitvector procedures
For the same efficiency reasons that use of 'vector-ref' on generic
arrays was deprecated in Guile 2.0.10, using 'bitvector-ref' and similar
procedures on 1-dimensional boolean-typed arrays is now deprecated. Use
'array-ref' and similar procedures on arrays.
arrays was deprecated in Guile 2.0.10, using 'bitvector->list' and
similar procedures on 1-dimensional boolean-typed arrays is now
deprecated. Use 'array-ref' and similar procedures on arrays.
** scm_istr2bve deprecated
*** scm_istr2bve
This C-only procedure to parse a bitvector from a string should be
replaced by calling `read' on a string port instead, if needed.

76
am/bootstrap.am
View file

@ -18,7 +18,7 @@
## Fifth Floor, Boston, MA 02110-1301 USA
# These variables can be set before you include bootstrap.am.
GUILE_WARNINGS ?= -Wunbound-variable -Warity-mismatch -Wformat
GUILE_WARNINGS ?= -W1
GUILE_OPTIMIZATIONS ?= -O2
GUILE_TARGET ?= $(host)
GUILE_BUILD_TAG ?= BOOTSTRAP
@ -53,15 +53,12 @@ SUFFIXES = .scm .go
SOURCES = \
ice-9/eval.scm \
ice-9/psyntax-pp.scm \
language/cps/intmap.scm \
language/cps/intset.scm \
language/cps/graphs.scm \
ice-9/vlist.scm \
language/tree-il/compile-bytecode.scm \
ice-9/boot-9.scm \
srfi/srfi-1.scm \
\
language/tree-il.scm \
language/tree-il/analyze.scm \
language/tree-il/compile-bytecode.scm \
language/tree-il/compile-cps.scm \
language/tree-il/cps-primitives.scm \
language/tree-il/debug.scm \
@ -74,36 +71,6 @@ SOURCES = \
language/tree-il/primitives.scm \
language/tree-il/spec.scm \
\
language/cps.scm \
language/cps/closure-conversion.scm \
language/cps/compile-bytecode.scm \
language/cps/contification.scm \
language/cps/cse.scm \
language/cps/dce.scm \
language/cps/devirtualize-integers.scm \
language/cps/effects-analysis.scm \
language/cps/licm.scm \
language/cps/loop-instrumentation.scm \
language/cps/peel-loops.scm \
language/cps/prune-top-level-scopes.scm \
language/cps/reify-primitives.scm \
language/cps/renumber.scm \
language/cps/rotate-loops.scm \
language/cps/optimize.scm \
language/cps/simplify.scm \
language/cps/self-references.scm \
language/cps/slot-allocation.scm \
language/cps/spec.scm \
language/cps/specialize-primcalls.scm \
language/cps/specialize-numbers.scm \
language/cps/split-rec.scm \
language/cps/type-checks.scm \
language/cps/type-fold.scm \
language/cps/types.scm \
language/cps/utils.scm \
language/cps/verify.scm \
language/cps/with-cps.scm \
\
language/scheme/spec.scm \
language/scheme/compile-tree-il.scm \
language/scheme/decompile-tree-il.scm \
@ -125,7 +92,6 @@ SOURCES = \
system/base/types/internal.scm \
system/base/ck.scm \
\
ice-9/boot-9.scm \
ice-9/ports.scm \
ice-9/r5rs.scm \
ice-9/deprecated.scm \
@ -143,6 +109,7 @@ SOURCES = \
ice-9/regex.scm \
ice-9/session.scm \
ice-9/pretty-print.scm \
ice-9/vlist.scm \
\
system/vm/assembler.scm \
system/vm/debug.scm \
@ -154,4 +121,37 @@ SOURCES = \
system/vm/loader.scm \
system/vm/program.scm \
system/vm/vm.scm \
system/foreign.scm
system/foreign.scm \
\
language/cps.scm \
language/cps/closure-conversion.scm \
language/cps/compile-bytecode.scm \
language/cps/contification.scm \
language/cps/cse.scm \
language/cps/dce.scm \
language/cps/devirtualize-integers.scm \
language/cps/effects-analysis.scm \
language/cps/intmap.scm \
language/cps/intset.scm \
language/cps/graphs.scm \
language/cps/licm.scm \
language/cps/loop-instrumentation.scm \
language/cps/peel-loops.scm \
language/cps/prune-top-level-scopes.scm \
language/cps/reify-primitives.scm \
language/cps/renumber.scm \
language/cps/rotate-loops.scm \
language/cps/optimize.scm \
language/cps/simplify.scm \
language/cps/self-references.scm \
language/cps/slot-allocation.scm \
language/cps/spec.scm \
language/cps/specialize-primcalls.scm \
language/cps/specialize-numbers.scm \
language/cps/split-rec.scm \
language/cps/type-checks.scm \
language/cps/type-fold.scm \
language/cps/types.scm \
language/cps/utils.scm \
language/cps/verify.scm \
language/cps/with-cps.scm

7
am/guilec
View file

@ -1,7 +1,8 @@
# -*- makefile -*-
GOBJECTS = $(SOURCES:%.scm=%.go) $(ELISP_SOURCES:%.el=%.go)
GUILE_WARNINGS = -Wunbound-variable -Wmacro-use-before-definition -Warity-mismatch -Wformat
GUILE_WARNINGS ?= -W1
GUILE_OPTIMIZATIONS ?= -O2
moddir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)/$(modpath)
nobase_mod_DATA = $(SOURCES) $(ELISP_SOURCES) $(NOCOMP_SOURCES)
@ -29,7 +30,7 @@ SUFFIXES = .scm .el .go
.scm.go:
$(AM_V_GUILEC)GUILE_AUTO_COMPILE=0 \
$(top_builddir)/meta/build-env \
guild compile --target="$(host)" $(GUILE_WARNINGS) \
guild compile --target="$(host)" $(GUILE_WARNINGS) $(GUILE_OPTIMIZATIONS) \
-L "$(abs_srcdir)" -L "$(abs_builddir)" \
-L "$(abs_top_srcdir)/guile-readline" \
-o "$@" "$<"
@ -37,7 +38,7 @@ SUFFIXES = .scm .el .go
.el.go:
$(AM_V_GUILEC)GUILE_AUTO_COMPILE=0 \
$(top_builddir)/meta/build-env \
guild compile --target="$(host)" $(GUILE_WARNINGS) \
guild compile --target="$(host)" $(GUILE_WARNINGS) $(GUILE_OPTIMIZATIONS) \
-L "$(abs_srcdir)" -L "$(abs_builddir)" \
-L "$(abs_top_srcdir)/guile-readline" \
--from=elisp -o "$@" "$<"

6
bootstrap/Makefile.am
View file

@ -1,7 +1,7 @@
## Process this file with automake to produce Makefile.in.
##
## Copyright (C) 2009, 2010, 2011, 2012, 2013,
## 2014, 2015, 2018 Free Software Foundation, Inc.
## 2014, 2015, 2018, 2020 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
@ -21,13 +21,13 @@
## Fifth Floor, Boston, MA 02110-1301 USA
GUILE_WARNINGS =
GUILE_WARNINGS = -W0
# Loading eval.go happens before boot and therefore before modules are
# resolved. For some reason if compiled without resolve-primitives,
# attempts to resolve primitives at boot fail; weird. Should fix this
# but in the meantime we turn on primitive resolution (which normally
# only happens at -O2).
GUILE_OPTIMIZATIONS = -O1 -Oresolve-primitives
GUILE_OPTIMIZATIONS = -O1 -Oresolve-primitives -Ono-cps
include $(top_srcdir)/am/bootstrap.am

28
doc/ref/api-evaluation.texi
View file

@ -1,7 +1,7 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2009,
@c 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
@c 2010, 2011, 2012, 2013, 2014, 2020 Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@node Read/Load/Eval/Compile
@ -680,7 +680,7 @@ warnings include @code{unused-variable}, @code{unused-toplevel},
@cindex optimizations, compiler
Enable or disable specific compiler optimizations; use @code{-Ohelp} for
a list of available options. The default is @code{-O2}, which enables
most optimizations. @code{-O1} is recommended if compilation speed is
most optimizations. @code{-O0} is recommended if compilation speed is
more important than the speed of the compiled code. Pass
@code{-Ono-@var{opt}} to disable a specific compiler pass. Any number
of @code{-O} options can be passed to the compiler, with later ones
@ -716,12 +716,18 @@ coding declaration as recognized by @code{file-encoding}
(@pxref{Character Encoding of Source Files}).
@end deffn
The compiler can also be invoked directly by Scheme code using the procedures
below:
The compiler can also be invoked directly by Scheme code. These
interfaces are in their own module:
@example
(use-modules (system base compile))
@end example
@deffn {Scheme Procedure} compile exp [#:env=#f] @
[#:from=(current-language)] @
[#:to=value] [#:opts=()]
[#:to=value] [#:opts='()] @
[#:optimization-level=(default-optimization-level)] @
[#:warning-level=(default-warning-level)]
Compile the expression @var{exp} in the environment @var{env}. If
@var{exp} is a procedure, the result will be a compiled procedure;
otherwise @code{compile} is mostly equivalent to @code{eval}.
@ -734,6 +740,8 @@ the Virtual Machine}.
[#:from=(current-language)] [#:to='rtl] @
[#:env=(default-environment from)] @
[#:opts='()] @
[#:optimization-level=(default-optimization-level)] @
[#:warning-level=(default-warning-level)] @
[#:canonicalization='relative]
Compile the file named @var{file}.
@ -749,6 +757,16 @@ As with @command{guild compile}, @var{file} is assumed to be
UTF-8-encoded unless it contains a coding declaration.
@end deffn
@deffn {Scheme Parameter} default-optimization-level
The default optimization level, as an integer from 0 to 9. The default
is 2.
@end deffn
@deffn {Scheme Parameter} default-warning-level
The default warning level, as an integer from 0 to 9. The default is 1.
@end deffn
@xref{Parameters}, for more on how to set parameters.
@deffn {Scheme Procedure} compiled-file-name file
Compute a cached location for a compiled version of a Scheme file named
@var{file}.

28
doc/ref/compiler.texi
View file

@ -52,7 +52,8 @@ They are registered with the @code{define-language} form.
[#:parser=#f] [#:compilers='()] @
[#:decompilers='()] [#:evaluator=#f] @
[#:joiner=#f] [#:for-humans?=#t] @
[#:make-default-environment=make-fresh-user-module]
[#:make-default-environment=make-fresh-user-module] @
[#:lowerer=#f] [#:analyzer=#f] [#:compiler-chooser=#f]
Define a language.
This syntax defines a @code{<language>} object, bound to @var{name} in
@ -96,18 +97,23 @@ The language object will be returned, or @code{#f} if there does not
exist a language with that name.
@end deffn
Defining languages this way allows us to programmatically determine
the necessary steps for compiling code from one language to another.
When Guile goes to compile Scheme to bytecode, it will ask the Scheme
language to choose a compiler from Scheme to the next language on the
path from Scheme to bytecode. Performing this computation recursively
builds transformations from a flexible chain of compilers. The next
link will be obtained by invoking the language's compiler chooser, or if
not present, from the language's compilers field.
@deffn {Scheme Procedure} lookup-compilation-order from to
Recursively traverses the set of languages to which @var{from} can
compile, depth-first, and return the first path that can transform
@var{from} to @var{to}. Returns @code{#f} if no path is found.
A language can specify an analyzer, which is run before a term of that
language is lowered and compiled. This is where compiler warnings are
issued.
This function memoizes its results in a cache that is invalidated by
subsequent calls to @code{define-language}, so it should be quite
fast.
@end deffn
If a language specifies a lowerer, that procedure is called on
expressions before compilation. This is where optimizations and
canonicalizations go.
Finally a language's compiler translates a lowered term from one
language to the next one in the chain.
There is a notion of a ``current language'', which is maintained in the
@code{current-language} parameter, defined in the core @code{(guile)}

3
libguile/fports.c
View file

@ -1,4 +1,4 @@
/* Copyright 1995-2004,2006-2015,2017-2019
/* Copyright 1995-2004,2006-2015,2017-2020
Free Software Foundation, Inc.
This file is part of Guile.
@ -452,6 +452,7 @@ scm_i_fdes_to_port (int fdes, long mode_bits, SCM name, unsigned options)
"file port");
fp->fdes = fdes;
fp->options = options;
fp->revealed = 0;
port = scm_c_make_port (scm_file_port_type, mode_bits, (scm_t_bits)fp);

28
libguile/intrinsics.c
View file

@ -334,7 +334,7 @@ resolve_module (SCM name, uint8_t public_p)
}
static SCM
lookup (SCM module, SCM name)
module_variable (SCM module, SCM name)
{
/* If MODULE was captured before modules were booted, use the root
module. Not so nice, but hey... */
@ -344,6 +344,30 @@ lookup (SCM module, SCM name)
return scm_module_variable (module, name);
}
static SCM
lookup (SCM module, SCM name)
{
SCM var = module_variable (module, name);
if (!SCM_VARIABLEP (var))
scm_error (scm_from_latin1_symbol ("unbound-variable"), NULL,
"Unbound variable: ~S", scm_list_1 (name), SCM_BOOL_F);
return var;
}
static SCM
lookup_bound (SCM module, SCM name)
{
SCM var = lookup (module, name);
if (SCM_UNBNDP (SCM_VARIABLE_REF (var)))
scm_error (scm_from_latin1_symbol ("unbound-variable"), NULL,
"Unbound variable: ~S", scm_list_1 (name), SCM_BOOL_F);
return var;
}
static void throw_ (SCM key, SCM args) SCM_NORETURN;
static void throw_with_value (SCM val, SCM key_subr_and_message) SCM_NORETURN;
static void throw_with_value_and_data (SCM val, SCM key_subr_and_message) SCM_NORETURN;
@ -574,7 +598,9 @@ scm_bootstrap_intrinsics (void)
scm_vm_intrinsics.less_p = less_p;
scm_vm_intrinsics.numerically_equal_p = numerically_equal_p;
scm_vm_intrinsics.resolve_module = resolve_module;
scm_vm_intrinsics.module_variable = module_variable;
scm_vm_intrinsics.lookup = lookup;
scm_vm_intrinsics.lookup_bound = lookup_bound;
scm_vm_intrinsics.define_x = scm_module_ensure_local_variable;
scm_vm_intrinsics.throw_ = throw_;
scm_vm_intrinsics.throw_with_value = throw_with_value;

4
libguile/intrinsics.h
View file

@ -142,7 +142,7 @@ typedef void (*scm_t_scm_uimm_scm_intrinsic) (SCM, uint8_t, SCM);
M(compare_from_scm_scm, less_p, "<?", LESS_P) \
M(bool_from_scm_scm, numerically_equal_p, "=?", NUMERICALLY_EQUAL_P) \
M(scm_from_scm_uimm, resolve_module, "resolve-module", RESOLVE_MODULE) \
M(scm_from_scm_scm, lookup, "lookup", LOOKUP) \
M(scm_from_scm_scm, module_variable, "module-variable", MODULE_VARIABLE) \
M(scm_from_scm_scm, define_x, "define!", DEFINE_X) \
M(thread_sp, expand_stack, "expand-stack", EXPAND_STACK) \
M(scm_from_thread_u32, cons_rest, "cons-rest", CONS_REST) \
@ -212,6 +212,8 @@ typedef void (*scm_t_scm_uimm_scm_intrinsic) (SCM, uint8_t, SCM);
M(scm_scm_scm, struct_set_x, "$struct-set!", STRUCT_SET_X) \
M(scm_from_scm_uimm, struct_ref_immediate, "$struct-ref/immediate", STRUCT_REF_IMMEDIATE) \
M(scm_uimm_scm, struct_set_x_immediate, "$struct-set!/immediate", STRUCT_SET_X_IMMEDIATE) \
M(scm_from_scm_scm, lookup, "lookup", LOOKUP) \
M(scm_from_scm_scm, lookup_bound, "lookup-bound", LOOKUP_BOUND) \
/* Add new intrinsics here; also update scm_bootstrap_intrinsics. */
/* Intrinsics prefixed with $ are meant to reduce bytecode size,

33
libguile/jit.c
View file

@ -261,8 +261,9 @@ static const jit_gpr_t T1_PRESERVED = JIT_V2;
static const uint32_t SP_IN_REGISTER = 0x1;
static const uint32_t FP_IN_REGISTER = 0x2;
static const uint32_t SP_CACHE_GPR = 0x4;
static const uint32_t SP_CACHE_FPR = 0x8;
static const uint32_t UNREACHABLE = 0x4;
static const uint32_t SP_CACHE_GPR = 0x8;
static const uint32_t SP_CACHE_FPR = 0x10;
static const uint8_t OP_ATTR_BLOCK = 0x1;
static const uint8_t OP_ATTR_ENTRY = 0x2;
@ -354,13 +355,20 @@ set_register_state (scm_jit_state *j, uint32_t state)
j->register_state |= state;
}
static uint32_t
unreachable (scm_jit_state *j)
{
return j->register_state & UNREACHABLE;
}
static uint32_t
has_register_state (scm_jit_state *j, uint32_t state)
{
return (j->register_state & state) == state;
}
#define ASSERT_HAS_REGISTER_STATE(state) ASSERT (has_register_state (j, state))
#define ASSERT_HAS_REGISTER_STATE(state) \
ASSERT (unreachable (j) || has_register_state (j, state));
static void
record_gpr_clobber (scm_jit_state *j, jit_gpr_t r)
@ -1622,6 +1630,12 @@ compile_receive_values (scm_jit_state *j, uint32_t proc, uint8_t allow_extra,
{
jit_gpr_t t = T0;
/* Although most uses of receive-values are after a call returns, the
baseline compiler will sometimes emit it elsewhere. In that case
ensure that FP is in a register for the frame-locals-count
branches. */
restore_reloadable_register_state (j, FP_IN_REGISTER);
if (allow_extra)
add_slow_path_patch
(j, emit_branch_if_frame_locals_count_less_than (j, t, proc + nvalues));
@ -1873,6 +1887,7 @@ compile_throw (scm_jit_state *j, uint16_t key, uint16_t args)
emit_call_2 (j, scm_vm_intrinsics.throw_, sp_scm_operand (j, key),
sp_scm_operand (j, args));
/* throw_ does not return. */
set_register_state (j, UNREACHABLE);
}
static void
compile_throw_slow (scm_jit_state *j, uint16_t key, uint16_t args)
@ -1887,7 +1902,8 @@ compile_throw_value (scm_jit_state *j, uint32_t val,
emit_call_2 (j, scm_vm_intrinsics.throw_with_value, sp_scm_operand (j, val),
jit_operand_imm (JIT_OPERAND_ABI_POINTER,
(intptr_t) key_subr_and_message));
/* throw_with_value does not return. */
/* Like throw_, throw_with_value does not return. */
set_register_state (j, UNREACHABLE);
}
static void
compile_throw_value_slow (scm_jit_state *j, uint32_t val,
@ -1904,7 +1920,8 @@ compile_throw_value_and_data (scm_jit_state *j, uint32_t val,
sp_scm_operand (j, val),
jit_operand_imm (JIT_OPERAND_ABI_POINTER,
(intptr_t) key_subr_and_message));
/* throw_with_value_and_data does not return. */
/* Like throw_, throw_with_value_and_data does not return. */
set_register_state (j, UNREACHABLE);
}
static void
compile_throw_value_and_data_slow (scm_jit_state *j, uint32_t val,
@ -2156,6 +2173,12 @@ compile_bind_rest (scm_jit_state *j, uint32_t dst)
jit_reloc_t k, cons;
jit_gpr_t t = T1;
/* As with receive-values, although bind-rest is usually used after a
call returns, the baseline compiler will sometimes emit it
elsewhere. In that case ensure that FP is in a register for the
frame-locals-count branches. */
restore_reloadable_register_state (j, FP_IN_REGISTER);
cons = emit_branch_if_frame_locals_count_greater_than (j, t, dst);
emit_alloc_frame (j, t, dst + 1);

6
module/language/brainfuck/spec.scm
View file

@ -1,6 +1,6 @@
;;; Brainfuck for GNU Guile.
;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;; Copyright (C) 2009-2010,2020 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
@ -34,10 +34,14 @@
; in #:compilers. This is the basic set of fields needed to specify a new
; language.
(define (choose-compiler compilers optimization-level opts)
(cons 'tree-il compile-tree-il))
(define-language brainfuck
#:title "Brainfuck"
#:reader (lambda (port env) (read-brainfuck port))
#:compilers `((tree-il . ,compile-tree-il)
(scheme . ,compile-scheme))
#:compiler-chooser choose-compiler
#:printer write
)

34
module/language/cps/compile-bytecode.scm
View file

@ -29,12 +29,6 @@
#:use-module (language cps)
#:use-module (language cps slot-allocation)
#:use-module (language cps utils)
#:use-module (language cps closure-conversion)
#:use-module (language cps loop-instrumentation)
#:use-module (language cps optimize)
#:use-module (language cps reify-primitives)
#:use-module (language cps renumber)
#:use-module (language cps split-rec)
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:use-module (system vm assembler)
@ -192,8 +186,15 @@
(emit-cache-ref asm (from-sp dst) key))
(($ $primcall 'resolve-module public? (name))
(emit-resolve-module asm (from-sp dst) (from-sp (slot name)) public?))
(($ $primcall 'module-variable #f (mod name))
(emit-module-variable asm (from-sp dst) (from-sp (slot mod))
(from-sp (slot name))))
(($ $primcall 'lookup #f (mod name))
(emit-lookup asm (from-sp dst) (from-sp (slot mod)) (from-sp (slot name))))
(emit-lookup asm (from-sp dst) (from-sp (slot mod))
(from-sp (slot name))))
(($ $primcall 'lookup-bound #f (mod name))
(emit-lookup-bound asm (from-sp dst) (from-sp (slot mod))
(from-sp (slot name))))
(($ $primcall 'add/immediate y (x))
(emit-add/immediate asm (from-sp dst) (from-sp (slot x)) y))
(($ $primcall 'sub/immediate y (x))
@ -680,7 +681,7 @@
(intmap-for-each compile-cont cps)))
(define (emit-bytecode exp env opts)
(define (compile-bytecode exp env opts)
(let ((asm (make-assembler)))
(intmap-for-each (lambda (kfun body)
(compile-function (intmap-select exp body) asm opts))
@ -688,20 +689,3 @@
(values (link-assembly asm #:page-aligned? (kw-arg-ref opts #:to-file? #f))
env
env)))
(define (lower-cps exp opts)
;; FIXME: For now the closure conversion pass relies on $rec instances
;; being separated into SCCs. We should fix this to not be the case,
;; and instead move the split-rec pass back to
;; optimize-higher-order-cps.
(set! exp (split-rec exp))
(set! exp (optimize-higher-order-cps exp opts))
(set! exp (convert-closures exp))
(set! exp (optimize-first-order-cps exp opts))
(set! exp (reify-primitives exp))
(set! exp (add-loop-instrumentation exp))
(renumber exp))
(define (compile-bytecode exp env opts)
(set! exp (lower-cps exp opts))
(emit-bytecode exp env opts))

4
module/language/cps/effects-analysis.scm
View file

@ -1,6 +1,6 @@
;;; Effects analysis on CPS
;; Copyright (C) 2011-2015,2017-2019 Free Software Foundation, Inc.
;; Copyright (C) 2011-2015,2017-2020 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
@ -485,7 +485,9 @@ the LABELS that are clobbered by the effects of LABEL."
((cache-current-module! m) (&write-object &cache))
((resolve name) (&read-object &module) &type-check)
((resolve-module mod) (&read-object &module) &type-check)
((module-variable mod name) (&read-object &module) &type-check)
((lookup mod name) (&read-object &module) &type-check)
((lookup-bound mod name) (&read-object &module) &type-check)
((cached-toplevel-box) &type-check)
((cached-module-box) &type-check)
((define! mod name) (&read-object &module)))

81
module/language/cps/optimize.scm
View file

@ -1,20 +1,19 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
;; Copyright (C) 2013-2018,2020 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
;;; 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 program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;;
@ -24,23 +23,30 @@
(define-module (language cps optimize)
#:use-module (ice-9 match)
#:use-module (language cps closure-conversion)
#:use-module (language cps contification)
#:use-module (language cps cse)
#:use-module (language cps devirtualize-integers)
#:use-module (language cps dce)
#:use-module (language cps devirtualize-integers)
#:use-module (language cps licm)
#:use-module (language cps loop-instrumentation)
#:use-module (language cps peel-loops)
#:use-module (language cps prune-top-level-scopes)
#:use-module (language cps reify-primitives)
#:use-module (language cps renumber)
#:use-module (language cps rotate-loops)
#:use-module (language cps self-references)
#:use-module (language cps simplify)
#:use-module (language cps specialize-primcalls)
#:use-module (language cps specialize-numbers)
#:use-module (language cps specialize-primcalls)
#:use-module (language cps split-rec)
#:use-module (language cps type-fold)
#:use-module (language cps verify)
#:use-module (system base optimize)
#:export (optimize-higher-order-cps
optimize-first-order-cps
cps-optimizations))
cps-optimizations
make-cps-lowerer))
(define (kw-arg-ref args kw default)
(match (memq kw args)
@ -112,19 +118,28 @@
(simplify #:simplify? #t))
(define (cps-optimizations)
'( ;; (#:split-rec? #t)
(#:simplify? 2)
(#:eliminate-dead-code? 2)
(#:prune-top-level-scopes? 2)
(#:contify? 2)
(#:specialize-primcalls? 2)
(#:peel-loops? 2)
(#:cse? 2)
(#:type-fold? 2)
(#:resolve-self-references? 2)
(#:devirtualize-integers? 2)
(#:specialize-numbers? 2)
(#:licm? 2)
(#:rotate-loops? 2)
;; This one is used by the slot allocator.
(#:precolor-calls? 2)))
(available-optimizations 'cps))
(define (lower-cps exp opts)
;; FIXME: For now the closure conversion pass relies on $rec instances
;; being separated into SCCs. We should fix this to not be the case,
;; and instead move the split-rec pass back to
;; optimize-higher-order-cps.
(set! exp (split-rec exp))
(set! exp (optimize-higher-order-cps exp opts))
(set! exp (convert-closures exp))
(set! exp (optimize-first-order-cps exp opts))
(set! exp (reify-primitives exp))
(set! exp (add-loop-instrumentation exp))
(renumber exp))
(define (make-cps-lowerer optimization-level opts)
(define (enabled-for-level? level) (<= level optimization-level))
(let ((opts (let lp ((all-opts (cps-optimizations)))
(match all-opts
(() '())
(((kw level) . all-opts)
(acons kw (kw-arg-ref opts kw (enabled-for-level? level))
(lp all-opts)))))))
(lambda (exp env)
(lower-cps exp opts))))

35
module/language/cps/reify-primitives.scm
View file

@ -201,34 +201,14 @@
(wrap-unary cps k src 's64->u64 'u64->s64 'ulsh/immediate param a))
(define (reify-lookup cps src mod-var name assert-bound? have-var)
(define (%lookup cps kbad k src mod-var name-var var assert-bound?)
(if assert-bound?
(with-cps cps
(letv val)
(letk kcheck
($kargs ('val) (val)
($branch k kbad src 'undefined? #f (val))))
(letk kref
($kargs () ()
($continue kcheck src
($primcall 'scm-ref/immediate '(box . 1) (var)))))
($ (%lookup kbad kref src mod-var name-var var #f)))
(with-cps cps
(letk kres
($kargs ('var) (var)
($branch kbad k src 'heap-object? #f (var))))
(build-term
($continue kres src
($primcall 'lookup #f (mod-var name-var)))))))
(define %unbound
#(unbound-variable #f "Unbound variable: ~S"))
(with-cps cps
(letv name-var var)
(let$ good (have-var var))
(letk kgood ($kargs () () ,good))
(letk kbad ($kargs () () ($throw src 'throw/value %unbound (name-var))))
(let$ body (%lookup kbad kgood src mod-var name-var var assert-bound?))
(letk klookup ($kargs ('name) (name-var) ,body))
(let$ body (have-var var))
(letk kres ($kargs ('var) (var) ,body))
(letk klookup ($kargs ('name) (name-var)
($continue kres src
($primcall (if assert-bound? 'lookup-bound 'lookup) #f
(mod-var name-var)))))
(build-term ($continue klookup src ($const name)))))
(define (reify-resolve-module cps k src module public?)
@ -354,7 +334,8 @@
push-dynamic-state pop-dynamic-state
lsh rsh lsh/immediate rsh/immediate
cache-ref cache-set!
resolve-module lookup define! current-module))
current-module resolve-module
module-variable lookup lookup-bound define!))
(let ((table (make-hash-table)))
(for-each
(match-lambda ((inst . _) (hashq-set! table inst #t)))

3
module/language/cps/spec.scm
View file

@ -23,6 +23,7 @@
#:use-module (system base language)
#:use-module (language cps)
#:use-module (language cps intmap)
#:use-module (language cps optimize)
#:use-module (language cps compile-bytecode)
#:export (cps))
@ -48,4 +49,4 @@
#:printer write-cps
#:compilers `((bytecode . ,compile-bytecode))
#:for-humans? #f
)
#:lowerer make-cps-lowerer)

25
module/language/tree-il/analyze.scm
View file

@ -1,6 +1,6 @@
;;; TREE-IL -> GLIL compiler
;; Copyright (C) 2001,2008-2014,2016,2018-2019 Free Software Foundation, Inc.
;; Copyright (C) 2001,2008-2014,2016,2018-2020 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
@ -37,7 +37,8 @@
unbound-variable-analysis
macro-use-before-definition-analysis
arity-analysis
format-analysis))
format-analysis
make-analyzer))
;;;
;;; Tree analyses for warnings.
@ -1086,3 +1087,23 @@ resort, return #t when EXP refers to the global variable SPECIAL-NAME."
#t)
#t))
(define %warning-passes
`(#(unused-variable 3 ,unused-variable-analysis)
#(unused-toplevel 2 ,unused-toplevel-analysis)
#(shadowed-toplevel 2 ,shadowed-toplevel-analysis)
#(unbound-variable 1 ,unbound-variable-analysis)
#(macro-use-before-definition 1 ,macro-use-before-definition-analysis)
#(arity-mismatch 1 ,arity-analysis)
#(format 1 ,format-analysis)))
(define (make-analyzer warning-level warnings)
(define (enabled-for-level? level) (<= level warning-level))
(let ((analyses (filter-map (match-lambda
(#(kind level analysis)
(and (or (enabled-for-level? level)
(memq kind warnings))
analysis)))
%warning-passes)))
(lambda (exp env)
(analyze-tree analyses exp env))))

248
module/language/tree-il/compile-bytecode.scm
View file

@ -2,19 +2,18 @@
;; Copyright (C) 2020 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
;;; 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 program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;;
@ -26,27 +25,13 @@
;;;
;;; Code:
;; FIXME: Add handle-interrupts, instrument-entry, and instrument-loop.
;; FIXME: Verify that all SCM values on the stack will be marked.
;; FIXME: Verify that the stack marker will never misinterpret an
;; unboxed temporary (u64 or otherwise) as a SCM.
;; FIXME: Verify that the debugger will never misinterpret an unboxed
;; temporary as a SCM.
;; FIXME: Add debugging source-location info.
(define-module (language tree-il compile-bytecode)
#:use-module (ice-9 match)
#:use-module (language bytecode)
#:use-module (language tree-il)
#:use-module (language tree-il analyze)
#:use-module (language tree-il optimize)
#:use-module ((srfi srfi-1) #:select (filter-map
fold
lset-union lset-difference))
lset-adjoin lset-union lset-difference))
#:use-module (srfi srfi-9)
#:use-module (system base types internal)
#:use-module (system vm assembler)
@ -68,12 +53,14 @@
(emit-word-set!/immediate asm dst 0 tmp)
(emit-word-set!/immediate asm dst 1 src)))))
(define (emit-box-set! asm loc val)
(emit-word-set!/immediate asm loc 1 val))
(emit-scm-set!/immediate asm loc 1 val))
(define (emit-box-ref asm dst loc)
(emit-scm-ref/immediate asm dst loc 1))
(define (emit-cons asm dst car cdr)
(cond
((= car dst)
(emit-mov asm 1 car)
(emit-cons asm dst 1 (if (= cdr dst) 1 dst)))
(emit-cons asm dst 1 (if (= cdr dst) 1 cdr)))
((= cdr dst)
(emit-mov asm 1 cdr)
(emit-cons asm dst car 1))
@ -82,7 +69,7 @@
(emit-scm-set!/immediate asm dst 0 car)
(emit-scm-set!/immediate asm dst 1 cdr))))
(define (emit-cached-module-box asm dst mod name public? tmp)
(define (emit-cached-module-box asm dst mod name public? bound? tmp)
(define key (cons mod name))
(define cached (gensym "cached"))
(emit-cache-ref asm dst key)
@ -91,10 +78,12 @@
(emit-load-constant asm dst mod)
(emit-resolve-module asm dst dst public?)
(emit-load-constant asm tmp name)
(emit-lookup asm dst dst tmp)
(if bound?
(emit-lookup-bound asm dst dst tmp)
(emit-lookup asm dst dst tmp))
(emit-cache-set! asm key dst)
(emit-label asm cached))
(define (emit-cached-toplevel-box asm dst scope name tmp)
(define (emit-cached-toplevel-box asm dst scope name bound? tmp)
(define key (cons scope name))
(define cached (gensym "cached"))
(emit-cache-ref asm dst key)
@ -102,13 +91,17 @@
(emit-je asm cached)
(emit-cache-ref asm dst scope)
(emit-load-constant asm tmp name)
(emit-lookup asm dst dst tmp)
(if bound?
(emit-lookup-bound asm dst dst tmp)
(emit-lookup asm dst dst tmp))
(emit-cache-set! asm key dst)
(emit-label asm cached))
(define (emit-toplevel-box asm dst name tmp)
(define (emit-toplevel-box asm dst name bound? tmp)
(emit-current-module asm dst)
(emit-load-constant asm tmp name)
(emit-lookup asm dst dst tmp))
(if bound?
(emit-lookup-bound asm dst dst tmp)
(emit-lookup asm dst dst tmp)))
(define closure-header-words 2)
(define (emit-allocate-closure asm dst nfree label tmp)
@ -261,6 +254,7 @@
(push-dynamic-state #:nargs 1 #:emit emit-push-dynamic-state)
(pop-dynamic-state #:nargs 0 #:emit emit-pop-dynamic-state)
(push-fluid #:nargs 2 #:emit emit-push-fluid)
(pop-fluid #:nargs 0 #:emit emit-pop-fluid)
(pop-fluid-state #:nargs 0 #:emit emit-pop-dynamic-state)
(fluid-ref #:nargs 1 #:has-result? #t #:emit emit-fluid-ref)
(fluid-set! #:nargs 2 #:emit emit-fluid-set!)
@ -304,7 +298,7 @@
(emit-jne asm kf)))
(< #:nargs 2 #:predicate? #t #:emit (lambda (asm a b kf)
(emit-<? asm a b)
(emit-jl asm kf)))
(emit-jnl asm kf)))
(<= #:nargs 2 #:predicate? #t #:emit (lambda (asm a b kf)
(emit-<? asm b a)
(emit-jnge asm kf)))
@ -511,7 +505,7 @@
;; expressions. (Escape-only prompt bodies are already
;; expressions.)
(($ <prompt> src #f tag body handler)
(make-prompt src tag #f (make-call src body '()) handler))
(make-prompt src #f tag (make-call src body '()) handler))
(_ exp)))
exp))
@ -544,6 +538,7 @@
;; lambdas are seen, and adding set! vars to `assigned'.
(define (visit-closure exp module-scope)
(define (visit exp)
(define (adjoin sym f) (lset-adjoin eq? f sym))
(define (union f1 f2) (lset-union eq? f1 f2))
(define (union3 f1 f2 f3) (union f1 (union f2 f3)))
(define (difference f1 f2) (lset-difference eq? f1 f2))
@ -600,7 +595,7 @@
(($ <lexical-set> src name gensym exp)
(hashq-set! assigned gensym #t)
(visit exp))
(adjoin gensym (visit exp)))
(($ <seq> src head tail)
(union (visit head) (visit tail)))
@ -747,26 +742,21 @@ in the frame with for the lambda-case clause @var{clause}."
(lookup-lexical sym prev)))
(_ (error "sym not found!" sym))))
(define (frame-base env)
(match env
(($ <env> _ 'frame-base #f)
env)
(($ <env> prev)
(frame-base prev))))
(define (compile-body clause module-scope free-vars frame-size)
(define (push-free-var sym idx env)
(make-env env sym sym idx #t (assigned? sym) #f))
(define frame-base
(make-env #f 'frame-base #f #f #f #f (- frame-size 1)))
(define (push-closure env)
(push-local 'closure #f
(make-env env 'frame-base #f #f #f #f (- frame-size 1))))
(define (push-free-var sym idx env)
(make-env env sym sym idx #t (assigned? sym) (env-next-local env)))
(define (push-local name sym env)
(let ((idx (env-next-local env)))
(emit-definition asm name (- frame-size idx 1) 'scm)
(make-env env name sym idx #f (assigned? sym) (1- idx))))
(define (push-closure env)
(push-local 'closure #f env))
(define (push-local-alias name sym idx env)
(make-env env name sym idx #f #f (env-next-local env)))
@ -788,7 +778,7 @@ in the frame with for the lambda-case clause @var{clause}."
((sym . free)
(lp (1+ idx) free
(push-free-var sym idx env))))))
(fold push-local (push-closure (push-free-vars #f)) names syms))
(fold push-local (push-closure (push-free-vars frame-base)) names syms))
(define (stack-height env)
(- frame-size (env-next-local env) 1))
@ -798,6 +788,9 @@ in the frame with for the lambda-case clause @var{clause}."
(emit-current-module asm 0)
(emit-cache-set! asm scope 0)))
(define (maybe-emit-source source)
(when source (emit-source asm source)))
(define (init-free-vars dst free-vars env tmp0 tmp1)
(let lp ((free-idx 0) (free-vars free-vars))
(unless (null? free-vars)
@ -822,6 +815,7 @@ in the frame with for the lambda-case clause @var{clause}."
env names syms))
(let ((proc-slot (stack-height env))
(nreq (length req)))
(maybe-emit-source src)
(unless (and rest (zero? nreq))
(emit-receive-values asm proc-slot (->bool rest) nreq))
(when rest
@ -835,6 +829,7 @@ in the frame with for the lambda-case clause @var{clause}."
(($ <prompt> src escape-only? tag body
($ <lambda> hsrc hmeta
($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f)))
(maybe-emit-source src)
(let ((tag (env-idx (for-value tag env)))
(proc-slot (stack-height env))
(khandler (gensym "handler"))
@ -845,8 +840,9 @@ in the frame with for the lambda-case clause @var{clause}."
('tail
;; Would be nice if we could invoke the body in true tail
;; context, but that's not how it currently is.
(for-values body env)
(for-values-at body env frame-base)
(emit-unwind asm)
(emit-handle-interrupts asm)
(emit-return-values asm))
(_
(for-context body env ctx)
@ -862,10 +858,12 @@ in the frame with for the lambda-case clause @var{clause}."
(match exp
(($ <conditional> src ($ <primcall> tsrc name args)
consequent alternate)
(maybe-emit-source tsrc)
(let ((emit (primitive-emitter (lookup-primitive name)))
(args (for-args args env))
(kf (gensym "false"))
(kdone (gensym "done")))
(maybe-emit-source src)
(match args
((a) (emit asm a kf))
((a b) (emit asm a b kf)))
@ -879,6 +877,7 @@ in the frame with for the lambda-case clause @var{clause}."
(define (visit-seq exp env ctx)
(match exp
(($ <seq> src head tail)
(maybe-emit-source src)
(for-effect head env)
(for-context tail env ctx))))
@ -893,6 +892,7 @@ in the frame with for the lambda-case clause @var{clause}."
env names syms vals))
(match exp
(($ <let> src names syms vals body)
(maybe-emit-source src)
(for-context body (push-bindings names syms vals env) ctx))))
(define (visit-fix exp env ctx)
@ -903,6 +903,8 @@ in the frame with for the lambda-case clause @var{clause}."
(let ((env (push-local name sym env)))
(match closure
(($ <closure> label code scope free-vars)
;; FIXME: Allocate one scope per fix.
(maybe-cache-module! scope 0)
(emit-maybe-allocate-closure
asm (env-idx env) (length free-vars) label 0)
env))))
@ -917,12 +919,14 @@ in the frame with for the lambda-case clause @var{clause}."
env))
(match exp
(($ <fix> src names syms vals body)
(maybe-emit-source src)
(for-context body (push-bindings names syms vals env) ctx))))
(define (visit-let-values exp env ctx)
(match exp
(($ <let-values> src exp
($ <lambda-case> lsrc req #f rest #f () syms body #f))
(maybe-emit-source src)
(for-values exp env)
(visit-values-handler lsrc req rest syms body env ctx))))
@ -954,36 +958,42 @@ in the frame with for the lambda-case clause @var{clause}."
(($ <lexical-set> src name sym exp)
(let ((env (for-value exp env)))
(maybe-emit-source src)
(match (lookup-lexical sym env)
(($ <env> _ _ _ idx #t #t) ;; Boxed closure.
(emit-load-free-variable asm 0 (1- frame-size) idx 0)
(emit-$variable-set! asm 0 (env-idx env)))
(emit-box-set! asm 0 (env-idx env)))
(($ <env> _ _ _ idx #f #t) ;; Boxed local.
(emit-$variable-set! asm idx (env-idx env))))))
(emit-box-set! asm idx (env-idx env))))))
(($ <module-set> src mod name public? exp)
(let ((env (for-value exp env)))
(emit-cached-module-box asm 0 mod name public? 1)
(emit-$variable-set! asm 0 (env-idx env))))
(maybe-emit-source src)
(emit-cached-module-box asm 0 mod name public? #f 1)
(emit-box-set! asm 0 (env-idx env))))
(($ <toplevel-set> src mod name exp)
(let ((env (for-value exp env)))
(maybe-emit-source src)
(if module-scope
(emit-cached-toplevel-box asm 0 module-scope name 1)
(emit-toplevel-box asm 0 name 1))
(emit-$variable-set! asm 0 (env-idx env))))
(emit-cached-toplevel-box asm 0 module-scope name #f 1)
(emit-toplevel-box asm 0 name #f 1))
(emit-box-set! asm 0 (env-idx env))))
(($ <toplevel-define> src mod name exp)
(let ((env (for-value exp env)))
(maybe-emit-source src)
(emit-current-module asm 0)
(emit-load-constant asm 1 name)
(emit-define! asm 0 0 1)
(emit-$variable-set! asm 0 (env-idx env))))
(emit-box-set! asm 0 (env-idx env))))
(($ <call> src proc args)
(let ((proc-slot (let ((env (push-frame env)))
(fold for-push (for-push proc env) args)
(stack-height env))))
(maybe-emit-source src)
(emit-handle-interrupts asm)
(emit-call asm proc-slot (1+ (length args)))
(emit-reset-frame asm frame-size)))
@ -1000,23 +1010,27 @@ in the frame with for the lambda-case clause @var{clause}."
((a ($ <const> _ (? emit/immediate? b)))
(let ((emit (primitive-emitter/immediate prim)))
(match (for-args (list a) env)
((a) (emit asm a b)))))
((a)
(maybe-emit-source src)
(emit asm a b)))))
((a ($ <const> _ (? emit/immediate? b)) c)
(let ((emit (primitive-emitter/immediate prim)))
(match (for-args (list a c) env)
((a c) (emit asm a b c)))))
((a c)
(maybe-emit-source src)
(emit asm a b c)))))
(_
(let ((emit (primitive-emitter prim)))
(apply emit asm (for-args args env)))))))))
(let ((emit (primitive-emitter prim))
(args (for-args args env)))
(maybe-emit-source src)
(apply emit asm args))))))))
(($ <prompt>) (visit-prompt exp env 'effect))
(($ <conditional>) (visit-conditional exp env 'effect))
(($ <seq>) (visit-seq exp env 'effect))
(($ <let>) (visit-let exp env 'effect))
(($ <fix>) (visit-fix exp env 'effect))
(($ <let-values>) (visit-let-values exp env 'effect)))
(values))
(($ <let-values>) (visit-let-values exp env 'effect))))
(define (for-value-at exp env base)
;; The baseline compiler follows a stack discipline: compiling
@ -1065,31 +1079,36 @@ in the frame with for the lambda-case clause @var{clause}."
(define dst (env-idx dst-env))
(match exp
(($ <lexical-ref> src name sym)
(maybe-emit-source src)
(match (lookup-lexical sym env)
(($ <env> _ _ _ idx #t #t)
(emit-load-free-variable asm dst (1- frame-size) idx 0)
(emit-$variable-ref asm dst dst))
(emit-box-ref asm dst dst))
(($ <env> _ _ _ idx #t #f)
(emit-load-free-variable asm dst (1- frame-size) idx 0))
(($ <env> _ _ _ idx #f #t)
(emit-$variable-ref asm dst idx))
(emit-box-ref asm dst idx))
(($ <env> _ _ _ idx #f #f)
(emit-mov asm dst idx))))
(($ <const> src val)
(maybe-emit-source src)
(emit-load-constant asm dst val))
(($ <module-ref> src mod name public?)
(emit-cached-module-box asm 0 mod name public? 1)
(emit-$variable-ref asm dst 0))
(maybe-emit-source src)
(emit-cached-module-box asm 0 mod name public? #t 1)
(emit-box-ref asm dst 0))
(($ <toplevel-ref> src mod name)
(maybe-emit-source src)
(if module-scope
(emit-cached-toplevel-box asm 0 module-scope name 1)
(emit-toplevel-box asm 0 name 1))
(emit-$variable-ref asm dst 0))
(emit-cached-toplevel-box asm 0 module-scope name #t 1)
(emit-toplevel-box asm 0 name #t 1))
(emit-box-ref asm dst 0))
(($ <lambda> src)
(maybe-emit-source src)
(match (lookup-closure exp)
(($ <closure> label code scope free-vars)
(maybe-cache-module! scope 0)
@ -1114,12 +1133,15 @@ in the frame with for the lambda-case clause @var{clause}."
(let ((proc-slot (let ((env (push-frame env)))
(fold for-push (for-push proc env) args)
(stack-height env))))
(emit-call asm proc-slot (length args))
(emit-receive src dst proc-slot frame-size)))
(maybe-emit-source src)
(emit-handle-interrupts asm)
(emit-call asm proc-slot (1+ (length args)))
(emit-receive asm (stack-height base) proc-slot frame-size)))
(($ <primcall> src (? variadic-constructor? name) args)
;; Stage result in 0 to avoid stompling args.
(let ((args (for-args args env)))
(maybe-emit-source src)
(match name
('list
(emit-load-constant asm 0 '())
@ -1136,12 +1158,14 @@ in the frame with for the lambda-case clause @var{clause}."
('make-struct/simple
(match args
((vtable . args)
(let ((len (length args)))
(emit-$allocate-struct asm 0 vtable len)
(let lp ((i 0) (args args))
(when (< i len)
(emit-struct-init! asm 0 i (car args) 1)
(lp (1+ i) (cdr args)))))))))
(emit-load-constant asm 0 (length args))
(emit-$allocate-struct asm 0 vtable 0)
(let lp ((i 0) (args args))
(match args
(() #t)
((arg . args)
(emit-struct-init! asm 0 i arg 1)
(lp (1+ i) args))))))))
(emit-mov asm dst 0)))
(($ <primcall> src name args)
@ -1157,22 +1181,25 @@ in the frame with for the lambda-case clause @var{clause}."
(match args
((($ <const> _ (? emit/immediate? a)))
(let* ((emit (primitive-emitter/immediate prim)))
(maybe-emit-source src)
(emit asm dst a)))
((a ($ <const> _ (? emit/immediate? b)))
(let* ((emit (primitive-emitter/immediate prim))
(a (for-value a env)))
(maybe-emit-source src)
(emit asm dst (env-idx a) b)))
(_
(let ((emit (primitive-emitter prim)))
(apply emit asm dst (for-args args env)))))))))
(let ((emit (primitive-emitter prim))
(args (for-args args env)))
(maybe-emit-source src)
(apply emit asm dst args))))))))
(($ <prompt>) (visit-prompt exp env `(value-at . ,base)))
(($ <conditional>) (visit-conditional exp env `(value-at. ,base)))
(($ <conditional>) (visit-conditional exp env `(value-at . ,base)))
(($ <seq>) (visit-seq exp env `(value-at . ,base)))
(($ <let>) (visit-let exp env `(value-at . ,base)))
(($ <fix>) (visit-fix exp env `(value-at . ,base)))
(($ <let-values>) (visit-let-values exp env `(value-at . ,base))))
dst-env)
(($ <let-values>) (visit-let-values exp env `(value-at . ,base)))))
(define (for-value exp env)
(match (and (lexical-ref? exp)
@ -1183,7 +1210,8 @@ in the frame with for the lambda-case clause @var{clause}."
(for-push exp env))))
(define (for-push exp env)
(for-value-at exp env env))
(for-value-at exp env env)
(push-temp env))
(define (for-init sym init env)
(match (lookup-lexical sym env)
@ -1217,6 +1245,8 @@ in the frame with for the lambda-case clause @var{clause}."
(env (push-frame env))
(from (stack-height env)))
(fold for-push (for-push proc env) args)
(maybe-emit-source src)
(emit-handle-interrupts asm)
(emit-call asm from (1+ (length args)))
(unless (= from to)
(emit-shuffle-down asm from to))))
@ -1226,9 +1256,7 @@ in the frame with for the lambda-case clause @var{clause}."
(($ <seq>) (visit-seq exp env `(values-at . ,base)))
(($ <let>) (visit-let exp env `(values-at . ,base)))
(($ <fix>) (visit-fix exp env `(values-at . ,base)))
(($ <let-values>) (visit-let-values exp env `(values-at . ,base))))
(values))
(($ <let-values>) (visit-let-values exp env `(values-at . ,base)))))
(define (for-values exp env)
(for-values-at exp env env))
@ -1245,17 +1273,20 @@ in the frame with for the lambda-case clause @var{clause}."
($ <module-set>)
($ <lambda>)
($ <primcall>))
(for-values-at exp env (frame-base env))
(for-values-at exp env frame-base)
(emit-handle-interrupts asm)
(emit-return-values asm))
(($ <call> src proc args)
(let* ((base (stack-height env))
(env (fold for-push (for-push proc env) args)))
(maybe-emit-source src)
(let lp ((i (length args)) (env env))
(when (<= 0 i)
(lp (1- i) (env-prev env))
(emit-mov asm (+ (env-idx env) base) (env-idx env))))
(emit-reset-frame asm (+ 1 (length args)))
(emit-handle-interrupts asm)
(emit-tail-call asm)))
(($ <prompt>) (visit-prompt exp env 'tail))
@ -1263,9 +1294,7 @@ in the frame with for the lambda-case clause @var{clause}."
(($ <seq>) (visit-seq exp env 'tail))
(($ <let>) (visit-let exp env 'tail))
(($ <fix>) (visit-fix exp env 'tail))
(($ <let-values>) (visit-let-values exp env 'tail)))
(values))
(($ <let-values>) (visit-let-values exp env 'tail))))
(match clause
(($ <lambda-case> src req opt rest kw inits syms body alt)
@ -1281,6 +1310,7 @@ in the frame with for the lambda-case clause @var{clause}."
(list-tail inits (if opt (length opt) 0)))))
(unless (= (length names) (length syms) (length inits))
(error "unexpected args" names syms inits))
(maybe-emit-source src)
(let ((env (create-initial-env names syms free-vars)))
(for-each (lambda (sym init) (for-init sym init env)) syms inits)
(for-tail body env))))))
@ -1298,7 +1328,7 @@ in the frame with for the lambda-case clause @var{clause}."
(values aok?
(map (match-lambda
((key name sym)
(cons key (list-index syms sym))))
(cons key (1+ (list-index syms sym)))))
kw)))))
(lambda (allow-other-keys? kw-indices)
(when label (emit-label asm label))
@ -1316,35 +1346,13 @@ in the frame with for the lambda-case clause @var{clause}."
(emit-clause #f body module-scope free)
(emit-end-program asm))))
(define %warning-passes
`((unused-variable . ,unused-variable-analysis)
(unused-toplevel . ,unused-toplevel-analysis)
(shadowed-toplevel . ,shadowed-toplevel-analysis)
(unbound-variable . ,unbound-variable-analysis)
(macro-use-before-definition . ,macro-use-before-definition-analysis)
(arity-mismatch . ,arity-analysis)
(format . ,format-analysis)))
(define (optimize-tree-il x e opts)
(define warnings
(or (and=> (memq #:warnings opts) cadr)
'()))
;; Go through the warning passes.
(let ((analyses (filter-map (lambda (kind)
(assoc-ref %warning-passes kind))
warnings)))
(analyze-tree analyses x e))
(optimize x e opts))
(define (kw-arg-ref args kw default)
(match (memq kw args)
((_ val . _) val)
(_ default)))
(define (compile-bytecode exp env opts)
(let* ((exp (canonicalize (optimize-tree-il exp env opts)))
(let* ((exp (canonicalize exp))
(asm (make-assembler)))
(call-with-values (lambda () (split-closures exp))
(lambda (closures assigned)

57
module/language/tree-il/compile-cps.scm
View file

@ -60,8 +60,6 @@
#:use-module (language cps utils)
#:use-module (language cps with-cps)
#:use-module (language tree-il cps-primitives)
#:use-module (language tree-il analyze)
#:use-module (language tree-il optimize)
#:use-module (language tree-il)
#:use-module (language cps intmap)
#:export (compile-cps))
@ -1403,36 +1401,16 @@
scope-id))
(define (toplevel-box cps src name bound? have-var)
(define %unbound
#(unbound-variable #f "Unbound variable: ~S"))
(match (current-topbox-scope)
(#f
(with-cps cps
(letv mod name-var box)
(letk kbad ($kargs () () ($throw src 'throw/value %unbound (name-var))))
(let$ body
((if bound?
(lambda (cps)
(with-cps cps
(letv val)
(let$ body (have-var box))
(letk kdef ($kargs () () ,body))
(letk ktest ($kargs ('val) (val)
($branch kdef kbad src
'undefined? #f (val))))
(build-term
($continue ktest src
($primcall 'scm-ref/immediate
'(box . 1) (box))))))
(lambda (cps)
(with-cps cps
($ (have-var box)))))))
(letk ktest ($kargs () () ,body))
(letk kbox ($kargs ('box) (box)
($branch kbad ktest src 'heap-object? #f (box))))
(let$ body (have-var box))
(letk kbox ($kargs ('box) (box) ,body))
(letk kname ($kargs ('name) (name-var)
($continue kbox src
($primcall 'lookup #f (mod name-var)))))
($primcall (if bound? 'lookup-bound 'lookup) #f
(mod name-var)))))
(letk kmod ($kargs ('mod) (mod)
($continue kname src ($const name))))
(build-term
@ -2324,28 +2302,6 @@ integer."
(define *comp-module* (make-fluid))
(define %warning-passes
`((unused-variable . ,unused-variable-analysis)
(unused-toplevel . ,unused-toplevel-analysis)
(shadowed-toplevel . ,shadowed-toplevel-analysis)
(unbound-variable . ,unbound-variable-analysis)
(macro-use-before-definition . ,macro-use-before-definition-analysis)
(arity-mismatch . ,arity-analysis)
(format . ,format-analysis)))
(define (optimize-tree-il x e opts)
(define warnings
(or (and=> (memq #:warnings opts) cadr)
'()))
;; Go through the warning passes.
(let ((analyses (filter-map (lambda (kind)
(assoc-ref %warning-passes kind))
warnings)))
(analyze-tree analyses x e))
(optimize x e opts))
(define (canonicalize exp)
(define-syntax-rule (with-lexical src id . body)
(let ((k (lambda (id) . body)))
@ -2560,10 +2516,7 @@ integer."
exp))
(define (compile-cps exp env opts)
(values (cps-convert/thunk
(canonicalize (optimize-tree-il exp env opts)))
env
env))
(values (cps-convert/thunk (canonicalize exp)) env env))
;;; Local Variables:
;;; eval: (put 'convert-arg 'scheme-indent-function 2)

28
module/language/tree-il/optimize.scm
View file

@ -27,7 +27,9 @@
#:use-module (language tree-il peval)
#:use-module (language tree-il primitives)
#:use-module (ice-9 match)
#:use-module (system base optimize)
#:export (optimize
make-lowerer
tree-il-optimizations))
(define (kw-arg-ref args kw default)
@ -61,17 +63,15 @@
x)
(define (tree-il-optimizations)
;; Avoid resolve-primitives until -O2, when CPS optimizations kick in.
;; Otherwise, inlining the primcalls during Tree-IL->CPS compilation
;; will result in a lot of code that will never get optimized nicely.
;; Similarly letrectification is great for generated code quality, but
;; as it gives the compiler more to work with, it increases compile
;; time enough that we reserve it for -O2. Also, this makes -O1 avoid
;; assumptions about top-level values, in the same way that avoiding
;; resolve-primitives does.
'((#:resolve-primitives? 2)
(#:expand-primitives? 1)
(#:letrectify? 2)
(#:seal-private-bindings? 3)
(#:partial-eval? 1)
(#:eta-expand? 2)))
(available-optimizations 'tree-il))
(define (make-lowerer optimization-level opts)
(define (enabled-for-level? level) (<= level optimization-level))
(let ((opts (let lp ((all-opts (tree-il-optimizations)))
(match all-opts
(() '())
(((kw level) . all-opts)
(acons kw (kw-arg-ref opts kw (enabled-for-level? level))
(lp all-opts)))))))
(lambda (exp env)
(optimize exp env opts))))

28
module/language/tree-il/spec.scm
View file

@ -1,6 +1,6 @@
;;; Tree Intermediate Language
;; Copyright (C) 2009, 2010, 2011, 2013, 2015 Free Software Foundation, Inc.
;; Copyright (C) 2009-2011,2013,2015,2020 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
@ -20,21 +20,31 @@
(define-module (language tree-il spec)
#:use-module (system base language)
#:use-module (system base pmatch)
#:use-module (ice-9 match)
#:use-module (language tree-il)
#:use-module (language tree-il compile-cps)
#:use-module ((language tree-il analyze) #:select (make-analyzer))
#:use-module ((language tree-il optimize) #:select (make-lowerer))
#:export (tree-il))
(define (write-tree-il exp . port)
(apply write (unparse-tree-il exp) port))
(define (join exps env)
(pmatch exps
(match exps
(() (make-void #f))
((,x) x)
((,x . ,rest)
((x) x)
((x . rest)
(make-seq #f x (join rest env)))
(else (error "what!" exps env))))
(_ (error "what!" exps env))))
(define (choose-compiler target optimization-level opts)
(define (load-compiler compiler)
(module-ref (resolve-interface `(language tree-il ,compiler)) compiler))
(if (match (memq #:cps? opts)
((_ cps? . _) cps?)
(#f (<= 1 optimization-level)))
(cons 'cps (load-compiler 'compile-cps))
(cons 'bytecode (load-compiler 'compile-bytecode))))
(define-language tree-il
#:title "Tree Intermediate Language"
@ -42,5 +52,7 @@
#:printer write-tree-il
#:parser parse-tree-il
#:joiner join
#:compilers `((cps . ,compile-cps))
#:compiler-chooser choose-compiler
#:analyzer make-analyzer
#:lowerer make-lowerer
#:for-humans? #f)

87
module/scripts/compile.scm
View file

@ -29,8 +29,10 @@
;;; Code:
(define-module (scripts compile)
#:use-module ((system base language) #:select (lookup-language))
#:use-module ((system base compile) #:select (compile-file))
#:use-module ((system base compile) #:select (compute-compiler
compile-file
default-warning-level
default-optimization-level))
#:use-module (system base target)
#:use-module (system base message)
#:use-module (system base optimize)
@ -44,8 +46,8 @@
(define %summary "Compile a file.")
(define (fail . messages)
(format (current-error-port) "error: ~{~a~}~%" messages)
(define (fail message . args)
(format (current-error-port) "error: ~?~%" message args)
(exit 1))
(define %options
@ -81,14 +83,21 @@
(option '(#\W "warn") #t #f
(lambda (opt name arg result)
(if (string=? arg "help")
(begin
(show-warning-help)
(exit 0))
(let ((warnings (assoc-ref result 'warnings)))
(alist-cons 'warnings
(cons (string->symbol arg) warnings)
(alist-delete 'warnings result))))))
(match arg
("help"
(show-warning-help)
(exit 0))
((? string->number)
(let ((n (string->number arg)))
(unless (and (exact-integer? n) (<= 0 n))
(fail "Bad warning level `~a'" n))
(alist-cons 'warning-level n
(alist-delete 'warning-level result))))
(_
(let ((warnings (assoc-ref result 'warnings)))
(alist-cons 'warnings
(cons (string->symbol arg) warnings)
(alist-delete 'warnings result)))))))
(option '(#\O "optimize") #t #f
(lambda (opt name arg result)
@ -104,10 +113,12 @@
((string=? arg "help")
(show-optimization-help)
(exit 0))
((equal? arg "0") (return (optimizations-for-level 0)))
((equal? arg "1") (return (optimizations-for-level 1)))
((equal? arg "2") (return (optimizations-for-level 2)))
((equal? arg "3") (return (optimizations-for-level 3)))
((string->number arg)
=> (lambda (level)
(unless (and (exact-integer? level) (<= 0 level 9))
(fail "Bad optimization level `~a'" level))
(alist-cons 'optimization-level level
(alist-delete 'optimization-level result))))
((string-prefix? "no-" arg)
(return-option (substring arg 3) #f))
(else
@ -141,8 +152,10 @@ options."
result)))
;; default option values
'((input-files)
`((input-files)
(load-path)
(warning-level . ,(default-warning-level))
(optimization-level . ,(default-optimization-level))
(warnings unsupported-warning))))
(define (show-version)
@ -159,7 +172,9 @@ There is NO WARRANTY, to the extent permitted by law.~%"))
(format #f "`~A'" (warning-type-name wt))
(warning-type-description wt)))
%warning-types)
(format #t "~%"))
(format #t "~%")
(format #t "You may also specify warning levels as `-W0`, `-W1',~%")
(format #t "`-W2', or `-W3'. The default is `-W1'.~%"))
(define (show-optimization-help)
(format #t "The available optimizations are:~%~%")
@ -184,6 +199,8 @@ There is NO WARRANTY, to the extent permitted by law.~%"))
(define (compile . args)
(let* ((options (parse-args args))
(help? (assoc-ref options 'help?))
(warning-level (assoc-ref options 'warning-level))
(optimization-level (assoc-ref options 'optimization-level))
(compile-opts `(#:warnings
,(assoc-ref options 'warnings)
,@(append-map
@ -233,21 +250,20 @@ Report bugs to <~A>.~%"
(when (assoc-ref options 'install-r7rs?)
(install-r7rs!))
;; Load FROM and TO before we have changed the load path. That way, when
;; cross-compiling Guile itself, we can be sure we're loading our own
;; language modules and not those of the Guile being compiled, which may
;; have incompatible .go files.
(lookup-language from)
(lookup-language to)
;; Compute a compiler before changing the load path, for its side
;; effects of loading compiler modules. That way, when
;; cross-compiling Guile itself, we can be sure we're loading our
;; own language modules and not those of the Guile being compiled,
;; which may have incompatible .go files.
(compute-compiler from to optimization-level warning-level compile-opts)
(set! %load-path (append load-path %load-path))
(set! %load-should-auto-compile #f)
(if (and output-file
(or (null? input-files)
(not (null? (cdr input-files)))))
(fail "`-o' option can only be specified "
"when compiling a single file"))
(when (and output-file
(or (null? input-files)
(not (null? (cdr input-files)))))
(fail "`-o' option can only be specified when compiling a single file"))
;; Install a SIGINT handler. As a side effect, this gives unwind
;; handlers an opportunity to run upon SIGINT; this includes that of
@ -262,11 +278,14 @@ Report bugs to <~A>.~%"
(with-fluids ((*current-warning-prefix* ""))
(with-target target
(lambda ()
(compile-file file
#:output-file output-file
#:from from
#:to to
#:opts compile-opts))))))
(compile-file
file
#:output-file output-file
#:from from
#:to to
#:warning-level warning-level
#:optimization-level optimization-level
#:opts compile-opts))))))
input-files)))
(define main compile)

270
module/system/base/compile.scm
View file

@ -1,39 +1,49 @@
;;; High-level compiler interface
;; Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
;; Copyright (C) 2001,2005,2008-2013,2016,2020 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 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.
;;; 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
;;; You should have received a copy of the GNU Lesser General Public License
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Code:
(define-module (system base compile)
#:use-module (system base syntax)
#:use-module (system base language)
#:use-module (system base message)
#:use-module (system vm vm) ;; FIXME: there's a reason for this, can't remember why tho
#:use-module (ice-9 regex)
#:use-module (ice-9 optargs)
#:use-module (ice-9 receive)
#:use-module (ice-9 match)
#:use-module (srfi srfi-11)
#:export (compiled-file-name
compile-file
compile-and-load
compute-compiler
read-and-compile
compile
decompile))
decompile
default-warning-level
default-optimization-level))
(define (level-validator x)
(unless (and (exact-integer? x) (<= 0 x 9))
(error
"bad warning or optimization level: expected integer between 0 and 9"
x))
x)
(define default-warning-level (make-parameter 1 level-validator))
(define default-optimization-level (make-parameter 2 level-validator))
;;;
;;; Compiler
;;;
@ -42,8 +52,8 @@
(let ((entered #f))
(dynamic-wind
(lambda ()
(if entered
(error "thunk may only be entered once: ~a" thunk))
(when entered
(error "thunk may only be entered once: ~a" thunk))
(set! entered #t))
thunk
(lambda () #t))))
@ -132,13 +142,38 @@
(and (false-if-exception (ensure-directory (dirname f)))
f))))
(define (validate-options opts)
(define (validate-warnings warnings)
(match warnings
(() (values))
((w . warnings)
(unless (lookup-warning-type w)
(warning 'unsupported-warning #f w))
(validate-warnings warnings))))
(match opts
(() (values))
((kw arg . opts)
(match kw
(#:warnings (validate-warnings arg))
((? keyword?) (values))
(_
;; Programming error.
(warn "malformed options list: not a keyword" kw)))
(validate-options opts))
(_
;; Programming error.
(warn "malformed options list: expected keyword and arg pair" opts))))
(define* (compile-file file #:key
(output-file #f)
(from (current-language))
(to 'bytecode)
(env (default-environment from))
(optimization-level (default-optimization-level))
(warning-level (default-warning-level))
(opts '())
(canonicalization 'relative))
(validate-options opts)
(with-fluids ((%file-port-name-canonicalization canonicalization))
(let* ((comp (or output-file (compiled-file-name file)
(error "failed to create path for auto-compiled file"
@ -152,18 +187,26 @@
(call-with-output-file/atomic comp
(lambda (port)
((language-printer (ensure-language to))
(read-and-compile in #:env env #:from from #:to to #:opts
(cons* #:to-file? #t opts))
(read-and-compile in #:env env #:from from #:to to
#:optimization-level optimization-level
#:warning-level warning-level
#:opts (cons* #:to-file? #t opts))
port))
file)
comp)))
(define* (compile-and-load file #:key (from (current-language)) (to 'value)
(env (current-module)) (opts '())
(env (current-module))
(optimization-level (default-optimization-level))
(warning-level (default-warning-level))
(opts '())
(canonicalization 'relative))
(validate-options opts)
(with-fluids ((%file-port-name-canonicalization canonicalization))
(read-and-compile (open-input-file file)
#:from from #:to to #:opts opts
#:optimization-level optimization-level
#:warning-level warning-level
#:env env)))
@ -171,34 +214,79 @@
;;; Compiler interface
;;;
(define (compile-passes from to opts)
(map cdr
(or (lookup-compilation-order from to)
(error "no way to compile" from "to" to))))
(define (compute-analyzer lang warning-level opts)
(level-validator warning-level)
(match (language-analyzer lang)
(#f (lambda (exp env) (values)))
(proc (proc warning-level
(let lp ((opts opts))
(match opts
(() '())
((#:warnings warnings . _) warnings)
((_ _ . opts) (lp opts))))))))
(define (compile-fold passes exp env opts)
(let lp ((passes passes) (x exp) (e env) (cenv env) (first? #t))
(if (null? passes)
(values x e cenv)
(receive (x e new-cenv) ((car passes) x e opts)
(lp (cdr passes) x e (if first? new-cenv cenv) #f)))))
(define (compute-lowerer lang optimization-level opts)
(level-validator optimization-level)
(match (language-lowerer lang)
(#f (lambda (exp env) exp))
(proc (proc optimization-level opts))))
(define (find-language-joint from to)
(let lp ((in (reverse (or (lookup-compilation-order from to)
(error "no way to compile" from "to" to))))
(lang to))
(cond ((null? in) to)
((language-joiner lang) lang)
(else
(lp (cdr in) (caar in))))))
(define (next-pass from lang to optimization-level opts)
(if (eq? lang to)
#f ;; Done.
(match (language-compilers lang)
(((name . pass))
(cons (lookup-language name) pass))
(compilers
(let ((chooser (language-compiler-chooser lang)))
(unless chooser
(if (null? compilers)
(error "no way to compile" from "to" to)
(error "multiple compilers; language should supply chooser")))
(match (chooser to optimization-level opts)
((name . pass)
(cons (lookup-language name) pass))))))))
(define (compute-compiler from to optimization-level warning-level opts)
(let ((from (ensure-language from))
(to (ensure-language to)))
(let lp ((lang from))
(match (next-pass from lang to optimization-level opts)
(#f (lambda (exp env) (values exp env env)))
((next . pass)
(let* ((analyze (compute-analyzer lang warning-level opts))
(lower (compute-lowerer lang optimization-level opts))
(compile (lambda (exp env)
(analyze exp env)
(pass (lower exp env) env opts)))
(tail (lp next)))
(lambda (exp env)
(let*-values (((exp env cenv) (compile exp env))
((exp env cenv*) (tail exp env)))
;; Return continuation environment from first pass, to
;; compile an additional expression in the same compilation
;; unit.
(values exp env cenv)))))))))
(define (find-language-joint from to optimization-level opts)
(let ((from (ensure-language from))
(to (ensure-language to)))
(let lp ((lang from))
(match (next-pass from lang to optimization-level opts)
(#f #f)
((next . pass)
(or (lp next)
(and (language-joiner next)
next)))))))
(define (default-language-joiner lang)
(lambda (exps env)
(if (and (pair? exps) (null? (cdr exps)))
(car exps)
(error
"Multiple expressions read and compiled, but language has no joiner"
lang))))
(match exps
((exp) exp)
(_
(error
"Multiple expressions read and compiled, but language has no joiner"
lang)))))
(define (read-and-parse lang port cenv)
(let ((exp ((language-reader lang) port cenv)))
@ -211,49 +299,54 @@
(from (current-language))
(to 'bytecode)
(env (default-environment from))
(optimization-level (default-optimization-level))
(warning-level (default-warning-level))
(opts '()))
(let ((from (ensure-language from))
(to (ensure-language to)))
(let ((joint (find-language-joint from to)))
(parameterize ((current-language from))
(let lp ((exps '()) (env #f) (cenv env))
(let ((x (read-and-parse (current-language) port cenv)))
(cond
((eof-object? x)
(close-port port)
(compile ((or (language-joiner joint)
(default-language-joiner joint))
(reverse exps)
env)
#:from joint #:to to
;; env can be false if no expressions were read.
#:env (or env (default-environment joint))
#:opts opts))
(else
;; compile-fold instead of compile so we get the env too
(receive (jexp jenv jcenv)
(compile-fold (compile-passes (current-language) joint opts)
x cenv opts)
(lp (cons jexp exps) jenv jcenv))))))))))
(let* ((from (ensure-language from))
(to (ensure-language to))
(joint (find-language-joint from to optimization-level opts)))
(parameterize ((current-language from))
(let lp ((exps '()) (env #f) (cenv env) (from #f) (compile1 #f))
(match (read-and-parse (current-language) port cenv)
((? eof-object?)
(close-port port)
(compile ((or (language-joiner joint)
(default-language-joiner joint))
(reverse exps)
env)
#:from joint #:to to
;; env can be false if no expressions were read.
#:env (or env (default-environment joint))
#:optimization-level optimization-level
#:warning-level warning-level
#:opts opts))
(exp
(let with-compiler ((from from) (compile1 compile1))
(cond
((eq? from (current-language))
(receive (exp env cenv) (compile1 exp cenv)
(lp (cons exp exps) env cenv from compile1)))
(else
;; compute-compiler instead of compile so we get the
;; env too.
(let ((from (current-language)))
(with-compiler
from
(compute-compiler from joint optimization-level
warning-level opts))))))))))))
(define* (compile x #:key
(from (current-language))
(to 'value)
(env (default-environment from))
(optimization-level (default-optimization-level))
(warning-level (default-warning-level))
(opts '()))
(let ((warnings (memq #:warnings opts)))
(if (pair? warnings)
(let ((warnings (cadr warnings)))
;; Sanity-check the requested warnings.
(for-each (lambda (w)
(or (lookup-warning-type w)
(warning 'unsupported-warning #f w)))
warnings))))
(receive (exp env cenv)
(compile-fold (compile-passes from to opts) x env opts)
exp))
(validate-options opts)
(let ((compile1 (compute-compiler from to optimization-level
warning-level opts)))
(receive (exp env cenv) (compile1 x env)
exp)))
;;;
@ -261,15 +354,16 @@
;;;
(define (decompile-passes from to opts)
(map cdr
(or (lookup-decompilation-order from to)
(error "no way to decompile" from "to" to))))
(match (lookup-decompilation-order from to)
(((langs . passes) ...) passes)
(_ (error "no way to decompile" from "to" to))))
(define (decompile-fold passes exp env opts)
(if (null? passes)
(values exp env)
(receive (exp env) ((car passes) exp env opts)
(decompile-fold (cdr passes) exp env opts))))
(match passes
(() (values exp env))
((pass . passes)
(receive (exp env) (pass exp env opts)
(decompile-fold passes exp env opts)))))
(define* (decompile x #:key
(env #f)

50
module/system/base/language.scm
View file

@ -1,6 +1,6 @@
;;; Multi-language support
;; Copyright (C) 2001, 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
;; Copyright (C) 2001,2005,2008-2011,2013,2020 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
@ -27,11 +27,11 @@
language-compilers language-decompilers language-evaluator
language-joiner language-for-humans?
language-make-default-environment
language-lowerer language-analyzer
language-compiler-chooser
lookup-compilation-order lookup-decompilation-order
invalidate-compilation-cache! default-environment
*current-language*)
default-environment)
#:re-export (current-language))
@ -51,12 +51,13 @@
(evaluator #f)
(joiner #f)
(for-humans? #t)
(make-default-environment make-fresh-user-module))
(make-default-environment make-fresh-user-module)
(lowerer #f)
(analyzer #f)
(compiler-chooser #f))
(define-macro (define-language name . spec)
`(begin
(invalidate-compilation-cache!)
(define ,name (make-language #:name ',name ,@spec))))
(define-syntax-rule (define-language name . spec)
(define name (make-language #:name 'name . spec)))
(define (lookup-language name)
(let ((m (resolve-module `(language ,name spec))))
@ -64,12 +65,11 @@
(module-ref m name)
(error "no such language" name))))
(define *compilation-cache* '())
(define *decompilation-cache* '())
(define (invalidate-compilation-cache!)
(set! *decompilation-cache* '())
(set! *compilation-cache* '()))
(begin-deprecated
(define-public (invalidate-compilation-cache!)
(issue-deprecation-warning
"invalidate-compilation-cache is deprecated; recompile your modules")
(values)))
(define (compute-translation-order from to language-translators)
(cond
@ -87,22 +87,11 @@
(language-translators from))))))))
(define (lookup-compilation-order from to)
(let ((key (cons from to)))
(or (assoc-ref *compilation-cache* key)
(let ((order (compute-translation-order from to language-compilers)))
(set! *compilation-cache*
(acons key order *compilation-cache*))
order))))
(compute-translation-order from to language-compilers))
(define (lookup-decompilation-order from to)
(let ((key (cons from to)))
(or (assoc-ref *decompilation-cache* key)
;; trickery!
(let ((order (and=>
(compute-translation-order to from language-decompilers)
reverse!)))
(set! *decompilation-cache* (acons key order *decompilation-cache*))
order))))
(and=> (compute-translation-order to from language-decompilers)
reverse!))
(define (default-environment lang)
"Return the default compilation environment for source language LANG."
@ -116,4 +105,5 @@
;;;
;; Deprecated; use current-language instead.
(define *current-language* (parameter-fluid current-language))
(begin-deprecated
(define-public *current-language* (parameter-fluid current-language)))

25
module/system/base/message.scm
View file

@ -1,20 +1,19 @@
;;; User interface messages
;; Copyright (C) 2009, 2010, 2011, 2012, 2018 Free Software Foundation, Inc.
;; Copyright (C) 2009-2012,2016,2018,2020 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 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.
;;; 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
;;; You should have received a copy of the GNU Lesser General Public License
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;;
@ -234,5 +233,3 @@ property alist) using the data in ARGS."
args)
(format port "~A: unknown warning type `~A': ~A~%"
(location-string location) type args))))
;;; message.scm ends here

44
module/system/base/optimize.scm
View file

@ -1,6 +1,6 @@
;;; Optimization flags
;; Copyright (C) 2018 Free Software Foundation, Inc.
;; Copyright (C) 2018, 2020 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
@ -19,15 +19,49 @@
;;; Code:
(define-module (system base optimize)
#:use-module (language tree-il optimize)
#:use-module (language cps optimize)
#:use-module (ice-9 match)
#:export (available-optimizations
pass-optimization-level
optimizations-for-level))
(define (available-optimizations)
(append (tree-il-optimizations) (cps-optimizations)))
(define* (available-optimizations #:optional lang-name)
(match lang-name
('tree-il
;; Avoid resolve-primitives until -O2, when CPS optimizations kick in.
;; Otherwise, inlining the primcalls during Tree-IL->CPS compilation
;; will result in a lot of code that will never get optimized nicely.
;; Similarly letrectification is great for generated code quality, but
;; as it gives the compiler more to work with, it increases compile
;; time enough that we reserve it for -O2. Also, this makes -O1 avoid
;; assumptions about top-level values, in the same way that avoiding
;; resolve-primitives does.
'((#:cps? 1)
(#:resolve-primitives? 2)
(#:expand-primitives? 1)
(#:letrectify? 2)
(#:seal-private-bindings? 3)
(#:partial-eval? 1)
(#:eta-expand? 2)))
('cps
'( ;; (#:split-rec? #t)
(#:simplify? 2)
(#:eliminate-dead-code? 2)
(#:prune-top-level-scopes? 2)
(#:contify? 2)
(#:specialize-primcalls? 2)
(#:peel-loops? 2)
(#:cse? 2)
(#:type-fold? 2)
(#:resolve-self-references? 2)
(#:devirtualize-integers? 2)
(#:specialize-numbers? 2)
(#:licm? 2)
(#:rotate-loops? 2)
;; This one is used by the slot allocator.
(#:precolor-calls? 2)))
(#f
(append (available-optimizations 'tree-il)
(available-optimizations 'cps)))))
(define (pass-optimization-level kw)
(match (assq kw (available-optimizations))

15
module/system/vm/assembler.scm
View file

@ -256,7 +256,9 @@
emit-lsh/immediate
emit-rsh/immediate
emit-resolve-module
emit-module-variable
emit-lookup
emit-lookup-bound
emit-define!
emit-current-module
@ -973,6 +975,15 @@ later by the linker."
(emit-push asm (+ c 2))
(encode-X8_S8_S8_S8-C32 asm 2 1 0 c32 opcode)
(emit-drop asm 3))))
(define (encode-X8_S8_C8_S8-C32!/shuffle asm a const b c32 opcode)
(cond
((< (logior a b) (ash 1 8))
(encode-X8_S8_C8_S8-C32 asm a const b c32 opcode))
(else
(emit-push asm a)
(emit-push asm (+ b 1))
(encode-X8_S8_C8_S8-C32 asm 1 const 0 c32 opcode)
(emit-drop asm 2))))
(define (encode-X8_S12_S12-C32<-/shuffle asm dst src c32 opcode)
(cond
((< (logior dst src) (ash 1 12))
@ -1009,9 +1020,9 @@ later by the linker."
(('<- 'X8_S8_S8_S8) #'encode-X8_S8_S8_S8<-/shuffle)
(('<- 'X8_S8_S8_C8) #'encode-X8_S8_S8_C8<-/shuffle)
(('! 'X8_S8_S8_S8 'C32) #'encode-X8_S8_S8_S8-C32!/shuffle)
(('! 'X8_S8_C8_S8 'C32) #'encode-X8_S8_C8_S8-C32!/shuffle)
(('<- 'X8_S8_S8_S8 'C32) #'encode-X8_S8_S8_S8-C32<-/shuffle)
(('<- 'X8_S8_S8_C8 'C32) #'encode-X8_S8_S8_C8-C32<-/shuffle)
(('! 'X8_S8_S8_C8 'C32) #'encode-X8_S8_S8_C8-C32!/shuffle)
(('<- 'X8_S12_S12 'C32) #'encode-X8_S12_S12-C32<-/shuffle)
(('! 'X8_S12_S12 'C32) #'encode-X8_S12_S12-C32!/shuffle)
(('! 'X8_S8_C8_S8) #'encode-X8_S8_C8_S8!/shuffle)
@ -1493,7 +1504,9 @@ returned instead."
(define-scm<-scm-uimm-intrinsic lsh/immediate)
(define-scm<-scm-uimm-intrinsic rsh/immediate)
(define-scm<-scm-bool-intrinsic resolve-module)
(define-scm<-scm-scm-intrinsic module-variable)
(define-scm<-scm-scm-intrinsic lookup)
(define-scm<-scm-scm-intrinsic lookup-bound)
(define-scm<-scm-scm-intrinsic define!)
(define-scm<-thread-intrinsic current-module)

33
test-suite/test-suite/lib.scm
View file

@ -1,5 +1,5 @@
;;;; test-suite/lib.scm --- generic support for testing
;;;; Copyright (C) 1999-2001,2004,2006-2007,2009-2014,2018
;;;; Copyright (C) 1999-2001,2004,2006-2007,2009-2014,2016,2018,2020
;;;; Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or
@ -466,20 +466,31 @@
(c&e (pass-if "[unnamed test]" exp)))
((_ (pass-if test-name exp))
(begin (pass-if (string-append test-name " (eval)")
(primitive-eval 'exp))
(pass-if (string-append test-name " (compile)")
(compile 'exp #:to 'value #:env (current-module)))))
(primitive-eval 'exp))
(pass-if (string-append test-name " (compile -O0)")
(compile 'exp #:to 'value #:env (current-module)
#:optimization-level 0))
(pass-if (string-append test-name " (compile -O2)")
(compile 'exp #:to 'value #:env (current-module)
#:optimization-level 2))))
((_ (pass-if-equal test-name val exp))
(begin (pass-if-equal (string-append test-name " (eval)") val
(primitive-eval 'exp))
(pass-if-equal (string-append test-name " (compile)") val
(compile 'exp #:to 'value #:env (current-module)))))
(pass-if-equal (string-append test-name " (compile -O0)") val
(compile 'exp #:to 'value #:env (current-module)
#:optimization-level 0))
(pass-if-equal (string-append test-name " (compile -O2)") val
(compile 'exp #:to 'value #:env (current-module)
#:optimization-level 2))))
((_ (pass-if-exception test-name exc exp))
(begin (pass-if-exception (string-append test-name " (eval)")
exc (primitive-eval 'exp))
(pass-if-exception (string-append test-name " (compile)")
exc (compile 'exp #:to 'value
#:env (current-module)))))))
(begin (pass-if-exception (string-append test-name " (eval)") exc
(primitive-eval 'exp))
(pass-if-exception (string-append test-name " (compile -O0)") exc
(compile 'exp #:to 'value #:env (current-module)
#:optimization-level 0))
(pass-if-exception (string-append test-name " (compile -O2)") exc
(compile 'exp #:to 'value #:env (current-module)
#:optimization-level 2))))))
;;; (with-test-prefix/c&e PREFIX BODY ...)
;;; Same as `with-test-prefix', but the enclosed tests are run both with

6
test-suite/tests/cross-compilation.test
View file

@ -1,6 +1,6 @@
;;;; Cross compilation -*- mode: scheme; coding: utf-8; -*-
;;;;
;;;; Copyright (C) 2010-2014 Free Software Foundation, Inc.
;;;; Copyright (C) 2010-2014, 2020 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
@ -56,7 +56,7 @@
(string=? (native-os) (target-os)))
(native-word-size)
word-size))
(bv (compile '(hello-world) #:to 'bytecode)))
(bv (compile '(hello-world) #:warning-level 0 #:to 'bytecode)))
(and=> (parse-elf bv)
(lambda (elf)
(and (equal? (elf-byte-order elf) endian)
@ -91,7 +91,7 @@
(pass-if-exception "unknown target" exception:miscellaneous-error
(with-target "fcpu-unknown-gnu1.0"
(lambda ()
(compile '(ohai) #:to 'bytecode)))))
(compile '(ohai) #:warning-level 0 #:to 'bytecode)))))
;; Local Variables:
;; eval: (put 'with-target 'scheme-indent-function 1)

364
test-suite/tests/optargs.test
View file

@ -47,87 +47,76 @@
;;; let-keywords
;;;
(with-test-prefix/c&e "let-keywords"
(define-syntax-rule (without-compiler-warnings exp ...)
(parameterize ((default-warning-level 0)) exp ...))
;; in guile 1.6.4 and earlier, an empty binding list only used `begin',
;; which caused apparently internal defines to "leak" out into the
;; encompasing environment
(pass-if-exception "empty bindings internal defines leaking out"
exception:unbound-var
(let ((rest '()))
(let-keywords rest #f ()
(define localvar #f)
#f)
localvar))
(without-compiler-warnings
(with-test-prefix/c&e "let-keywords"
;; in guile 1.6.4 and earlier, an empty binding list only used `begin',
;; which caused apparently internal defines to "leak" out into the
;; encompasing environment
(pass-if-exception "empty bindings internal defines leaking out"
exception:unbound-var
(let ((rest '()))
(let-keywords rest #f ()
(define localvar #f)
#f)
localvar))
(pass-if "one key"
(let-keywords '(#:foo 123) #f (foo)
(= foo 123))))
(pass-if "one key"
(let-keywords '(#:foo 123) #f (foo)
(= foo 123))))
;;;
;;; let-keywords*
;;;
(with-test-prefix/c&e "let-keywords*"
(with-test-prefix/c&e "let-keywords*"
;; in guile 1.6.4 and earlier, an empty binding list only used `begin',
;; which caused apparently internal defines to "leak" out into the
;; encompasing environment
(pass-if-exception "empty bindings internal defines leaking out"
exception:unbound-var
(let ((rest '()))
(let-keywords* rest #f ()
(define localvar #f)
#f)
localvar))
;; in guile 1.6.4 and earlier, an empty binding list only used `begin',
;; which caused apparently internal defines to "leak" out into the
;; encompasing environment
(pass-if-exception "empty bindings internal defines leaking out"
exception:unbound-var
(let ((rest '()))
(let-keywords* rest #f ()
(define localvar #f)
#f)
localvar))
(pass-if "one key"
(let-keywords* '(#:foo 123) #f (foo)
(= foo 123))))
(pass-if "one key"
(let-keywords* '(#:foo 123) #f (foo)
(= foo 123))))
(with-test-prefix/c&e "let-optional"
;; in guile 1.6.4 and earlier, an empty binding list only used `begin',
;; which caused apparently internal defines to "leak" out into the
;; encompasing environment
(pass-if-exception "empty bindings internal defines leaking out"
exception:unbound-var
(let ((rest '()))
(let-optional rest ()
(define localvar #f)
#f)
localvar))
;;;
;;; let-optional
;;;
(pass-if "one var"
(let ((rest '(123)))
(let-optional rest ((foo 999))
(= foo 123)))))
(with-test-prefix/c&e "let-optional"
(with-test-prefix/c&e "let-optional*"
;; in guile 1.6.4 and earlier, an empty binding list only used `begin',
;; which caused apparently internal defines to "leak" out into the
;; encompasing environment
(pass-if-exception "empty bindings internal defines leaking out"
exception:unbound-var
(let ((rest '()))
(let-optional* rest ()
(define localvar #f)
#f)
localvar))
;; in guile 1.6.4 and earlier, an empty binding list only used `begin',
;; which caused apparently internal defines to "leak" out into the
;; encompasing environment
(pass-if-exception "empty bindings internal defines leaking out"
exception:unbound-var
(let ((rest '()))
(let-optional rest ()
(define localvar #f)
#f)
localvar))
(pass-if "one var"
(let ((rest '(123)))
(let-optional rest ((foo 999))
(= foo 123)))))
;;;
;;; let-optional*
;;;
(with-test-prefix/c&e "let-optional*"
;; in guile 1.6.4 and earlier, an empty binding list only used `begin',
;; which caused apparently internal defines to "leak" out into the
;; encompasing environment
(pass-if-exception "empty bindings internal defines leaking out"
exception:unbound-var
(let ((rest '()))
(let-optional* rest ()
(define localvar #f)
#f)
localvar))
(pass-if "one var"
(let ((rest '(123)))
(let-optional* rest ((foo 999))
(= foo 123)))))
(pass-if "one var"
(let ((rest '(123)))
(let-optional* rest ((foo 999))
(= foo 123))))))
(define* (foo a b #:optional c (d 1) (e c) f #:key g (h a) (i r) #:rest r)
(list a b c d e f g h i r))
@ -136,46 +125,47 @@
;; the compiler, and the compiler compiles itself, using the evaluator
;; (when bootstrapping) and compiled code (when doing a partial rebuild)
;; makes me a bit complacent.
(with-test-prefix/c&e "define*"
(pass-if "the whole enchilada"
(equal? (foo 1 2)
'(1 2 #f 1 #f #f #f 1 () ())))
(without-compiler-warnings
(with-test-prefix/c&e "define*"
(pass-if "the whole enchilada"
(equal? (foo 1 2)
'(1 2 #f 1 #f #f #f 1 () ())))
(pass-if-exception "extraneous arguments"
exception:extraneous-arguments
(let ((f (lambda* (#:key x) x)))
(f 1 2 #:x 'x)))
(pass-if-exception "extraneous arguments"
exception:extraneous-arguments
(let ((f (lambda* (#:key x) x)))
(f 1 2 #:x 'x)))
(pass-if-equal "unrecognized keyword" '(#:y)
(catch 'keyword-argument-error
(lambda ()
(let ((f (lambda* (#:key x) x)))
(f #:y 'not-recognized)))
(lambda (key proc fmt args data)
data)))
(pass-if-equal "unrecognized keyword" '(#:y)
(catch 'keyword-argument-error
(lambda ()
(let ((f (lambda* (#:key x) x)))
(f #:y 'not-recognized)))
(lambda (key proc fmt args data)
data)))
(pass-if-equal "missing argument" '("Keyword argument has no value" #:x)
(catch 'keyword-argument-error
(lambda ()
(let ((f (lambda* (#:key x) x)))
(f #:x)))
(lambda (key proc fmt args data)
(cons fmt data))))
(pass-if-equal "missing argument" '("Keyword argument has no value" #:x)
(catch 'keyword-argument-error
(lambda ()
(let ((f (lambda* (#:key x) x)))
(f #:x)))
(lambda (key proc fmt args data)
(cons fmt data))))
(pass-if-equal "invalid keyword" '(not-a-keyword)
(catch 'keyword-argument-error
(lambda ()
(let ((f (lambda* (#:key x) x)))
(f 'not-a-keyword 'something)))
(lambda (key proc fmt args data)
data)))
(pass-if-equal "invalid keyword" '(not-a-keyword)
(catch 'keyword-argument-error
(lambda ()
(let ((f (lambda* (#:key x) x)))
(f 'not-a-keyword 'something)))
(lambda (key proc fmt args data)
data)))
(pass-if "rest given before keywords"
;; Passing the rest argument before the keyword arguments should not
;; prevent keyword argument binding.
(let ((f (lambda* (#:key x y z #:rest r) (list x y z r))))
(equal? (f 1 2 3 #:x 'x #:z 'z)
'(x #f z (1 2 3 #:x x #:z z))))))
(pass-if "rest given before keywords"
;; Passing the rest argument before the keyword arguments should not
;; prevent keyword argument binding.
(let ((f (lambda* (#:key x y z #:rest r) (list x y z r))))
(equal? (f 1 2 3 #:x 'x #:z 'z)
'(x #f z (1 2 3 #:x x #:z z)))))))
(with-test-prefix "scm_c_bind_keyword_arguments"
@ -245,98 +235,100 @@
(equal? (transmogrify quote)
10)))
(with-test-prefix/c&e "case-lambda"
(pass-if-exception "no clauses, no args" exception:wrong-num-args
((case-lambda)))
(without-compiler-warnings
(with-test-prefix/c&e "case-lambda"
(pass-if-exception "no clauses, no args" exception:wrong-num-args
((case-lambda)))
(pass-if-exception "no clauses, args" exception:wrong-num-args
((case-lambda) 1))
(pass-if-exception "no clauses, args" exception:wrong-num-args
((case-lambda) 1))
(pass-if "docstring"
(equal? "docstring test"
(procedure-documentation
(case-lambda
"docstring test"
(() 0)
((x) 1))))))
(pass-if "docstring"
(equal? "docstring test"
(procedure-documentation
(case-lambda
"docstring test"
(() 0)
((x) 1)))))))
(with-test-prefix/c&e "case-lambda*"
(pass-if-exception "no clauses, no args" exception:wrong-num-args
((case-lambda*)))
(without-compiler-warnings
(with-test-prefix/c&e "case-lambda*"
(pass-if-exception "no clauses, no args" exception:wrong-num-args
((case-lambda*)))
(pass-if-exception "no clauses, args" exception:wrong-num-args
((case-lambda*) 1))
(pass-if-exception "no clauses, args" exception:wrong-num-args
((case-lambda*) 1))
(pass-if "docstring"
(equal? "docstring test"
(procedure-documentation
(case-lambda*
"docstring test"
(() 0)
((x) 1)))))
(pass-if "docstring"
(equal? "docstring test"
(procedure-documentation
(case-lambda*
"docstring test"
(() 0)
((x) 1)))))
(pass-if "unambiguous"
((case-lambda*
((a b) #t)
((a) #f))
1 2))
(pass-if "unambiguous"
((case-lambda*
((a b) #t)
((a) #f))
1 2))
(pass-if "unambiguous (reversed)"
((case-lambda*
((a) #f)
((a b) #t))
1 2))
(pass-if "unambiguous (reversed)"
((case-lambda*
((a) #f)
((a b) #t))
1 2))
(pass-if "optionals (order disambiguates)"
((case-lambda*
((a #:optional b) #t)
((a b) #f))
1 2))
(pass-if "optionals (order disambiguates)"
((case-lambda*
((a #:optional b) #t)
((a b) #f))
1 2))
(pass-if "optionals (order disambiguates (2))"
((case-lambda*
((a b) #t)
((a #:optional b) #f))
1 2))
(pass-if "optionals (order disambiguates (2))"
((case-lambda*
((a b) #t)
((a #:optional b) #f))
1 2))
(pass-if "optionals (one arg)"
((case-lambda*
((a b) #f)
((a #:optional b) #t))
1))
(pass-if "optionals (one arg)"
((case-lambda*
((a b) #f)
((a #:optional b) #t))
1))
(pass-if "optionals (one arg (2))"
((case-lambda*
((a #:optional b) #t)
((a b) #f))
1))
(pass-if "optionals (one arg (2))"
((case-lambda*
((a #:optional b) #t)
((a b) #f))
1))
(pass-if "keywords without keyword"
((case-lambda*
((a #:key c) #t)
((a b) #f))
1))
(pass-if "keywords without keyword"
((case-lambda*
((a #:key c) #t)
((a b) #f))
1))
(pass-if "keywords with keyword"
((case-lambda*
((a #:key c) #t)
((a b) #f))
1 #:c 2))
(pass-if "keywords with keyword"
((case-lambda*
((a #:key c) #t)
((a b) #f))
1 #:c 2))
(pass-if "keywords (too many positionals)"
((case-lambda*
((a #:key c) #f)
((a b) #t))
1 2))
(pass-if "keywords (too many positionals)"
((case-lambda*
((a #:key c) #f)
((a b) #t))
1 2))
(pass-if "keywords (order disambiguates)"
((case-lambda*
((a #:key c) #t)
((a b c) #f))
1 #:c 2))
(pass-if "keywords (order disambiguates)"
((case-lambda*
((a #:key c) #t)
((a b c) #f))
1 #:c 2))
(pass-if "keywords (order disambiguates (2))"
((case-lambda*
((a b c) #t)
((a #:key c) #f))
1 #:c 2)))
(pass-if "keywords (order disambiguates (2))"
((case-lambda*
((a b c) #t)
((a #:key c) #f))
1 #:c 2))))

54
test-suite/tests/ports.test
View file

@ -2,7 +2,7 @@
;;;; Jim Blandy <jimb@red-bean.com> --- May 1999
;;;;
;;;; Copyright (C) 1999, 2001, 2004, 2006, 2007, 2009, 2010,
;;;; 2011, 2012, 2013, 2014, 2015, 2017, 2019 Free Software Foundation, Inc.
;;;; 2011, 2012, 2013, 2014, 2015, 2017, 2019, 2020 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
@ -602,10 +602,40 @@
(pass-if "unread residue"
(string=? (read-line) "moon"))))
(pass-if-equal "initial revealed count" ;<https://bugs.gnu.org/41204>
0
(let* ((port (open-input-file "/dev/null"))
(revealed (port-revealed port)))
(close-port port)
revealed))
(pass-if-equal "non-revealed port is closed"
EBADF
(let* ((port (open-input-file "/dev/null"))
(fdes (fileno port))) ;leaves revealed count unchanged
(unless (zero? (port-revealed port))
(error "wrong revealed count" (port-revealed port)))
(set! port #f)
(gc)
(catch 'system-error
(lambda ()
(seek fdes 0 SEEK_CUR)
;; If we get here, it might be because PORT was not GC'd, we
;; don't know (and we can't use a guardian because it would keep
;; PORT alive.)
(close-fdes fdes)
(throw 'unresolved))
(lambda args
(system-error-errno args)))))
(pass-if-equal "close-port & revealed port"
EBADF
(let* ((port (open-file "/dev/null" "r0"))
(fdes (port->fdes port))) ;increments revealed count of PORT
(unless (= 1 (port-revealed port))
(error "wrong revealed count" (port-revealed port)))
(close-port port) ;closes FDES as a side-effect
(catch 'system-error
(lambda ()
@ -616,19 +646,19 @@
(pass-if "revealed port fdes not closed"
(let* ((port (open-file "/dev/null" "r0"))
(fdes (port->fdes port)) ;increments revealed count of PORT
(guardian (make-guardian)))
(guardian port)
(fdes (port->fdes port)))
(unless (= 1 (port-revealed port))
(error "wrong revealed count" (port-revealed port)))
(set! port #f)
(gc)
(if (port? (guardian))
(and (zero? (seek fdes 0 SEEK_CUR))
(begin
(close-fdes fdes)
#t))
(begin
(close-fdes fdes)
(throw 'unresolved)))))
;; Note: We can't know for sure whether PORT was GC'd; using a
;; guardian is not an option because it would keep it alive.
(and (zero? (seek fdes 0 SEEK_CUR))
(begin
(close-fdes fdes)
#t))))
(when (provided? 'threads)
(let* ((p (pipe))

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

@ -241,9 +241,11 @@
(define (call-with-warnings thunk)
(let ((port (open-output-string)))
(with-fluids ((*current-warning-port* port)
(*current-warning-prefix* ""))
(thunk))
;; Disable any warnings added by default.
(parameterize ((default-warning-level 0))
(with-fluids ((*current-warning-port* port)
(*current-warning-prefix* ""))
(thunk)))
(let ((warnings (get-output-string port)))
(string-tokenize warnings
(char-set-complement (char-set #\newline))))))