From 379254456ea9d86111e670a7fa89337b3686da88 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= <daniel@turtleware.eu>
Date: Sat, 21 Mar 2020 12:25:29 +0100
Subject: [PATCH] cmp: make-load-form: detect circular dependencies

Init forms are deferred when possible. This change solves two problems:

- init forms using uninitialized constant boxes
- make forms not signaling an error when circular

Partial fix for #562 (we need to fix bytecodes compiler too).
---
 src/cmp/cmpglobals.lsp |  3 +++
 src/cmp/cmputil.lsp    |  8 ++++++++
 src/cmp/cmpwt.lsp      | 34 +++++++++++++++++++++++++---------
 3 files changed, 36 insertions(+), 9 deletions(-)

diff --git a/src/cmp/cmpglobals.lsp b/src/cmp/cmpglobals.lsp
index 8ba09e7d1..60b86cca2 100644
--- a/src/cmp/cmpglobals.lsp
+++ b/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 )
diff --git a/src/cmp/cmputil.lsp b/src/cmp/cmputil.lsp
index 064c1284b..03386388a 100644
--- a/src/cmp/cmputil.lsp
+++ b/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
diff --git a/src/cmp/cmpwt.lsp b/src/cmp/cmpwt.lsp
index 6b9d73bc6..5930b1644 100644
--- a/src/cmp/cmpwt.lsp
+++ b/src/cmp/cmpwt.lsp
@@ -155,15 +155,29 @@
   (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*)
-        (multiple-value-bind (make-form init-form) (make-load-form object)
-          (setf (gethash object *load-objects*) location)
-          (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*))))))
+  (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
+        (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)
@@ -197,6 +211,8 @@
                       (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