From: Taylor R Campbell <campbell@mumble.net>
Date: Thu, 3 Jan 2019 07:17:32 +0000 (+0000)
Subject: Use another indirection for representation of promises.
X-Git-Tag: mit-scheme-pucked-10.1.9~3^2~30
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=4e246161076d4a2e3f9ff5f9e72dcca30a8013e5;p=mit-scheme.git

Use another indirection for representation of promises.

The pairs never change, so merely loading the pair object from the
cell indirection gives us an atomic snapshot of it.  This way, there
is no need for without-interrupts in promise-forced?.

This makes each promise cost one more word (previously: one word to
represent plus three words of heap space; now one word to represent
plus four words of heap space), but reducing without-interrupts is a
big win -- this halves the time of test-promise.scm on my machine.

Of course, on a parallel system, the without-interrupts in %force is
still not enough (and we'll need the cell-contentses to be
load-acquire operations, not just loads).
---

diff --git a/src/runtime/boot.scm b/src/runtime/boot.scm
index 33a226a8e..86e465989 100644
--- a/src/runtime/boot.scm
+++ b/src/runtime/boot.scm
@@ -433,25 +433,25 @@ USA.
 
 (define (promise? object)
   (and (cell? object)
-       (object-type? (ucode-type delayed) (cell-contents object))))
+       (cell? (cell-contents object))
+       (object-type? (ucode-type delayed)
+		     (cell-contents (cell-contents object)))))
 
 (define (make-promise object)
-  (make-cell (system-pair-cons (ucode-type delayed) #t object)))
+  (make-cell (make-cell (system-pair-cons (ucode-type delayed) #t object))))
 
 (define (make-unforced-promise thunk)
   ;(guarantee thunk? thunk 'make-unforced-promise)
-  (make-cell (system-pair-cons (ucode-type delayed) #f thunk)))
+  (make-cell (make-cell (system-pair-cons (ucode-type delayed) #f thunk))))
 
 (define (%promise-parts promise)
-  (without-interrupts
-   (lambda ()
-     (let ((p (cell-contents promise)))
-       (values (system-pair-car p)
-	       (system-pair-cdr p))))))
+  (let ((p (cell-contents (cell-contents promise))))
+    (values (system-pair-car p)
+	    (system-pair-cdr p))))
 
 (define (promise-forced? promise)
   (guarantee promise? promise 'promise-forced?)
-  (system-pair-car (cell-contents promise)))
+  (system-pair-car (cell-contents (cell-contents promise))))
 
 (define (promise-value promise)
   (guarantee promise? promise 'promise-value)
@@ -472,12 +472,16 @@ USA.
 	  (guarantee promise? promise* 'force)
 	  (without-interrupts
 	   (lambda ()
-	     (let ((p (cell-contents promise)))
-	       (if (not (system-pair-car p))
-		   (let ((p* (cell-contents promise*)))
-		     (system-pair-set-car! p (system-pair-car p*))
-		     (system-pair-set-cdr! p (system-pair-cdr p*))
-		     (set-cell-contents! promise* p))))))
+	     (let ((q (cell-contents promise)))
+	       (if (not (system-pair-car (cell-contents q)))
+		   (let ((q* (cell-contents promise*)))
+		     ;; Reduce the chain of indirections by one link so
+		     ;; that we don't accumulate space.
+		     (set-cell-contents! q (cell-contents q*))
+		     ;; Point promise* at the same chain of
+		     ;; indirections as promise so that forcing
+		     ;; promise* will yield the same result.
+		     (set-cell-contents! promise* q))))))
 	  (%force promise)))))
 
 (define-print-method promise?