bytecmp: preserve the identity for literal objects

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.

contrib/bytecmp/bytecmp.lsp

@@ -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
+           (let ((binary
-			    with *package* = *package*
+                  (let ((*package* *package*)
-			    with *readtable* = *readtable*
+                        (*readtable* *readtable*)
-			    with ext:*bytecodes-compiler* = t
+                        (ext:*bytecodes-compiler* t))
-			    for position = (file-position input)
+                    (si::bc-compile-from-stream 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)))))

src/c/compiler.d

@@ -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;

src/c/symbols_list.h

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

src/h/external.h

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