Merge branch 'fix-562' into 'develop'

Compiler improvements

See merge request embeddable-common-lisp/ecl!190

src/c/compiler.d

@@ -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 =
+    push(cl_list(3, args, value, ECL_NIL), &c_env->load_time_forms);
-      ecl_cons(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),
+  push(cl_list(3, constant, make, init), &c_env->load_time_forms);
-                                    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);
         }
       }
     }

src/c/dpp.c

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

src/c/symbols_list.h

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

src/c/symbols_list2.h

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

src/clos/print.lsp

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

src/cmp/cmpglobals.lsp

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

src/cmp/cmputil.lsp

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

src/cmp/cmpwt.lsp

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

src/lsp/cmuutil.lsp

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

src/tests/2am.lisp

@@ -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"))
+                    (let ((fmt-ctrl
-                          (fmt-args (if args (cdr args) (list expected (type-of condition) condition))))
+                            (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"))

src/tests/ecl-tests.lisp

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

src/tests/normal-tests/compiler.lsp

@@ -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
+;;;     The detection of when a lisp constant has to be externalized
-;;;     breaks down with some circular structures
+;;;     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")
+      (with-compiler ("make-load-form.lsp")
-           "(in-package cl-test)"
+        "(in-package cl-test)"
-           "(eval-when (:compile-toplevel)
+        "(eval-when (:compile-toplevel)
-      (defvar s4 (make-instance 'compiler-test-class))
+      (defparameter s4.0030 (make-instance 'compiler-test-class))
-      (defvar s5 (make-instance 'compiler-test-class))
+      (defparameter s5.0030 (make-instance 'compiler-test-class))
-      (setf (compiler-test-parent s5) s4)
+      (setf (compiler-test-parent s5.0030) s4.0030)
-      (setf (compiler-test-children s4) (list s5)))"
+      (setf (compiler-test-children s4.0030) (list s5.0030)))"
-           "(defvar a '#.s5)"
+        "(defparameter a.0030 '#.s5.0030)"
-           "(defvar b '#.s4)"
+        "(defparameter b.0030 '#.s4.0030)"
-           "(defvar c '#.s5)"
+        "(defparameter c.0030 '#.s5.0030)"
-           "(defun foo ()
+        "(defun foo.0030 ()
        (let ((*print-circle* t))
-         (with-output-to-string (s) (princ '#1=(1 2 3 #.s4 #1#) s))))")))
+         (with-output-to-string (s) (princ '#1=(1 2 3 #.s4.0030 #1#) s))))")
-    (load output)
+    (declare (ignore output))
+    (load file)
     (delete-file "make-load-form.lsp")
-    (delete-file output))
+    (delete-file file))
-  (is-equal "#1=(1 2 3 #<a CL-TEST::COMPILER-TEST-CLASS> #1#)" (foo)))
+  (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)))))))
+