From f57c1870ef7389c157b739fff2b56beb7f765e40 Mon Sep 17 00:00:00 2001
From: Stephen Adams <edu/mit/csail/zurich/adams>
Date: Wed, 9 Jul 1997 14:40:07 +0000
Subject: [PATCH] Implemented FORCE as a compiled procedure.  SF no longer
 integrates FORCE as a primitive procedure.

There is a minor bootstrapping problem with the standard build
scripts since any pre-existing version of SF will integrate the
primitive FORCE, and SF is only run on files that have changed.
A solution is:

    1. rebuild the system
    2. remove any .bin files that call FORCE
    3. rebuild the system using bands produced in step 1.

Timings under Scheme 8.0 on plex:

	Test	Primitive	Compiled
	 [1]	 10370ms	  560ms
	 [2]	   180ms	  130ms
	 [3]       440ms	  270ms

(let ((nums (list->stream (make-initialized-list 100001 identity-procedure)))
      (primes
       ((access make-prime-numbers-stream (->environment '(runtime stream))))))
  (show-time (lambda () (stream-ref nums 100000)))    ; [1]
  (show-time (lambda () (stream-ref nums 100000)))    ; [2]
  (show-time (lambda () (stream-ref primes 1000))))   ; [3]
---
 v7/src/runtime/udata.scm  | 17 +++++++++++++++--
 v8/src/runtime/global.scm |  4 ++--
 v8/src/sf/gconst.scm      |  3 +--
 3 files changed, 18 insertions(+), 6 deletions(-)

diff --git a/v7/src/runtime/udata.scm b/v7/src/runtime/udata.scm
index 7af69628a..a04677b58 100644
--- a/v7/src/runtime/udata.scm
+++ b/v7/src/runtime/udata.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: udata.scm,v 14.17 1995/07/27 21:23:12 adams Exp $
+$Id: udata.scm,v 14.18 1997/07/09 14:39:36 adams Exp $
 
 Copyright (c) 1988-1995 Massachusetts Institute of Technology
 
@@ -291,4 +291,17 @@ contains constants derived from the source program.
       (error "Promise already forced" promise))
   (if (promise-non-expression? promise)
       (error "Promise has no environment" promise))
-  (system-pair-car promise))
\ No newline at end of file
+  (system-pair-car promise))
+
+(define (force promise)
+  (cond ((not (promise? promise))
+	 (error:wrong-type-argument promise "promise" 'FORCE))
+	((eq? #T (system-pair-car promise))
+	 (system-pair-cdr promise))
+	((eqv? 0 (system-pair-car promise)) ; compiled promise
+	 (let ((result ((system-pair-cdr promise))))
+	   (system-pair-set-cdr! promise result)
+	   (system-pair-set-car! promise #T)
+	   result))
+	(else ; losing old style
+	 ((ucode-primitive force 1) promise))))
diff --git a/v8/src/runtime/global.scm b/v8/src/runtime/global.scm
index 3e3625f21..035792055 100644
--- a/v8/src/runtime/global.scm
+++ b/v8/src/runtime/global.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: global.scm,v 14.52 1996/12/01 17:22:31 adams Exp $
+$Id: global.scm,v 14.53 1997/07/09 14:40:07 adams Exp $
 
 Copyright (c) 1988-1996 Massachusetts Institute of Technology
 
@@ -40,7 +40,7 @@ MIT in each case. |#
 ;;;; Primitive Operators
 
 (define-primitives
-  force error-procedure
+  error-procedure
   set-interrupt-enables! enable-interrupts! with-interrupt-mask
   get-fixed-objects-vector with-history-disabled
   (primitive-procedure-arity 1)
diff --git a/v8/src/sf/gconst.scm b/v8/src/sf/gconst.scm
index 9a07d235b..8dc4f7a5e 100644
--- a/v8/src/sf/gconst.scm
+++ b/v8/src/sf/gconst.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: gconst.scm,v 1.3 1997/06/27 14:06:10 adams Exp $
+$Id: gconst.scm,v 1.4 1997/07/09 14:39:47 adams Exp $
 
 Copyright (c) 1987-93 Massachusetts Institute of Technology
 
@@ -149,7 +149,6 @@ MIT in each case. |#
     FLO:VECTOR-REF
     FLO:VECTOR-SET!
     FLO:ZERO?
-    FORCE
     GENERAL-CAR-CDR
     GET-FIXED-OBJECTS-VECTOR
     GET-NEXT-CONSTANT
-- 
2.25.1