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

bytecmp: preserve the identity for literal objects

Browse source 
When a literal appears in the file multiple times its identity should be
preserved.

CLHS 3.2.4.4:

> If two literal objects appearing in the source code for a single
> file processed with the file compiler are the identical, the
> corresponding objects in the compiled code must also be the identical.

Previously, every bytecode object created during ext::bc-compile-file
had its own vector of constants making it impossible to satisfy this
constraint. Thus, we change ext::bc-compile-file to use the same
constants vector for all bytecode objects from the same file. The
simplest way to achieve this is to use the same compiler environment
for all of the compilation process and push the read-compile loop
into the si_bc_compile_from_stream function implemented in C.
This commit is contained in:
Marius Gerbershagen 2020-08-13 16:29:28 +02:00
parent e5736d393a
commit b730412ebc
4 changed files with 69 additions and 35 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

61
contrib/bytecmp/bytecmp.lsp
View file

@ -26,17 +26,17 @@
(when (si::valid-function-name-p thing)
(setq thing (fdefinition thing)))
(cond ((null thing))
((functionp thing)
(si::bc-disassemble thing))
((and (consp thing)
((functionp thing)
(si::bc-disassemble thing))
((and (consp thing)
(member (car thing) '(LAMBDA 'EXT:LAMBDA-BLOCK)))
(disassemble (compile nil thing)))
(t
(error 'simple-type-error
:datum thing
:expected-type '(OR FUNCTION (SATISFIES SI:VALID-FUNCTION-NAME-P))
:format-control "DISASSEMBLE cannot accept ~A."
:format-arguments (list thing))))
(disassemble (compile nil thing)))
(t
(error 'simple-type-error
:datum thing
:expected-type '(OR FUNCTION (SATISFIES SI:VALID-FUNCTION-NAME-P))
:format-control "DISASSEMBLE cannot accept ~A."
:format-arguments (list thing))))
nil)
(defun bc-compile (name &optional (definition nil def-p) &aux (*print-pretty* nil))
@ -79,8 +79,8 @@
(return-from bc-compile (values name nil nil)))))
(defun bc-compile-file-pathname (name &key (output-file name) (type :fasl)
verbose print c-file h-file data-file
shared-data-file system-p load external-format)
verbose print c-file h-file data-file
shared-data-file system-p load external-format)
(declare (ignore load c-file h-file data-file shared-data-file system-p verbose print external-format))
(let ((extension "fasc"))
(case type
@ -89,13 +89,13 @@
(make-pathname :type extension :defaults output-file)))
(defun bc-compile-file (input
&key
((:verbose *compile-verbose*) *compile-verbose*)
((:print *compile-print*) *compile-print*)
(load nil)
(external-format :default)
(output-file nil output-file-p)
&allow-other-keys &aux foo)
&key
((:verbose *compile-verbose*) *compile-verbose*)
((:print *compile-print*) *compile-print*)
(load nil)
(external-format :default)
(output-file nil output-file-p)
&allow-other-keys &aux foo)
(setf output-file (if (and output-file-p (not (eql output-file t)))
(pathname output-file)
(bc-compile-file-pathname input)))
@ -112,20 +112,15 @@
(t
(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))))
(sys:with-ecl-io-syntax
(write binary :stream sout :circle t :escape t :readably t :pretty nil))
(terpri sout)))))
:external-format external-format)
(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)))))
(when load
(load output-file :verbose *compile-verbose*))
(values output-file nil nil))

40
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].
*/
@ -2708,7 +2708,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);
@ -3203,6 +3203,42 @@ si_make_lambda(cl_object name, cl_object rest)
@(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'))
cl_compiler_env_ptr old_c_env;

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)},

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 */