mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2025-12-06 02:40:26 -08:00
Code Issues Projects Releases Packages Wiki Activity

Merge branch 'fix-562' into 'develop'

Browse source 
Compiler improvements

See merge request embeddable-common-lisp/ecl!190
This commit is contained in:
Daniel Kochmański 2020-03-28 08:16:53 +00:00
commit fa24f95f7b
12 changed files with 317 additions and 90 deletions
Download patch file Download diff file Expand all files Collapse all files

24
src/c/compiler.d
View file

@ -154,6 +154,15 @@ pop_maybe_nil(cl_object *l) {
return head;
}
static cl_object
push(cl_object v, cl_object *l) {
cl_object list = *l;
unlikely_if (!ECL_LISTP(list))
FEill_formed_input();
*l = ecl_cons(v, *l);
return *l;
}
/* ------------------------------ ASSEMBLER ------------------------------ */
static cl_object
@ -1310,7 +1319,7 @@ c_register_functions(cl_env_ptr env, cl_object l)
static int
c_labels_flet(cl_env_ptr env, int op, cl_object args, int flags) {
#define push(v,l) { cl_object c = *l = CONS(v, *l); l = &ECL_CONS_CDR(c); }
#define push_back(v,l) { cl_object c = *l = CONS(v, *l); l = &ECL_CONS_CDR(c); }
cl_object l, def_list = pop(&args);
cl_object old_vars = env->c_env->variables;
cl_object old_funs = env->c_env->macros;
@ -1331,7 +1340,7 @@ c_labels_flet(cl_env_ptr env, int op, cl_object args, int flags) {
FEprogram_error
("~s: The function ~s was already defined.",
2, (op == OP_LABELS ? @'LABELS' : @'FLET'), v);
push(v, f);
push_back(v, f);
}
/* If compiling a LABELS form, add the function names to the lexical
@ -1626,9 +1635,7 @@ c_load_time_value(cl_env_ptr env, cl_object args, int flags)
} else if (ECL_SYMBOLP(value) || ECL_LISTP(value)) {
/* Using the form as constant, we force the system to coalesce multiple
* copies of the same load-time-value form */
c_env->load_time_forms =
ecl_cons(cl_list(3, args, value, ECL_NIL),
c_env->load_time_forms);
push(cl_list(3, args, value, ECL_NIL), &c_env->load_time_forms);
value = args;
}
return compile_constant(env, value, flags);
@ -2232,8 +2239,7 @@ maybe_make_load_forms(cl_env_ptr env, cl_object constant)
return;
make = _ecl_funcall2(@'make-load-form', constant);
init = (env->nvalues > 1)? env->values[1] : ECL_NIL;
c_env->load_time_forms = ecl_cons(cl_list(3, constant, make, init),
c_env->load_time_forms);
push(cl_list(3, constant, make, init), &c_env->load_time_forms);
}
static int
@ -2681,12 +2687,12 @@ c_listA(cl_env_ptr env, cl_object args, int flags)
}
for (form = ECL_CONS_CDR(form); !Null(form); ) {
cl_object sentence = pop(&form);
declarations = ecl_cons(sentence, declarations);
push(sentence, &declarations);
if (pop(&sentence) == @'special') {
while (!Null(sentence)) {
cl_object v = pop(&sentence);
assert_type_symbol(v);
specials = ecl_cons(v, specials);
specials = push(v, &specials);
}
}
}

24
src/c/dpp.c
View file

@ -351,6 +351,20 @@ read_symbol(int code)
return name;
}
char *
read_string()
{
char c, *str = poolp;
char end = '"';
pushstr("ecl_make_constant_base_string(\"");
do {
c = readc();
pushc(c);
} while (c != end);
pushstr(", -1)\0");
return str;
}
char *
search_function(char *name)
{
@ -441,6 +455,9 @@ read_token(void)
poolp--;
} else if (c == '@') {
pushc(c);
} else if (c == '"') {
read_string();
poolp--;
} else {
char *name;
unreadc(c);
@ -933,6 +950,13 @@ main_loop(void)
fprintf(out,"%s",p);
poolp = tmp;
goto LOOP;
} else if (c == '"') {
char *p;
char * tmp = poolp;
p = read_string();
fprintf(out,"%s",p);
poolp = tmp;
goto LOOP;
} else if (c != '(') {
char *p;
char * tmp = poolp;

3
src/c/symbols_list.h
View file

@ -1994,6 +1994,9 @@ cl_symbols[] = {
{EXT_ "WITH-UNIQUE-NAMES", EXT_ORDINARY, NULL, -1, OBJNULL},
{EXT_ "WITH-GENSYMS", EXT_ORDINARY, NULL, -1, OBJNULL},
{EXT_ "WITH-CLEAN-SYMBOLS", EXT_ORDINARY, NULL, -1, OBJNULL},
{EXT_ "IF-LET", EXT_ORDINARY, NULL, -1, OBJNULL},
{EXT_ "WHEN-LET", EXT_ORDINARY, NULL, -1, OBJNULL},
{EXT_ "WHEN-LET*", EXT_ORDINARY, NULL, -1, OBJNULL},
{SYS_ "HANDLE-SIGNAL", SI_ORDINARY, si_handle_signal, 2, OBJNULL},

3
src/c/symbols_list2.h
View file

@ -1994,6 +1994,9 @@ cl_symbols[] = {
{EXT_ "WITH-UNIQUE-NAMES",NULL,-1},
{EXT_ "WITH-GENSYMS",NULL,-1},
{EXT_ "WITH-CLEAN-SYMBOLS",NULL,-1},
{EXT_ "IF-LET",NULL,-1},
{EXT_ "WHEN-LET",NULL,-1},
{EXT_ "WHEN-LET*",NULL,-1},
{SYS_ "HANDLE-SIGNAL","si_handle_signal",2},

6
src/clos/print.lsp
View file

@ -128,8 +128,10 @@ printer and we should rather use MAKE-LOAD-FORM."
x))))
(and init-forms `(progn ,@init-forms)))))
(cons
(values `(cons ,(maybe-quote (car object)) nil)
(and (rest object) `(rplacd ,(maybe-quote object)
(values `(cons nil nil)
`(progn (rplaca ,(maybe-quote object)
,(maybe-quote (car object)))
(rplacd ,(maybe-quote object)
,(maybe-quote (cdr object))))))
(hash-table
(let* ((content (ext:hash-table-content object))

3
src/cmp/cmpglobals.lsp
View file

@ -268,6 +268,9 @@ lines are inserted, but the order is preserved")
(defvar *top-level-forms* nil) ; holds { top-level-form }*
(defvar *make-forms* nil) ; holds { top-level-form }*
(defvar *objects-being-created* nil) ; helps detecting circular references
(defvar *objects-init-deferred* nil) ; helps avoiding circularity
;;;
;;; top-level-form:
;;; ( 'DEFUN' fun-name cfun lambda-expr doc-vv sp )

8
src/cmp/cmputil.lsp
View file

@ -134,6 +134,14 @@
Compiler assumes it is a global."
(slot-value c 'variable)))))
(define-condition circular-dependency (compiler-error)
()
(:report
(lambda (c stream)
(compiler-message-report stream c
"Circular references in creation form for ~S."
(compiler-message-form c)))))
(defun print-compiler-message (c stream)
(unless (typep c *suppress-compiler-messages*)
#+cmu-format

123
src/cmp/cmpwt.lsp
View file

@ -155,60 +155,85 @@
(add-object 0 :duplicate t :permanent t))
(defun add-load-form (object location)
(when (clos::need-to-make-load-form-p object *cmp-env*)
(if (not (eq *compiler-phase* 't1))
(cmperr "Unable to internalize complex object ~A in ~a phase" object *compiler-phase*)
(unless (clos::need-to-make-load-form-p object *cmp-env*)
(return-from add-load-form))
(unless (eq *compiler-phase* 't1)
(cmperr "Unable to internalize complex object ~A in ~a phase." object *compiler-phase*))
(multiple-value-bind (make-form init-form) (make-load-form object)
(setf (gethash object *load-objects*) location)
(let (deferred)
(when make-form
(push (make-c1form* 'MAKE-FORM :args location (c1expr make-form)) *make-forms*))
(when init-form
(push (make-c1form* 'INIT-FORM :args location (c1expr init-form)) *make-forms*))))))
(let ((*objects-init-deferred* nil)
(*objects-being-created* (list* object *objects-being-created*)))
(push (make-c1form* 'MAKE-FORM :args location (c1expr make-form)) *make-forms*)
(setf deferred (nreverse *objects-init-deferred*))))
(flet ((maybe-init (loc init)
(handler-case
(push (make-c1form* 'INIT-FORM :args loc (c1expr init)) *make-forms*)
(circular-dependency (c)
(if *objects-being-created*
(push (cons location init-form) *objects-init-deferred*)
(error c))))))
(loop for (loc . init) in deferred
do (maybe-init loc init)
finally (when init-form
(maybe-init location init-form)))))))
(defun add-object (object &key (duplicate nil)
(permanent (or (symbolp object) *permanent-data*))
(used-p nil))
;; FIXME! Currently we have two data vectors and, when compiling
;; files, it may happen that a constant is duplicated and stored
;; both in VV and VVtemp. This would not be a problem if the
;; constant were readable, but due to using MAKE-LOAD-FORM we may
;; end up having two non-EQ objects created for the same value.
(defun add-object (object &key
(duplicate nil)
(used-p nil)
(permanent (or (symbolp object)
*permanent-data*)))
(when-let ((vv (add-static-constant object)))
(when used-p
(setf (vv-used-p vv) t))
(return-from add-object vv))
(let* ((test (if *compiler-constants* 'eq 'equal))
(array (if permanent *permanent-objects* *temporary-objects*))
(x (or (and (not permanent)
(find object *permanent-objects* :test test
:key #'first))
(find object array :test test :key #'first)))
(next-ndx (length array))
(forced duplicate)
found)
(setq x
(cond ((add-static-constant object))
((and x duplicate)
(setq x (make-vv :location next-ndx :used-p forced
(item (if permanent
;; FIXME! Currently we have two data vectors and,
;; when compiling files, it may happen that a
;; constant is duplicated and stored both in VV
;; and VVtemp. This would not be a problem if the
;; constant were readable, but due to using
;; MAKE-LOAD-FORM we may end up having two non-EQ
;; objects created for the same value.
(find object *permanent-objects* :test test :key #'first)
(or (find object *permanent-objects* :test test :key #'first)
(find object *temporary-objects* :test test :key #'first))))
(array (if permanent
*permanent-objects*
*temporary-objects*))
(vv (cond ((and item duplicate)
(let* ((ndx (length array))
(vv (make-vv :location ndx
:permanent-p permanent
:value object
:used-p t))
(vector-push-extend (list object x next-ndx) array)
x)
(x
(second x))
((and (not duplicate)
(symbolp object)
(multiple-value-setq (found x) (si::mangle-name object)))
x)
:value object)))
(vector-push-extend (list object vv ndx) array)
vv))
(item
(when (member object *objects-being-created*)
(error 'circular-dependency :form object))
(second item))
;; FIXME! all other branches return VV instance
;; while this branch returns a STRING making the
;; function return value inconsistent.
((and (not item) (not duplicate) (symbolp object)
(multiple-value-bind (foundp symbol)
(si::mangle-name object)
(and foundp
(return-from add-object symbol)))))
(t
(setq x (make-vv :location next-ndx :used-p forced
(let* ((ndx (length array))
(vv (make-vv :location ndx
:permanent-p permanent
:value object
:used-p used-p))
(vector-push-extend (list object x next-ndx) array)
:value object)))
(vector-push-extend (list object vv ndx) array)
(unless *compiler-constants*
(add-load-form object x))
x)))
(when (and used-p (typep x 'vv))
(setf (vv-used-p x) t))
x))
(add-load-form object vv))
vv)))))
(when (or duplicate used-p)
(setf (vv-used-p vv) t))
vv))
(defun add-symbol (symbol)
(add-object symbol :duplicate nil :permanent t))
@ -347,10 +372,10 @@
#+msvc
nil
#-msvc
;; FIXME! The Microsoft compiler does not allow static initialization of bit fields.
;; SSE uses always unboxed static constants. No reference
;; is kept to them -- it is thus safe to use them even on code
;; that might be unloaded.
;; FIXME! The MSVC compiler does not allow static initialization of
;; bit fields. SSE uses always unboxed static constants. No
;; reference is kept to them -- it is thus safe to use them even on
;; code that might be unloaded.
(unless (or *compiler-constants*
(and (not *use-static-constants-p*)
#+sse2

30
src/lsp/cmuutil.lsp
View file

@ -194,3 +194,33 @@ ones, which is useful for creating hygienic macros."
(cons s (make-symbol (symbol-name s))))
symbols)
body)))
;;; Curbed from alexandria
(defmacro if-let (bindings &body (then-form &optional else-form))
(let* ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
(list bindings)
bindings))
(variables (mapcar #'car binding-list)))
`(let ,binding-list
(if (and ,@variables)
,then-form
,else-form))))
(defmacro when-let (bindings &body forms)
`(if-let ,bindings
(progn ,@forms)))
(defmacro when-let* (bindings &body body)
(let ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
(list bindings)
bindings)))
(labels ((bind (bindings body)
(if bindings
`((let (,(car bindings))
(when ,(caar bindings)
,@(bind (cdr bindings) body))))
body)))
`(let (,(car binding-list))
(when ,(caar binding-list)
,@(bind (cdr binding-list) body))))))

15
src/tests/2am.lisp
View file

@ -185,14 +185,21 @@
(flet ((handler (condition)
(cond ((typep condition expected)
(return-from %signals (passed)))
(t
((typep condition 'serious-condition)
(return-from %signals
(let ((fmt-ctrl (if args (car args) "Expected to signal ~s, but got ~s:~%~a"))
(fmt-args (if args (cdr args) (list expected (type-of condition) condition))))
(let ((fmt-ctrl
(if args
(car args)
"Expected to signal ~s, but got ~s:~%~a"))
(fmt-args
(if args
(cdr args)
(list expected (type-of condition) condition))))
(failed (make-condition 'test-failure
:name *test-name*
:format-control fmt-ctrl
:format-arguments fmt-args))))))))
:format-arguments fmt-args)))))
(t #|ignore non-serious unexpected conditions|#))))
(handler-bind ((condition #'handler))
(funcall fn)))
(let ((fmt-ctrl (if args (car args) "Expected to signal ~s, but got nothing"))

3
src/tests/ecl-tests.lisp
View file

@ -107,6 +107,9 @@ as a second value."
;; (when delete-files
;; (delete-file filename)
;; (delete-file compiled-file))
(when (null compiled-file)
(delete-file ,filename)
(error "Compiling file ~a failed:~%~a" ,filename output))
(values compiled-file output))))
(defmacro with-temporary-file ((var string &rest args) &body body)

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

@ -631,8 +631,8 @@
;;; Fixed: 18/05/2006 (juanjo)
;;; Description:
;;;
;;; The detection of when a lisp constant has to be externalized using MAKE-LOAD-FORM
;;; breaks down with some circular structures
;;; The detection of when a lisp constant has to be externalized
;;; using MAKE-LOAD-FORM breaks down with some circular structures
;;;
(defclass compiler-test-class ()
((parent :accessor compiler-test-parent :initform nil)
@ -666,25 +666,35 @@
;;; printed representation. In that case MAKE-LOAD-FORM should be
;;; used.
;;;
;;;
;;; Date: 2020-02-12
;;; URL: https://gitlab.com/embeddable-common-lisp/ecl/issues/562
;;; Description:
;;;
;;; Circular structures are not properly initialized because make
;;; and init form order of evaluation is not always correct.
(test cmp.0030.make-load-form
(let ((output
(multiple-value-bind (file output)
(with-compiler ("make-load-form.lsp")
"(in-package cl-test)"
"(eval-when (:compile-toplevel)
(defvar s4 (make-instance 'compiler-test-class))
(defvar s5 (make-instance 'compiler-test-class))
(setf (compiler-test-parent s5) s4)
(setf (compiler-test-children s4) (list s5)))"
"(defvar a '#.s5)"
"(defvar b '#.s4)"
"(defvar c '#.s5)"
"(defun foo ()
(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 #1#) s))))")))
(load output)
(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")
(delete-file output))
(is-equal "#1=(1 2 3 #<a CL-TEST::COMPILER-TEST-CLASS> #1#)" (foo)))
(delete-file file))
(is-equal "#1=(1 2 3 #<a CL-TEST::COMPILER-TEST-CLASS> #1#)" (foo.0030))
(is (eq (compiler-test-parent a.0030) b.0030))
(is (eq (first (compiler-test-children b.0030)) a.0030)))
;;; Date: 9/06/2006 (Pascal Costanza)
;;; Fixed: 13/06/2006 (juanjo)
@ -1629,3 +1639,106 @@
3)))
(is (eq result 4))
(is (eq (funcall *function*) 4)))))
;;; Date 2020-03-13
;;; 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.
(test cmp.0076.make-load-form-non-eq
(multiple-value-bind (file output)
(with-compiler ("make-temp.lsp")
"(in-package #:cl-test)"
"(eval-when (:compile-toplevel :load-toplevel :execute)
(defclass my-class ()
((name :initarg :name :accessor name)))
(defmethod print-object ((obj my-class) stream)
(print-unreadable-object (obj stream :identity t)
(format stream \"~s ~s\" (name obj) (class-name (class-of obj)))))
(defmethod make-load-form ((x my-class) &optional environment)
(declare (ignore environment))
`(make-instance ',(class-of x) :name ',(slot-value x 'name))))"
"(eval-when (:compile-toplevel)
(defparameter s4 (make-instance 'my-class :name :s4)))"
"(defparameter *s4-a* nil)"
"(defparameter *s4-b* nil)"
"(let ((a '#.s4))
(setf *s4-a* a))"
"(defun foo ()
(let ((x #.s4))
(values x *s4-a* *s4-b*)))"
"(let ((b '#.s4))
(setf *s4-b* b))")
(declare (ignore output))
(load file)
(delete-file "make-temp.lsp")
(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)))
(ext:with-clean-symbols (class)
(test cmp.0077.make-load-form.circular-dep
(macrolet ((make-template (&body extra)
`(with-compiler ("make-circle.lsp")
'(progn
(in-package #:cl-test)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defclass class ()
((peer :initform nil :initarg :peer :accessor peer)
(peer* :initform nil :initarg :peer* :accessor peer*)))
(defmethod make-load-form ((x class) &optional env)
(declare (ignore env))
(values `(make-instance 'class :peer ',(peer x))
`(setf (peer* ',x) ',(peer* x)))))
(eval-when (:compile-toplevel)
(defparameter var1 (make-instance 'class))
(defparameter var2 (make-instance 'class :peer var1))
,@extra))
"(defun foo () (values '#.var1 '#.var2))")))
;; Ordinary case (reference).
(multiple-value-bind (file output)
(make-template)
(load file)
(delete-file "make-circle.lsp")
(delete-file file)
(multiple-value-bind (v1 v2) (foo)
(is (eq (peer v2) v1))))
;; Circularity between make forms (should signal an error).
(signals error
(unwind-protect (multiple-value-bind (file output)
(make-template (setf (peer var1) var2))
(when file (delete-file file)))
(delete-file "make-circle.lsp"))
"Successfully compiled a file with a circular dependency.")
;; Circularity between make and init forms (is not an error!).
(multiple-value-bind (file output)
(make-template (setf (peer* var1) var2))
(load file)
(delete-file "make-circle.lsp")
(delete-file file)
(multiple-value-bind (v1 v2) (foo)
(is (eq (peer v2) v1))
(is (eq (peer* v1) v2))))
;; Circularity between init forms (is not an error!).
(multiple-value-bind (file output)
(make-template (setf (peer* var1) var2)
(setf (peer* var2) var1))
(load file)
(delete-file "make-circle.lsp")
(delete-file file)
(multiple-value-bind (v1 v2) (foo)
(is (eq (peer v2) v1))
(is (eq (peer* v1) v2))
(is (eq (peer* v2) v1)))))))