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]

diff --git a/v7/src/runtime/udata.scm b/v7/src/runtime/udata.scm
index 7af69628a31eb609932a6ccff2a58732421fc5b1..a04677b5870a2f0126088e9af8406c3383ca2afc 100644 (file)
--- 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 3e3625f21d4bb7fea56f3a8263f81b107c5a586c..035792055fbf62fbc1c47e22334a27e9ed0976b1 100644 (file)
--- 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 9a07d235bed95e0680232137038619c2dc3a788f..8dc4f7a5ecee657f6b06e29eff40368fd4206d0a 100644 (file)
--- 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