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

@@ -26,17 +26,17 @@
   (when (si::valid-function-name-p thing)
     (setq thing (fdefinition thing)))
   (cond ((null thing))
-	((functionp thing)
+        ((functionp thing)
-	 (si::bc-disassemble thing))
+         (si::bc-disassemble thing))
-	((and (consp thing)
+        ((and (consp thing)
               (member (car thing) '(LAMBDA 'EXT:LAMBDA-BLOCK)))
-	 (disassemble (compile nil thing)))
+         (disassemble (compile nil thing)))
-	(t
+        (t
-	 (error 'simple-type-error
+         (error 'simple-type-error
-		:datum thing
+                :datum thing
-		:expected-type '(OR FUNCTION (SATISFIES SI:VALID-FUNCTION-NAME-P))
+                :expected-type '(OR FUNCTION (SATISFIES SI:VALID-FUNCTION-NAME-P))
-		:format-control "DISASSEMBLE cannot accept ~A."
+                :format-control "DISASSEMBLE cannot accept ~A."
-		:format-arguments (list thing))))
+                :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
+                                        verbose print c-file h-file data-file
-				 shared-data-file system-p load external-format)
+                                        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
+                        &key
-			((:verbose *compile-verbose*) *compile-verbose*)
+                          ((:verbose *compile-verbose*) *compile-verbose*)
-			((:print *compile-print*) *compile-print*)
+                          ((:print *compile-print*) *compile-print*)
-			(load nil)
+                          (load nil)
-			(external-format :default)
+                          (external-format :default)
-			(output-file nil output-file-p)
+                          (output-file nil output-file-p)
-			&allow-other-keys &aux foo)
+                        &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)
+                               :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)
+             (sys:with-ecl-io-syntax
-			    until (eq form :EOF)
+                 (write binary :stream sout :circle t :escape t :readably t :pretty nil))
-			    do (when ext::*source-location*
+             (terpri sout)))))
-				 (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)))))
   (when load
     (load output-file :verbose *compile-verbose*))
   (values output-file nil nil))

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