sfos/ecl
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge branch 'fix-load-forms' into 'develop'

Browse source 
fix load forms

Closes #562

See merge request embeddable-common-lisp/ecl!238
This commit is contained in:
Daniel Kochmański 2020-12-27 20:53:28 +00:00
commit 594d47f23f
9 changed files with 257 additions and 125 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

11
CHANGELOG
View file

@ -31,12 +31,19 @@
** Announcement
** Enhancements
- less cryptic names in backtraces of C-compiled functions
** Issues fixed
- The generational and precise garbage collector modes work again
- ECL can now use precompiled headers to speed up compilation. Use ~(setq
c::*use-precompiled-headers* nil)~ to disable this feature
** Issues fixed
- the generational and precise garbage collector modes work again
- ~serve-event~ extension may be used simultaneously from different threads now
- several Unicode issues have been fixed thanks to Vladimir Sedach
- encoding issues when reading in the output of the MSVC compiler have been fixed
- inlining of a local function which closes over a variable no longer leads
to miscompilations if a variable with the same name exists at the point
where the function is inlined
- the bytecompiler handles load time forms from literal objects correctly
with regards to the evaluation order and to multiple occurrences of the same
literal object in a single file
** API changes
- a condition ~ext:timeout~ is defined
* 20.4.24 changes since 16.1.3

15
contrib/bytecmp/bytecmp.lsp
View file

@ -113,16 +113,11 @@
(with-open-file (sout output-file :direction :output :if-exists :supersede
:if-does-not-exist :create
:external-format external-format)
(let ((binary (loop
with *package* = *package*
with *readtable* = *readtable*
with ext:*bytecodes-compiler* = t
for position = (file-position input)
for form = (read input nil :EOF)
until (eq form :EOF)
do (when ext::*source-location*
(rplacd ext:*source-location* position))
collect (si:eval-with-env form nil nil nil :load-toplevel))))
(let ((binary
(let ((*package* *package*)
(*readtable* *readtable*)
(ext:*bytecodes-compiler* t))
(si::bc-compile-from-stream input))))
(sys:with-ecl-io-syntax
(write binary :stream sout :circle t :escape t :readably t :pretty nil))
(terpri sout)))))

230
src/c/compiler.d
View file

@ -19,7 +19,7 @@
takes two words of memory: one for the operator and one for the argument.
The interpreter is written with this assumption in mind, but it should be
easily modifed, because arguments are retrieved with "next_arg" and
easily modified, because arguments are retrieved with "next_arg" and
operators with "next_op". Parts which will require a careful modification
are marked with flag [1].
*/
@ -549,6 +549,9 @@ c_new_env(cl_env_ptr the_env, cl_compiler_env_ptr new, cl_object env,
new->stepping = 0;
new->lexical_level = 0;
new->load_time_forms = ECL_NIL;
new->ltf_being_created = ECL_NIL;
new->ltf_defer_init_until = ECL_T;
new->ltf_locations = ECL_NIL;
new->env_depth = 0;
new->macros = CDR(env);
new->variables = CAR(env);
@ -568,6 +571,19 @@ c_new_env(cl_env_ptr the_env, cl_compiler_env_ptr new, cl_object env,
new->env_size = 0;
}
static void
c_restore_env(cl_env_ptr the_env, cl_compiler_env_ptr new_c_env, cl_compiler_env_ptr old_c_env)
{
if (new_c_env->env_depth == 0) {
/* Clear created constants (they cannot be printed) */
loop_for_in(new_c_env->ltf_locations) {
cl_index loc = ecl_fixnum(ECL_CONS_CAR(new_c_env->ltf_locations));
new_c_env->constants->vector.self.t[loc] = ecl_make_fixnum(0);
} end_loop_for_in;
}
the_env->c_env = old_c_env;
}
static cl_object
c_tag_ref(cl_env_ptr env, cl_object the_tag, cl_object the_type)
{
@ -2198,17 +2214,39 @@ c_values(cl_env_ptr env, cl_object args, int flags) {
return FLAG_VALUES;
}
static void
defer_load_object(cl_env_ptr env, cl_object place, cl_object created)
{
const cl_compiler_ptr c_env = env->c_env;
if (c_env->ltf_defer_init_until == ECL_T) {
FEerror("Circular dependency in load time forms involving ~S.", 1, ECL_CONS_CAR(place));
}
if (c_env->ltf_defer_init_until != ECL_NIL
&& ecl_member_eq(c_env->ltf_defer_init_until, created)) {
/* We are already deferring the init form long enough, nothing to do. */
return;
}
c_env->ltf_defer_init_until = place;
}
static void
maybe_make_load_forms(cl_env_ptr env, cl_object constant)
{
const cl_compiler_ptr c_env = env->c_env;
cl_object init, make;
if (c_env->mode != FLAG_LOAD)
cl_object init, make, created;
if ((c_env->mode != FLAG_LOAD)
|| (si_need_to_make_load_form_p(constant) == ECL_NIL))
return;
if (c_search_constant(env, constant) >= 0)
return;
if (si_need_to_make_load_form_p(constant) == ECL_NIL)
created = c_env->ltf_being_created;
/* If we are compiling a creation form for another load time form, defer the
* init form until after this creation form has been compiled. */
loop_for_in(created) {
cl_object place = ECL_CONS_CAR(created);
if (ECL_CONS_CAR(place) == constant) {
defer_load_object(env, place, created);
return;
}
} end_loop_for_in;
make = _ecl_funcall2(@'make-load-form', constant);
init = (env->nvalues > 1)? env->values[1] : ECL_NIL;
push(cl_list(3, constant, make, init), &c_env->load_time_forms);
@ -2376,6 +2414,9 @@ eval_nontrivial_form(cl_env_ptr env, cl_object form) {
ECL_NIL, /* displacement */
ECL_NIL);
new_c_env.load_time_forms = ECL_NIL;
new_c_env.ltf_being_created = ECL_NIL;
new_c_env.ltf_defer_init_until = ECL_T;
new_c_env.ltf_locations = ECL_NIL;
new_c_env.env_depth = 0;
new_c_env.env_size = 0;
env->c_env = &new_c_env;
@ -2420,72 +2461,113 @@ execute_each_form(cl_env_ptr env, cl_object body)
return FLAG_VALUES;
}
static cl_index *
static cl_object
save_bytecodes(cl_env_ptr env, cl_index start, cl_index end)
{
#ifdef GBC_BOEHM
cl_index l = end - start;
cl_index *bytecodes = ecl_alloc_atomic((l + 1) * sizeof(cl_index));
cl_index *p = bytecodes;
for (*(p++) = l; end > start; end--, p++) {
cl_object bytecodes = ecl_alloc_simple_vector(l, ecl_aet_index);
cl_index *p;
for (p = bytecodes->vector.self.index; end > start; end--, p++) {
*p = (cl_index)ECL_STACK_POP_UNSAFE(env);
}
return bytecodes;
#else
#error "Pointer references outside of recognizable object"
#endif
}
static void
restore_bytecodes(cl_env_ptr env, cl_index *bytecodes)
restore_bytecodes(cl_env_ptr env, cl_object bytecodes)
{
cl_index *p = bytecodes;
cl_index *p = bytecodes->vector.self.index;
cl_index l;
for (l = *p; l; l--) {
ECL_STACK_PUSH(env, (cl_object)p[l]);
for (l = bytecodes->vector.dim; l; l--) {
ECL_STACK_PUSH(env, (cl_object)p[l-1]);
}
ecl_dealloc(bytecodes);
}
static cl_index
add_load_form(cl_env_ptr env, cl_object object)
{
const cl_compiler_ptr c_env = env->c_env;
cl_object constant = pop(&object);
cl_object make_form = pop(&object);
cl_object init_form = pop(&object);
cl_object deferred_init_forms;
cl_index loc = c_register_constant(env, constant);
{
cl_object previous_locs = c_env->ltf_locations;
loop_for_in(previous_locs) {
if (ecl_fixnum(ECL_CONS_CAR(previous_locs)) == loc) {
/* We already compiled this load time form, nothing to do */
return loc;
}
} end_loop_for_in;
}
/* compile the MAKE-FORM */
/* c_env->ltf_being_created holds a list with the constant whose
* creation form is being compiled as first element... */
push(ecl_list1(constant), &c_env->ltf_being_created);
compile_with_load_time_forms(env, make_form, FLAG_REG0);
asm_op2(env, OP_CSET, loc);
/* ... and bytecodes for init forms which need to be deferred
* until the creation form has been evaluated in the following
* elements */
deferred_init_forms = ECL_CONS_CDR(pop(&c_env->ltf_being_created));
/* save the location of the created constant. This also serves as an
* indicator that we already compiled the load form for constant and
* don't need to do that again if we encouter constant in any other
* load time forms. */
push(ecl_make_fixnum(loc), &c_env->ltf_locations);
/* compile the INIT-FORM ... */
if (init_form != ECL_NIL) {
cl_index handle_init = current_pc(env);
cl_object old_init_until = c_env->ltf_defer_init_until;
c_env->ltf_defer_init_until = ECL_NIL;
compile_with_load_time_forms(env, init_form, FLAG_IGNORE);
/* ... and if it needs to be deferred, add it to c_env->ltf_being_created */
if (c_env->ltf_defer_init_until != ECL_NIL
&& c_env->ltf_defer_init_until != object) {
cl_object bytecodes_init = save_bytecodes(env, handle_init, current_pc(env));
cl_object l = si_memq(c_env->ltf_defer_init_until, c_env->ltf_being_created);
if (l != ECL_NIL) {
cl_object constant_and_inits = ECL_CONS_CAR(l);
ECL_RPLACD(constant_and_inits,
CONS(bytecodes_init, ECL_CONS_CDR(constant_and_inits)));
}
}
c_env->ltf_defer_init_until = old_init_until;
}
/* restore bytecodes for deferred init-forms. This comes after
* compiling the init form for constant since we are required to
* evaluate init forms as soon as possible. */
loop_for_in(deferred_init_forms) {
restore_bytecodes(env, ECL_CONS_CAR(deferred_init_forms));
} end_loop_for_in;
return loc;
}
/* First we compile the form as usual. If some constants need to be built,
* insert the code _before_ the actual forms; to do that we first save the
* bytecodes for the form, and then we compile forms that build constants;
* only after that we restore bytecodes of the compiled form. */
static int
compile_with_load_time_forms(cl_env_ptr env, cl_object form, int flags)
{
/*
* First compile the form as usual.
*/
const cl_compiler_ptr c_env = env->c_env;
cl_index handle = asm_begin(env);
int output_flags = compile_form(env, form, flags);
/*
* If some constants need to be built, we insert the
* code _before_ the actual forms;
*/
if (c_env->load_time_forms != ECL_NIL) {
cl_index *bytecodes = save_bytecodes(env, handle, current_pc(env));
/* reverse the load time forms list to make sure the forms are
* compiled in the right order */
cl_object p, forms_list = cl_nreverse(c_env->load_time_forms);
/* load_time_forms are collected in a reverse order, so we need to reverse
the list. Forms should not be compiled as top-level forms - to ensure
that we increment the lexical_level. */
cl_object bytecodes = save_bytecodes(env, handle, current_pc(env));
cl_object p = cl_nreverse(c_env->load_time_forms);
c_env->load_time_forms = ECL_NIL;
p = forms_list;
do {
cl_object r = ECL_CONS_CAR(p);
cl_object constant = pop(&r);
cl_object make_form = pop(&r);
cl_object init_form = pop(&r);
cl_index loc = c_register_constant(env, constant);
compile_with_load_time_forms(env, make_form, FLAG_REG0);
asm_op2(env, OP_CSET, loc);
compile_with_load_time_forms(env, init_form, FLAG_IGNORE);
ECL_RPLACA(p, ecl_make_fixnum(loc));
p = ECL_CONS_CDR(p);
} while (p != ECL_NIL);
p = forms_list;
do {
cl_index loc = ecl_fixnum(ECL_CONS_CAR(p));
/* Clear created constants (they cannot be printed) */
c_env->constants->vector.self.t[loc] = ecl_make_fixnum(0);
p = ECL_CONS_CDR(p);
} while (p != ECL_NIL);
c_env->lexical_level++;
loop_for_in(p) {
add_load_form(env, ECL_CONS_CAR(p));
} end_loop_for_in;
c_env->lexical_level--;
restore_bytecodes(env, bytecodes);
}
return output_flags;
@ -2704,7 +2786,7 @@ si_need_to_make_load_form_p(cl_object object)
push(ECL_CONS_CDR(object), &waiting_objects);
goto loop;
case t_bclosure: {
cl_object bc = object->bclosure.code;;
cl_object bc = object->bclosure.code;
push(object->bclosure.lex, &waiting_objects);
push(bc->bytecodes.data, &waiting_objects);
push(bc->bytecodes.name, &waiting_objects);
@ -3143,7 +3225,7 @@ ecl_make_lambda(cl_env_ptr env, cl_object name, cl_object lambda) {
output->bytecodes.name = name;
old_c_env->load_time_forms = env->c_env->load_time_forms;
env->c_env = old_c_env;
c_restore_env(env, &new_c_env, old_c_env);
ecl_bds_unwind1(env);
@ -3187,21 +3269,57 @@ si_make_lambda(cl_object name, cl_object rest)
{
cl_object lambda;
const cl_env_ptr the_env = ecl_process_env();
volatile cl_compiler_env_ptr old_c_env = the_env->c_env;
cl_compiler_env_ptr old_c_env = the_env->c_env;
struct cl_compiler_env new_c_env;
c_new_env(the_env, &new_c_env, ECL_NIL, 0);
ECL_UNWIND_PROTECT_BEGIN(the_env) {
lambda = ecl_make_lambda(the_env, name, rest);
} ECL_UNWIND_PROTECT_EXIT {
the_env->c_env = old_c_env;
c_restore_env(the_env, &new_c_env, old_c_env);
} ECL_UNWIND_PROTECT_END;
@(return lambda);
}
cl_object
si_bc_compile_from_stream(cl_object input)
{
/* Compile all forms read from input stream to bytecodes */
cl_env_ptr the_env = ecl_process_env();
cl_compiler_env_ptr old_c_env;
struct cl_compiler_env new_c_env;
cl_object bytecodes = ECL_NIL;
old_c_env = the_env->c_env;
c_new_env(the_env, &new_c_env, ECL_NIL, 0);
new_c_env.mode = FLAG_LOAD;
ECL_UNWIND_PROTECT_BEGIN(the_env) {
while (TRUE) {
cl_object position, form, source_location;
cl_index handle;
position = ecl_file_position(input);
form = cl_read(3, input, ECL_NIL, @':eof');
if (form == @':eof')
break;
source_location = ECL_SYM_VAL(the_env, @'ext::*source-location*');
if (source_location != ECL_NIL)
cl_rplacd(source_location, position);
handle = asm_begin(the_env);
compile_with_load_time_forms(the_env, form, FLAG_VALUES);
asm_op(the_env, OP_EXIT);
push(asm_end(the_env, handle, form), &bytecodes);
}
} ECL_UNWIND_PROTECT_EXIT {
c_restore_env(the_env, &new_c_env, old_c_env);
} ECL_UNWIND_PROTECT_END;
return cl_nreverse(bytecodes);
}
@(defun si::eval-with-env (form &optional (env ECL_NIL) (stepping ECL_NIL)
(compiler_env_p ECL_NIL) (mode @':execute'))
volatile cl_compiler_env_ptr old_c_env;
cl_compiler_env_ptr old_c_env;
struct cl_compiler_env new_c_env;
cl_object interpreter_env, compiler_env;
@
@ -3246,9 +3364,7 @@ si_make_lambda(cl_object name, cl_object rest)
the_env->nvalues = 1;
}
} ECL_UNWIND_PROTECT_EXIT {
/* Clear up */
the_env->c_env = old_c_env;
memset(&new_c_env, 0, sizeof(new_c_env));
c_restore_env(the_env, &new_c_env, old_c_env);
} ECL_UNWIND_PROTECT_END;
return the_env->values[0];
@)

1
src/c/symbols_list.h
View file

@ -1154,6 +1154,7 @@ cl_symbols[] = {
{SYS_ "ASET" ECL_FUN("si_aset", si_aset, -2) ECL_VAR(SI_ORDINARY, OBJNULL)},
{SYS_ "BASE-CHAR-P" ECL_FUN("si_base_char_p", si_base_char_p, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},
{SYS_ "BASE-STRING-P" ECL_FUN("si_base_string_p", si_base_string_p, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},
{SYS_ "BC-COMPILE-FROM-STREAM" ECL_FUN("si_bc_compile_from_stream", si_bc_compile_from_stream, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},
{SYS_ "BC-DISASSEMBLE" ECL_FUN("si_bc_disassemble", si_bc_disassemble, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},
{SYS_ "BC-SPLIT" ECL_FUN("si_bc_split", si_bc_split, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},
{SYS_ "BC-JOIN" ECL_FUN("si_bc_join", si_bc_join, 4) ECL_VAR(SI_ORDINARY, OBJNULL)},

4
src/doc/manual/standards/arrays.txi
View file

@ -114,7 +114,7 @@ Creating array and vectors
@cppdef ecl_alloc_simple_vector
@cppdef si_make_vector
@cppdef si_make_array
@deftypefun cl_object ecl_alloc_simple_vector (cl_elttype element_type, cl_index length);
@deftypefun cl_object ecl_alloc_simple_vector (cl_index length, cl_elttype element_type);
@deftypefunx cl_object si_make_vector (cl_object element_type, cl_object length, cl_object adjustablep, cl_object fill_pointerp, cl_object displaced_to, cl_object displacement);
@deftypefunx cl_object si_make_array (cl_object element_type, cl_object dimensions, cl_object adjustablep, cl_object fill_pointerp, cl_object displaced_to, cl_object displacement);
@ -136,7 +136,7 @@ Finally, the function @coderef{si_make_array} does a similar job to @coderef{si_
Create one-dimensional @code{base-string} with room for 11 characters:
@example
cl_object s = ecl_alloc_simple_vector(ecl_aet_bc, 11);
cl_object s = ecl_alloc_simple_vector(11, ecl_aet_bc);
@end example
Create a one-dimensional @code{array} with a fill pointer

2
src/h/external.h
View file

@ -531,6 +531,8 @@ extern ECL_API cl_object si_function_block_name(cl_object name);
extern ECL_API cl_object si_valid_function_name_p(cl_object name);
extern ECL_API cl_object si_process_declarations _ECL_ARGS((cl_narg narg, cl_object body, ...));
extern ECL_API cl_object si_bc_compile_from_stream (cl_object input);
extern ECL_API cl_object si_eval_with_env _ECL_ARGS((cl_narg narg, cl_object form, ...));
/* interpreter.c */

6
src/h/internal.h
View file

@ -113,6 +113,12 @@ struct cl_compiler_env {
cl_fixnum lexical_level; /* =0 if toplevel form */
cl_object constants; /* Constants for this form */
cl_object load_time_forms; /* Constants that have to be rebuilt */
cl_object ltf_being_created; /* Load time objects being compiled */
cl_object ltf_defer_init_until; /* Defer evaluation of current
* load time init form until
* this object has been created */
cl_object ltf_locations; /* Locations of constants externalized
* with make-load-form */
cl_object lex_env; /* Lexical env. for eval-when */
cl_object code_walker; /* Value of SI:*CODE-WALKER* */
cl_index env_depth;

8
src/tests/config.lsp.in
View file

@ -87,10 +87,14 @@
(progn
(ext:chdir *sandbox*)
(ext:setenv "TEST_IMAGE" *test-image*)
(ext:run-program *test-image*
(ext:run-program
*test-image*
`("-norc"
"-eval" "(print (ext:getenv \"ECLDIR\"))"
"-eval" "(ignore-errors (require :cmp))"
"-eval" "(ext:install-bytecodes-compiler)"
"-eval" ,(if (ext:getenv "BYTECMP")
"t"
"(ignore-errors (ext:install-c-compiler))")
"-load" ,(namestring
(merge-pathnames
"tests/doit.lsp" *ecl-sources*))

23
src/tests/normal-tests/compiler.lsp
View file

@ -757,7 +757,8 @@
(is (and (search "#1=(1 2 3 #<a CL-TEST::COMPILER-TEST-CLASS" str)
(search "> #1#)" str))))
(is (eq (compiler-test-parent a.0030) b.0030))
(is (eq (first (compiler-test-children b.0030)) a.0030)))
(is (eq (first (compiler-test-children b.0030)) a.0030))
(is (eq a.0030 c.0030)))
;;; Date: 9/06/2006 (Pascal Costanza)
;;; Fixed: 13/06/2006 (juanjo)
@ -1707,14 +1708,16 @@
;;; URL: https://gitlab.com/embeddable-common-lisp/ecl/-/issues/565
;;; Description
;;;
;;; COMPILE-FILE produces two vectors VV and VVtemp which
;;; represent the fasl data segment. The latter is deallocated
;;; after all top-level forms are evaluated. As compiler processes
;;; them currently if the object is first pushed to the temporary
;;; segment and then we try to add it to the permanent segment we
;;; have two versions of the same objects which are not EQ. File
;;; src/cmp/cmpwt.lsp has an appropriate FIXME in the ADD-OBJECT
;;; function definition.
;;; This test checks whether the same constant is coalesced to the EQ
;;; value among three distinct top-level forms.
;;;
;;; ccmp's COMPILE-FILE produces two vectors VV and VVtemp which represent
;;; the fasl data segment. The latter is deallocated after all top-level
;;; forms are evaluated. As compiler processes them currently if the
;;; object is first pushed to the temporary segment and then we try to add
;;; it to the permanent segment we have two versions of the same objects
;;; which are not EQ. File src/cmp/cmpwt.lsp has an appropriate FIXME in
;;; the ADD-OBJECT function definition.
(test cmp.0076.make-load-form-non-eq
(multiple-value-bind (file output)
(with-compiler ("make-temp.lsp")
@ -1745,8 +1748,6 @@
(delete-file file))
(multiple-value-bind (x a b) (foo)
(is (eq x a) "~a is not eq to ~a" x a)
;; This test passes because B toplevel form is compiled after the
;; function FOO. Included here for completness.
(is (eq x b) "~a is not eq to ~a" x b)
(is (eq a b) "~a is not eq to ~a" a b)))