From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 29 May 2018 06:53:16 +0000 (-0700)
Subject: Refactor promises again, to support delay-force.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=5e2cd4805275f3766e5019572b93c12930a0feac;p=mit-scheme.git

Refactor promises again, to support delay-force.

This no longer uses scode DELAY expressions, which can be deleted after 9.3 is
released.  It does continue to use DELAYED objects for type convenience.
---

diff --git a/src/runtime/boot.scm b/src/runtime/boot.scm
index ad39b5260..e614ea6ec 100644
--- a/src/runtime/boot.scm
+++ b/src/runtime/boot.scm
@@ -431,6 +431,59 @@ USA.
 	  (write-string "object satisfying " port)
 	  (write predicate port)))))
 
+;;;; Promises
+
+(define (promise? object)
+  (and (cell? object)
+       (object-type? (ucode-type delayed) (cell-contents object))))
+
+(define (make-promise object)
+  (if (promise? object)
+      object
+      (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)))
+
+(define (%promise-parts promise)
+  (without-interrupts
+   (lambda ()
+     (let ((p (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)))
+
+(define (promise-value promise)
+  (guarantee promise? promise 'promise-value)
+  (receive (forced? value) (%promise-parts promise)
+    (if (not forced?)
+	(error "Promise not yet forced:" promise))
+    value))
+
+(define (force promise)
+  (guarantee promise? promise 'force)
+  (%force promise))
+
+(define (%force promise)
+  (receive (forced? value) (%promise-parts promise)
+    (if forced?
+	value
+	(let ((promise* (value)))
+	  (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))))))
+	  (%force promise)))))
+
 ;;;; Miscellany
 
 (define (object-constant? object)
diff --git a/src/runtime/framex.scm b/src/runtime/framex.scm
index e493faeb1..33d745a33 100644
--- a/src/runtime/framex.scm
+++ b/src/runtime/framex.scm
@@ -133,11 +133,7 @@ USA.
     (values (make-scode-combination (ucode-primitive force 1)
 				    (list (make-evaluated-object promise)))
 	    undefined-environment
-	    (let ((expr (promise-expression promise)))
-	      (case expr
-		((|#[(runtime microcode-data)forced]|) undefined-expression)
-		((|#[(runtime microcode-data)compiled]|) unknown-expression)
-		(else (validate-subexpression frame expr)))))))
+	    undefined-expression)))
 
 (define ((method/application-frame index) frame)
   (values (make-scode-combination
diff --git a/src/runtime/host-adapter.scm b/src/runtime/host-adapter.scm
index dd447c6ea..109f84e69 100644
--- a/src/runtime/host-adapter.scm
+++ b/src/runtime/host-adapter.scm
@@ -89,6 +89,18 @@ USA.
 				   (list (cons 'name name) ...)))))
 	      env))
 
+    (if (unbound? env 'delay-force)
+	(eval '(begin
+		 (define-syntax delay-force
+		   (syntax-rules ()
+		     ((delay-force expression)
+		      (make-unforced-promise (lambda () expression)))))
+		 (define-syntax delay
+		   (syntax-rules ()
+		     ((delay expression)
+		      (delay-force (make-promise expression))))))
+	      env))
+
     (if (unbound? env 'define-print-method)
 	(eval '(define (define-print-method predicate print-method)
 		 unspecific)
diff --git a/src/runtime/microcode-data.scm b/src/runtime/microcode-data.scm
index bdeb69f86..06b5d52d4 100644
--- a/src/runtime/microcode-data.scm
+++ b/src/runtime/microcode-data.scm
@@ -256,50 +256,4 @@ contains constants derived from the source program.
 	    (filter-potentially-dangerous (cdr aux-list))
 	    (cons (car aux-list)
 		  (filter-potentially-dangerous (cdr aux-list))))
-	'())))
-
-;;;; Promises
-
-(define-integrable (promise? object)
-  (object-type? (ucode-type delayed) object))
-
-(define (make-promise object)
-  (if (promise? object)
-      object
-      (system-pair-cons (ucode-type delayed) #t object)))
-
-(define-integrable (%promise-forced? promise)
-  (eq? #t (system-pair-car promise)))
-
-(define (promise-forced? promise)
-  (guarantee promise? promise 'promise-forced?)
-  (%promise-forced? promise))
-
-(define (promise-value promise)
-  (guarantee promise? promise 'promise-value)
-  (if (not (%promise-forced? promise))
-      (error "Promise not yet forced:" promise))
-  (system-pair-cdr promise))
-
-(define (promise-expression promise)
-  (without-interrupts
-   (lambda ()
-     (case (system-pair-car promise)
-       ((#t) '|#[(runtime microcode-data)forced]|)
-       ((0) '|#[(runtime microcode-data)compiled]|)
-       (else (system-pair-cdr promise))))))
-
-(define (force promise)
-  (guarantee promise? promise 'force)
-  (without-interrupts
-   (lambda ()
-     (case (system-pair-car promise)
-       ((#t)
-	(system-pair-cdr promise))
-       ((0)				;compiled
-	(let ((result ((system-pair-cdr promise))))
-	  (system-pair-set-cdr! promise result)
-	  (system-pair-set-car! promise #t)
-	  result))
-       (else				;interpreted
-	((ucode-primitive force 1) promise))))))
\ No newline at end of file
+	'())))
\ No newline at end of file
diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm
index 4ae0f6b59..74aaf0319 100644
--- a/src/runtime/mit-macros.scm
+++ b/src/runtime/mit-macros.scm
@@ -396,6 +396,16 @@ USA.
      (if (not condition)
 	 (begin form ...)))))
 
+(define-syntax $delay-force
+  (syntax-rules ()
+    ((delay-force expression)
+     (make-unforced-promise (lambda () expression)))))
+
+(define-syntax $delay
+  (syntax-rules ()
+    ((delay expression)
+     (delay-force (make-promise expression)))))
+
 (define $guard
   (spar-transformer->runtime
    (delay
diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm
index fa030125c..5403f58c5 100644
--- a/src/runtime/mit-syntax.scm
+++ b/src/runtime/mit-syntax.scm
@@ -158,15 +158,6 @@ USA.
        (spar-push spar-arg:ctx)
        (spar* (spar-subform spar-push-classified))
        (spar-match-null)))))
-
-(define $delay
-  (spar-classifier->runtime
-   (delay
-     (spar-call-with-values delay-item
-       (spar-subform)
-       (spar-push spar-arg:ctx)
-       (spar-subform spar-push-deferred-classified)
-       (spar-match-null)))))
 
 ;;;; Definitions
 
@@ -454,11 +445,6 @@ USA.
     (lambda ()
       (output/declaration (classify)))))
 
-(define (delay-item ctx classify)
-  (expr-item ctx
-    (lambda ()
-      (output/delay (compile-expr-item (classify))))))
-
 (define (if-item ctx predicate consequent alternative)
   (expr-item ctx
     (lambda ()
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 7925f3654..bdc41fd0b 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -163,6 +163,7 @@ USA.
 	  define-print-method
 	  error:not-a
 	  error:not-a-list-of
+	  force				;R7RS
 	  gc-space-status
 	  guarantee
 	  guarantee-list-of
@@ -179,10 +180,15 @@ USA.
 	  interrupt-mask/gc-ok
 	  interrupt-mask/none
 	  interrupt-mask/timer-ok
+	  make-promise			;R7RS
+	  make-unforced-promise
 	  object-constant?
 	  object-pure?
 	  predicate->dispatch-tag
 	  predicate?
+	  promise-forced?
+	  promise-value
+	  promise?			;R7RS
 	  register-predicate!
 	  set-dispatch-tag<=!
 	  set-predicate<=!
@@ -806,17 +812,12 @@ USA.
 	  environment-extension-parent
 	  environment-extension-procedure
 	  environment-extension?
-	  force				;R7RS
 	  interpreter-return-address?
-	  make-promise			;R7RS
 	  make-return-address
 	  microcode-error
 	  microcode-return
 	  microcode-termination
 	  microcode-type
-	  promise-forced?
-	  promise-value
-	  promise?			;R7RS
 	  return-address/code
 	  return-address/name
 	  return-address?
@@ -824,9 +825,7 @@ USA.
 	  set-environment-extension-parent!
 	  stack-address->index
 	  stack-address-offset
-	  stack-address?)
-  (export (runtime debugging-info)
-	  promise-expression))
+	  stack-address?))
 
 (define-package (runtime vector)
   (files "vector")
@@ -4705,7 +4704,6 @@ USA.
 	  output/constant
 	  output/declaration
 	  output/definition
-	  output/delay
 	  output/disjunction
 	  output/lambda
 	  output/let
@@ -4741,7 +4739,6 @@ USA.
 	  (begin $begin)		;R7RS
 	  (declare $declare)
 	  (define-syntax $define-syntax) ;R7RS
-	  (delay $delay)		;R7RS
 	  (else $else)			;R7RS
 	  (er-macro-transformer $er-macro-transformer)
 	  (if $if)			;R7RS
@@ -4786,6 +4783,8 @@ USA.
 	  (define-integrable $define-integrable)
 	  (define-record-type $define-record-type)
 	  (define-values $define-values) ;R7RS
+	  (delay $delay)		;R7RS
+	  (delay-force $delay-force)	;R7RS
 	  (do $do)			;R7RS
 	  (fluid-let $fluid-let)
 	  (guard $guard)		;R7RS
diff --git a/src/runtime/syntax-output.scm b/src/runtime/syntax-output.scm
index f3e4316b9..985a0c70b 100644
--- a/src/runtime/syntax-output.scm
+++ b/src/runtime/syntax-output.scm
@@ -82,9 +82,6 @@ USA.
   (receive (required optional rest) (parse-mit-lambda-list lambda-list)
     (make-lambda* name required optional rest body)))
 
-(define (output/delay expression)
-  (make-scode-delay expression))
-
 (define (output/unassigned-test name)
   (make-scode-unassigned? name))