From b20a675f64540e7cc977ae097c92fd0c2504042d Mon Sep 17 00:00:00 2001 From: Marius Gerbershagen Date: Fri, 18 Sep 2020 21:30:50 +0200 Subject: [PATCH 01/10] tests: compiler: improve make-load-form tests Also check for identical objects in CMP.0030.MAKE-LOAD-FORM Be more aware of the bcmp in the test CMP.0076.MAKE-LOAD-FORM-NON-EQ - bytecmp fails the test in a different manner, so remove the remark that a part of the test pass, and change the description to 1) explain the test, 2) explain the ccmp's failure mode. --- src/tests/normal-tests/compiler.lsp | 35 +++++++++++++++-------------- 1 file changed, 18 insertions(+), 17 deletions(-) diff --git a/src/tests/normal-tests/compiler.lsp b/src/tests/normal-tests/compiler.lsp index aafc150f0..500253e10 100644 --- a/src/tests/normal-tests/compiler.lsp +++ b/src/tests/normal-tests/compiler.lsp @@ -739,16 +739,16 @@ (with-compiler ("make-load-form.lsp") "(in-package cl-test)" "(eval-when (:compile-toplevel) - (defparameter s4.0030 (make-instance 'compiler-test-class)) - (defparameter s5.0030 (make-instance 'compiler-test-class)) - (setf (compiler-test-parent s5.0030) s4.0030) - (setf (compiler-test-children s4.0030) (list s5.0030)))" + (defparameter s4.0030 (make-instance 'compiler-test-class)) + (defparameter s5.0030 (make-instance 'compiler-test-class)) + (setf (compiler-test-parent s5.0030) s4.0030) + (setf (compiler-test-children s4.0030) (list s5.0030)))" "(defparameter a.0030 '#.s5.0030)" "(defparameter b.0030 '#.s4.0030)" "(defparameter c.0030 '#.s5.0030)" "(defun foo.0030 () - (let ((*print-circle* t)) - (with-output-to-string (s) (princ '#1=(1 2 3 #.s4.0030 #1#) s))))") + (let ((*print-circle* t)) + (with-output-to-string (s) (princ '#1=(1 2 3 #.s4.0030 #1#) s))))") (declare (ignore output)) (load file) (delete-file "make-load-form.lsp") @@ -757,7 +757,8 @@ (is (and (search "#1=(1 2 3 # #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))) From 1a6807170a1ee5ced823425111b050507f9c5f51 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 15 Dec 2020 19:44:44 +0100 Subject: [PATCH 02/10] tests: improve config.lsp to allow testing bytecmp via make check Even when the C compiler is present. Also first install the bytecodes compiler and then eventually try install the C compiler - that's because ASDF depends on the :bytecmp feature to work with the bytecompiler. --- src/tests/config.lsp.in | 30 +++++++++++++++++------------- 1 file changed, 17 insertions(+), 13 deletions(-) diff --git a/src/tests/config.lsp.in b/src/tests/config.lsp.in index 13b6b5715..6d5e91c51 100755 --- a/src/tests/config.lsp.in +++ b/src/tests/config.lsp.in @@ -87,19 +87,23 @@ (progn (ext:chdir *sandbox*) (ext:setenv "TEST_IMAGE" *test-image*) - (ext:run-program *test-image* - `("-norc" - "-eval" "(print (ext:getenv \"ECLDIR\"))" - "-eval" "(ignore-errors (require :cmp))" - "-load" ,(namestring - (merge-pathnames - "tests/doit.lsp" *ecl-sources*)) - "-eval" "(in-package cl-test)" - "-eval" ,(format nil "(2am-ecl:run '~a)" suites) - "-eval" "(ext:exit)") - :input nil - :output t - :error :output)) + (ext:run-program + *test-image* + `("-norc" + "-eval" "(print (ext:getenv \"ECLDIR\"))" + "-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*)) + "-eval" "(in-package cl-test)" + "-eval" ,(format nil "(2am-ecl:run '~a)" suites) + "-eval" "(ext:exit)") + :input nil + :output t + :error :output)) (ext:chdir *here*) #+ (or) (format t "~%Known fails: ~%~{~a~%~}~%" From 4460a8c7f1ad9c85c1fae570d86fa65fdaa9e7fe Mon Sep 17 00:00:00 2001 From: Marius Gerbershagen Date: Wed, 12 Aug 2020 15:37:09 +0200 Subject: [PATCH 03/10] doc: fix argument order for ecl_alloc_simple_vector --- src/doc/manual/standards/arrays.txi | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/doc/manual/standards/arrays.txi b/src/doc/manual/standards/arrays.txi index e158b5ba0..184ce0e01 100644 --- a/src/doc/manual/standards/arrays.txi +++ b/src/doc/manual/standards/arrays.txi @@ -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 From c18b6d6967bae545d502e94ffc83a91526b080a6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 18 Dec 2020 17:28:44 +0100 Subject: [PATCH 04/10] bytecmp: represent bytecodes as a lisp vector Previously they were passed as an index array, now they are a simple vector (the cl_object). --- src/c/compiler.d | 22 +++++++++------------- 1 file changed, 9 insertions(+), 13 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index 8d731e790..46cea6cb1 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -2420,29 +2420,25 @@ 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); } @@ -2461,7 +2457,7 @@ compile_with_load_time_forms(cl_env_ptr env, cl_object form, int flags) * code _before_ the actual forms; */ if (c_env->load_time_forms != ECL_NIL) { - cl_index *bytecodes = save_bytecodes(env, handle, current_pc(env)); + cl_object 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); From be46fc0caa1630b717e37fed09ef267c442ed026 Mon Sep 17 00:00:00 2001 From: Marius Gerbershagen Date: Sun, 27 Dec 2020 18:58:43 +0100 Subject: [PATCH 05/10] bytecmp: factor out c_restore_env (used together with c_new_env) --- src/c/compiler.d | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index 46cea6cb1..222a22eb9 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -568,6 +568,12 @@ 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) +{ + 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) { @@ -3139,7 +3145,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); @@ -3183,21 +3189,21 @@ 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); } @(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; @ @@ -3242,9 +3248,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]; @) From e5736d393a55b94ae05fb8c09c5b5e6e44b21e85 Mon Sep 17 00:00:00 2001 From: Marius Gerbershagen Date: Sun, 2 Aug 2020 19:09:56 +0200 Subject: [PATCH 06/10] bytecmp: don't treat load time forms as toplevel forms This prevents top level forms from being evaluated in the middle of another top level form. --- src/c/compiler.d | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/c/compiler.d b/src/c/compiler.d index 222a22eb9..a7053f7be 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -2469,6 +2469,7 @@ compile_with_load_time_forms(cl_env_ptr env, cl_object form, int flags) cl_object p, forms_list = cl_nreverse(c_env->load_time_forms); c_env->load_time_forms = ECL_NIL; p = forms_list; + c_env->lexical_level++; /* don't treat load time forms as toplevel forms */ do { cl_object r = ECL_CONS_CAR(p); cl_object constant = pop(&r); @@ -2481,6 +2482,7 @@ compile_with_load_time_forms(cl_env_ptr env, cl_object form, int flags) ECL_RPLACA(p, ecl_make_fixnum(loc)); p = ECL_CONS_CDR(p); } while (p != ECL_NIL); + c_env->lexical_level--; p = forms_list; do { cl_index loc = ecl_fixnum(ECL_CONS_CAR(p)); From b730412ebcd7c9e05725ea14b89f0c73b54be61a Mon Sep 17 00:00:00 2001 From: Marius Gerbershagen Date: Thu, 13 Aug 2020 16:29:28 +0200 Subject: [PATCH 07/10] 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 | 61 +++++++++++++++++-------------------- src/c/compiler.d | 40 ++++++++++++++++++++++-- src/c/symbols_list.h | 1 + src/h/external.h | 2 ++ 4 files changed, 69 insertions(+), 35 deletions(-) diff --git a/contrib/bytecmp/bytecmp.lsp b/contrib/bytecmp/bytecmp.lsp index 1f55ff13e..86bebbae1 100755 --- a/contrib/bytecmp/bytecmp.lsp +++ b/contrib/bytecmp/bytecmp.lsp @@ -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)) diff --git a/src/c/compiler.d b/src/c/compiler.d index a7053f7be..70a5d2d4f 100644 --- a/src/c/compiler.d +++ b/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; diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index e714b7058..4666ba636 100755 --- a/src/c/symbols_list.h +++ b/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)}, diff --git a/src/h/external.h b/src/h/external.h index 3392fd57b..33aba4bad 100755 --- a/src/h/external.h +++ b/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 */ From 3cec96739d58a39e39508986f65998da1fd0a918 Mon Sep 17 00:00:00 2001 From: Marius Gerbershagen Date: Sun, 27 Dec 2020 18:58:01 +0100 Subject: [PATCH 08/10] bytecmp: fix evaluation order of load time forms We need to defer initialization forms until all dependent creation forms have been compiled (see CLHS make-load-form). Closes #562. Co-authored-by: Marius Gerbershagen --- src/c/compiler.d | 148 +++++++++++++++++++++++++++++++++++------------ src/h/internal.h | 6 ++ 2 files changed, 117 insertions(+), 37 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index 70a5d2d4f..5aee13353 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -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_NIL; + new->ltf_locations = ECL_NIL; new->env_depth = 0; new->macros = CDR(env); new->variables = CAR(env); @@ -571,6 +574,13 @@ c_new_env(cl_env_ptr the_env, cl_compiler_env_ptr new, cl_object env, 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; } @@ -2204,17 +2214,35 @@ 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 (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) - return; - if (c_search_constant(env, constant) >= 0) - return; - if (si_need_to_make_load_form_p(constant) == ECL_NIL) + cl_object init, make, created; + if ((c_env->mode != FLAG_LOAD) + || (si_need_to_make_load_form_p(constant) == ECL_NIL)) return; + 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); @@ -2382,6 +2410,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_NIL; + 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; @@ -2449,47 +2480,90 @@ restore_bytecodes(cl_env_ptr env, cl_object bytecodes) 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) { + /* 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)); - /* 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); + cl_object p = cl_nreverse(c_env->load_time_forms); c_env->load_time_forms = ECL_NIL; - p = forms_list; - c_env->lexical_level++; /* don't treat load time forms as toplevel forms */ - 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); + c_env->lexical_level++; + loop_for_in(p) { + add_load_form(env, ECL_CONS_CAR(p)); + } end_loop_for_in; c_env->lexical_level--; - 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); restore_bytecodes(env, bytecodes); } return output_flags; diff --git a/src/h/internal.h b/src/h/internal.h index 4019daccd..19a47486f 100755 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -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; From 32704f8cf5f99e14072e8f14128ede145752dac9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 23 Dec 2020 09:12:52 +0100 Subject: [PATCH 09/10] bytecmp: error when make-load-form has a circular dependency --- src/c/compiler.d | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index 5aee13353..c68fead46 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -550,7 +550,7 @@ c_new_env(cl_env_ptr the_env, cl_compiler_env_ptr new, cl_object env, new->lexical_level = 0; new->load_time_forms = ECL_NIL; new->ltf_being_created = ECL_NIL; - new->ltf_defer_init_until = ECL_NIL; + new->ltf_defer_init_until = ECL_T; new->ltf_locations = ECL_NIL; new->env_depth = 0; new->macros = CDR(env); @@ -2218,7 +2218,11 @@ 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 (ecl_member_eq(c_env->ltf_defer_init_until, created)) { + 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; } @@ -2411,7 +2415,7 @@ eval_nontrivial_form(cl_env_ptr env, cl_object form) { 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_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; From 0ddcc9a5f3e15bcc0f1515d293b04ed22bf39f93 Mon Sep 17 00:00:00 2001 From: Marius Gerbershagen Date: Sun, 27 Dec 2020 19:28:29 +0100 Subject: [PATCH 10/10] update CHANGELOG --- CHANGELOG | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index 70cf4ca4c..f6795b939 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -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