Import to github.

8 files changed, 1365 insertions, 0 deletions

diff --git a/runtime/README b/runtime/README
new file mode 100644
index 0000000..99d113a
--- /dev/null
+++ b/runtime/README
@@ -0,0 +1,8 @@
+This directory contains definitions of things that are used
+exclusively in code generated by the Haskell compiler.  It contains
+implementations of some of the things declared in the prims files for
+the prelude, as well as some more generic things that the code
+generator knows about.  
+
+Note that some of the files in this directory access some Common Lisp
+features directly.
diff --git a/runtime/array-prims.scm b/runtime/array-prims.scm
new file mode 100644
index 0000000..6b553f5
--- /dev/null
+++ b/runtime/array-prims.scm
@@ -0,0 +1,55 @@
+;;; array-prims.scm -- array primitives
+;;;
+;;; author :  John & Sandra
+;;; date   :  14 May 1993
+
+
+;;; Vector reference, returning unboxed value
+
+(define-syntax (prim.vector-sel vec i)
+  `(vector-ref ,vec ,i))
+
+
+;;; Destructive vector update.  All arguments are unboxed.
+
+(define-syntax (prim.vector-update vec i newval)
+  `(setf (vector-ref ,vec ,i) ,newval))
+
+
+;;; Make a vector whose elements are initialized to val (which is boxed).
+
+(define-syntax (prim.make-vector size val)
+  `(make-vector ,size ,val))
+
+
+;;; Copy an existing vector.
+
+(define-syntax (prim.copy-vector vec)
+  `(vector-copy ,vec))
+
+
+;;; Explicit force operation
+
+(define-syntax (prim.force x)
+  `(force ,x))
+
+
+;;; The first parameter is forced first since this prim is declared to
+;;; be strict in the first arg.
+
+(define-syntax (prim.strict1 force-this leave-this)
+  `(begin
+     ;; Can't ignore the first argument entirely since doing so
+     ;; might result in variable-bound-but-not-referenced errors.
+     ;; Hopefully the Lisp compiler will be smart enough to get
+     ;; rid of this when appropriate.
+     ,force-this
+     ;; Don't generate a stupid (force (delay x)) sequence here if
+     ;; we don't need to.
+     ,(if (and (pair? leave-this)
+	       (or (eq? (car leave-this) 'delay)
+		   (eq? (car leave-this) 'box)))
+	  (cadr leave-this)
+	  `(force ,leave-this))))
+
+
diff --git a/runtime/debug-utils.scm b/runtime/debug-utils.scm
new file mode 100644
index 0000000..e5fa971
--- /dev/null
+++ b/runtime/debug-utils.scm
@@ -0,0 +1,33 @@
+
+;;; This has some diagnostic stuff
+
+;;; This forces all delays in a structure
+
+(define (force-all x)
+  (cond ((delay? x)
+	 (force-all (force x)))
+	((pair? x)
+	 (force-all (car x))
+	 (force-all (cdr x)))
+	((vector? x)
+	 (dotimes (i (vector-length x))
+            (force-all (vector-ref x i)))))
+  x)
+
+;;; This forces & removes all delays in a structure.
+
+(define (remove-delays x)
+  (cond ((delay? x)
+	 (remove-delays (force x)))
+	((pair? x)
+	 (cons (remove-delays (car x))
+	       (remove-delays (cdr x))))
+	((vector? x)
+	 (list->vector (map (function remove-delays) (vector->list x))))
+	(else x)))
+
+(define (delay? x)
+  (and (pair? x)
+       (or (eq? (car x) '#t)
+	   (eq? (car x) '#f))))
+
diff --git a/runtime/io-primitives.scm b/runtime/io-primitives.scm
new file mode 100644
index 0000000..85bc51b
--- /dev/null
+++ b/runtime/io-primitives.scm
@@ -0,0 +1,178 @@
+
+;;; These are the IO primitives used by PreludeIOPrims
+
+;;; Note: the box in write-string-stdout, write-string-file, and
+;;;  append-string-file are due to the NoConversion in the .hi file.
+;;; The problem is that NoConversion applies to everything, not just
+;;; the input arg that the conversion is not needed or.
+
+
+(predefine (notify-input-request))
+
+(define *emacs-notified* '#f)
+(define *stdin-read* '#f)
+
+(define (initialize-io-system)
+  (setf *emacs-notified* '#f)
+  (setf *stdin-read* '#f))
+
+(define (io-success . res)
+  (make-tagged-data 0
+    (if (null? res)
+	(box 0)
+	(box (make-haskell-string (car res))))))
+
+(define (io-success/bin res)
+  (make-tagged-data 0 (box res)))
+
+(define (io-success/lazy res)
+  (make-tagged-data 0 res))
+
+(define (io-failure string)
+  (make-tagged-data 1 (box (make-haskell-string string))))
+
+; primReadStringFile
+(define (prim.read-string-file filename)
+  (if (file-exists? filename)
+      (let ((str (call-with-input-file filename
+		   (lambda (port)
+		     (port->string port)))))
+	(io-success str))
+      (io-failure (format '#f "File not found: ~A~%" filename))))
+
+(define (port->string port)
+  (call-with-output-string
+   (lambda (string-port)
+     (copy-till-eof port string-port))))
+
+(define (copy-till-eof in-port out-port)
+  (do ((ch (read-char in-port) (read-char in-port)))
+      ((eof-object? ch))
+    (write-char ch out-port)))
+
+; primWriteStringFile
+(define (prim.write-string-file filename contents state)
+ (declare (ignore state))
+ (box
+  (let ((stream (lisp:open (haskell-string->string filename)
+			   :direction :output 
+			   :if-exists :overwrite
+			   :if-does-not-exist :create)))
+    (print-haskell-string contents stream)
+    (close-output-port stream)
+    (io-success))))
+        
+;primAppendStringFile
+(define (prim.append-string-file filename contents state)
+ (declare (ignore state))
+ (box
+  (let ((stream (lisp:open (haskell-string->string filename)
+			   :direction :output 
+			   :if-exists :append
+			   :if-does-not-exist '())))
+    (cond ((not (eq? stream '()))
+           (print-haskell-string contents stream)
+           (close-output-port stream)
+	   (io-success))
+          (else
+	   (io-failure "Can't open file"))))))
+
+; primReadBinFile
+(define (prim.read-bin-file name)
+  (let ((bin (lisp-read name)))
+    (if (and (pair? bin) (eq? (car bin) ':binary))
+	(io-success/bin bin)
+	(io-failure "Not a bin file"))))
+
+; primWriteBinFile
+(define (prim.write-bin-file name contents)
+  (let ((stream (lisp:open name :direction :output 
+			   :if-exists :overwrite
+			   :if-does-not-exist :create)))
+    (write (cons ':binary contents) stream)
+    (close-output-port stream)
+    (io-success)))
+
+; primAppendBinFile
+(define (prim.append-bin-file name contents)
+ (let ((bin (lisp-read name)))
+   (if (and (pair? bin) (eq? (car bin) ':binary))
+       (let ((stream (lisp:open name :direction :output :if-exists :overwrite)))
+	 (write (append bin contents) stream)
+	 (io-success))
+       (io-failure "Can't open Bin file"))))
+
+; primDeleteFile
+(define (prim.delete-file name)
+  (if (file-exists? name)
+      (if (lisp:delete-file name)
+	  (io-success)
+	  (io-failure "Can't delete file"))
+      (io-failure "File not found")))
+
+; primStatusFile
+(define (prim.status-file name)
+  (if (file-exists? name)
+      (io-success "frw")
+      (io-failure (format '#f "File ~A not found" name))))
+
+;primReadStdin
+(define (prim.read-string-stdin state)
+  (declare (ignore state))
+  (cond (*stdin-read*
+	 (haskell-runtime-error "Multiple ReadChan from stdin"))
+	(else
+	 (setf *stdin-read* '#t)
+	 (delay (read-next-char)))))
+
+(define (read-next-char)
+  (when (and *emacs-mode* (not *emacs-notified*))
+    (setf *emacs-notified* '#t)
+    (notify-input-request))
+  (let ((ch (read-char)))
+    (if (eof-object? ch)
+	'()
+	(cons (box (char->integer ch))
+	      (delay (read-next-char))))))
+
+; primWriteStdout
+(define (prim.write-string-stdout string state)
+  (declare (ignore state))
+  (print-haskell-string string (current-output-port))
+  (box (io-success)))
+
+; primReadBinStdin
+(define (prim.read-bin-stdin)
+  (haskell-runtime-error  "ReadBinChan not implemented"))
+
+; primWriteBinStdout
+(define (prim.write-bin-stdout bin)
+  (declare (ignore bin))
+  (haskell-runtime-error  "WriteBinChan not implemented"))
+
+;;; %%% probably bogus
+; primGetEnv
+(define (prim.getenv name)
+  (io-success (getenv name)))
+
+(define (lisp-read file)
+  (if (not (file-exists? file))
+      'error
+      (call-with-input-file file
+        (lambda (port)
+	  (lisp:read port '#f 'error '#f)))))
+
+(define-integrable (prim.returnio x s)
+  (declare (ignore s))
+  x)
+
+(define-integrable (prim.getstate x)
+  (declare (ignore x))
+  'state)
+
+(define-integrable (prim.getres x)
+  (force x))
+
+
+
+
diff --git a/runtime/prims.scm b/runtime/prims.scm
new file mode 100644
index 0000000..797f21b
--- /dev/null
+++ b/runtime/prims.scm
@@ -0,0 +1,595 @@
+;;; prims.scm -- definitions for primitives
+;;;
+;;; author :  Sandra Loosemore
+;;; date   :  9 Jun 1992
+;;;
+;;; WARNING!!!  This file contains Common-Lisp specific code.
+;;;
+
+
+;;; Helper stuff
+
+(define-integrable (is-fixnum? x)
+  (lisp:typep x 'lisp:fixnum))
+
+(define-integrable (is-integer? x)
+  (lisp:typep x 'lisp:integer))
+
+(define-integrable (is-single-float? x)
+  (lisp:typep x 'lisp:single-float))
+
+(define-integrable (is-double-float? x)
+  (lisp:typep x 'lisp:double-float))
+
+(define-syntax (the-fixnum x)
+  `(lisp:the lisp:fixnum ,x))
+
+(define-syntax (the-integer x)
+  `(lisp:the lisp:integer ,x))
+
+(define-syntax (the-single-float x)
+  `(lisp:the lisp:single-float ,x))
+
+(define-syntax (the-double-float x)
+  `(lisp:the lisp:double-float ,x))
+
+(define-syntax (make-haskell-tuple2 x y)
+  `(make-tuple (box ,x) (box ,y)))
+
+;;; Abort
+;;; *** Should probably do something other than just signal an error.
+
+(define (prim.abort s)
+  (haskell-runtime-error s))
+
+(define (haskell-string->list s)
+  (if (null? s)
+      '()
+      (cons (integer->char (force (car s)))
+	    (haskell-string->list (force (cdr s))))))
+
+;;; Char
+
+(define-syntax (prim.char-to-int c)
+  `(the-fixnum ,c))
+
+(define-syntax (prim.int-to-char i)
+  `(the-fixnum ,i))
+
+(define-syntax (prim.eq-char i1 i2)
+  `(= (the-fixnum ,i1) (the-fixnum ,i2)))
+(define-syntax (prim.not-eq-char i1 i2)
+  `(not (= (the-fixnum ,i1) (the-fixnum ,i2))))
+(define-syntax (prim.le-char i1 i2)
+  `(<= (the-fixnum ,i1) (the-fixnum ,i2)))
+(define-syntax (prim.not-le-char i1 i2)
+  `(> (the-fixnum ,i1) (the-fixnum ,i2)))
+(define-syntax (prim.not-lt-char i1 i2)
+  `(>= (the-fixnum ,i1) (the-fixnum ,i2)))
+(define-syntax (prim.lt-char i1 i2)
+  `(< (the-fixnum ,i1) (the-fixnum ,i2)))
+
+(define-integrable prim.max-char 255)
+
+
+;;; Floating
+
+(define-syntax (prim.eq-float f1 f2)
+  `(= (the-single-float ,f1) (the-single-float ,f2)))
+(define-syntax (prim.not-eq-float f1 f2)
+  `(not (= (the-single-float ,f1) (the-single-float ,f2))))
+(define-syntax (prim.le-float f1 f2)
+  `(<= (the-single-float ,f1) (the-single-float ,f2)))
+(define-syntax (prim.not-le-float f1 f2)
+  `(> (the-single-float ,f1) (the-single-float ,f2)))
+(define-syntax (prim.not-lt-float f1 f2)
+  `(>= (the-single-float ,f1) (the-single-float ,f2)))
+(define-syntax (prim.lt-float f1 f2)
+  `(< (the-single-float ,f1) (the-single-float ,f2)))
+
+(define-syntax (prim.eq-double f1 f2)
+  `(= (the-double-float ,f1) (the-double-float ,f2)))
+(define-syntax (prim.not-eq-double f1 f2)
+  `(not (= (the-double-float ,f1) (the-double-float ,f2))))
+(define-syntax (prim.le-double f1 f2)
+  `(<= (the-double-float ,f1) (the-double-float ,f2)))
+(define-syntax (prim.not-le-double f1 f2)
+  `(> (the-double-float ,f1) (the-double-float ,f2)))
+(define-syntax (prim.not-lt-double f1 f2)
+  `(>= (the-double-float ,f1) (the-double-float ,f2)))
+(define-syntax (prim.lt-double f1 f2)
+  `(< (the-double-float ,f1) (the-double-float ,f2)))
+
+(define-syntax (prim.float-max f1 f2)
+  `(the-single-float (max (the-single-float ,f1) (the-single-float ,f2))))
+(define-syntax (prim.float-min f1 f2)
+  `(the-single-float (min (the-single-float ,f1) (the-single-float ,f2))))
+
+(define-syntax (prim.double-max f1 f2)
+  `(the-double-float (max (the-double-float ,f1) (the-double-float ,f2))))
+(define-syntax (prim.double-min f1 f2)
+  `(the-double-float (min (the-double-float ,f1) (the-double-float ,f2))))
+
+(define-syntax (prim.plus-float f1 f2)
+  `(the-single-float (+ (the-single-float ,f1) (the-single-float ,f2))))
+(define-syntax (prim.minus-float f1 f2) 
+  `(the-single-float (- (the-single-float ,f1) (the-single-float ,f2))))
+(define-syntax (prim.mul-float f1 f2)
+  `(the-single-float (* (the-single-float ,f1) (the-single-float ,f2))))
+(define-syntax (prim.div-float f1 f2)
+  `(the-single-float (/ (the-single-float ,f1) (the-single-float ,f2))))
+
+(define-syntax (prim.plus-double f1 f2)
+  `(the-double-float (+ (the-double-float ,f1) (the-double-float ,f2))))
+(define-syntax (prim.minus-double f1 f2) 
+  `(the-double-float (- (the-double-float ,f1) (the-double-float ,f2))))
+(define-syntax (prim.mul-double f1 f2)
+  `(the-double-float (* (the-double-float ,f1) (the-double-float ,f2))))
+(define-syntax (prim.div-double f1 f2)
+  `(the-double-float (/ (the-double-float ,f1) (the-double-float ,f2))))
+
+
+(define-syntax (prim.neg-float f)
+  `(the-single-float (- (the-single-float ,f))))
+
+(define-syntax (prim.neg-double f)
+  `(the-double-float (- (the-double-float ,f))))
+
+(define-syntax (prim.abs-float f)
+  `(the-single-float (lisp:abs (the-single-float ,f))))
+
+(define-syntax (prim.abs-double f)
+  `(the-double-float (lisp:abs (the-double-float ,f))))
+
+
+(define-syntax (prim.exp-float f)
+  `(the-single-float (lisp:exp (the-single-float ,f))))
+(define-syntax (prim.log-float f)
+  `(the-single-float (lisp:log (the-single-float ,f))))
+(define-syntax (prim.sqrt-float f)
+  `(the-single-float (lisp:sqrt (the-single-float ,f))))
+(define-syntax (prim.sin-float f)
+  `(the-single-float (lisp:sin (the-single-float ,f))))
+(define-syntax (prim.cos-float f)
+  `(the-single-float (lisp:cos (the-single-float ,f))))
+(define-syntax (prim.tan-float f)
+  `(the-single-float (lisp:tan (the-single-float ,f))))
+(define-syntax (prim.asin-float f)
+  `(the-single-float (lisp:asin (the-single-float ,f))))
+(define-syntax (prim.acos-float f)
+  `(the-single-float (lisp:acos (the-single-float ,f))))
+(define-syntax (prim.atan-float f)
+  `(the-single-float (lisp:atan (the-single-float ,f))))
+(define-syntax (prim.sinh-float f)
+  `(the-single-float (lisp:sinh (the-single-float ,f))))
+(define-syntax (prim.cosh-float f)
+  `(the-single-float (lisp:cosh (the-single-float ,f))))
+(define-syntax (prim.tanh-float f)
+  `(the-single-float (lisp:tanh (the-single-float ,f))))
+(define-syntax (prim.asinh-float f)
+  `(the-single-float (lisp:asinh (the-single-float ,f))))
+(define-syntax (prim.acosh-float f)
+  `(the-single-float (lisp:acosh (the-single-float ,f))))
+(define-syntax (prim.atanh-float f)
+  `(the-single-float (lisp:atanh (the-single-float ,f))))
+
+
+(define-syntax (prim.exp-double f)
+  `(the-double-float (lisp:exp (the-double-float ,f))))
+(define-syntax (prim.log-double f)
+  `(the-double-float (lisp:log (the-double-float ,f))))
+(define-syntax (prim.sqrt-double f)
+  `(the-double-float (lisp:sqrt (the-double-float ,f))))
+(define-syntax (prim.sin-double f)
+  `(the-double-float (lisp:sin (the-double-float ,f))))
+(define-syntax (prim.cos-double f)
+  `(the-double-float (lisp:cos (the-double-float ,f))))
+(define-syntax (prim.tan-double f)
+  `(the-double-float (lisp:tan (the-double-float ,f))))
+(define-syntax (prim.asin-double f)
+  `(the-double-float (lisp:asin (the-double-float ,f))))
+(define-syntax (prim.acos-double f)
+  `(the-double-float (lisp:acos (the-double-float ,f))))
+(define-syntax (prim.atan-double f)
+  `(the-double-float (lisp:atan (the-double-float ,f))))
+(define-syntax (prim.sinh-double f)
+  `(the-double-float (lisp:sinh (the-double-float ,f))))
+(define-syntax (prim.cosh-double f)
+  `(the-double-float (lisp:cosh (the-double-float ,f))))
+(define-syntax (prim.tanh-double f)
+  `(the-double-float (lisp:tanh (the-double-float ,f))))
+(define-syntax (prim.asinh-double f)
+  `(the-double-float (lisp:asinh (the-double-float ,f))))
+(define-syntax (prim.acosh-double f)
+  `(the-double-float (lisp:acosh (the-double-float ,f))))
+(define-syntax (prim.atanh-double f)
+  `(the-double-float (lisp:atanh (the-double-float ,f))))
+
+
+(define-integrable prim.pi-float (lisp:coerce lisp:pi 'lisp:single-float))
+
+(define-integrable prim.pi-double (lisp:coerce lisp:pi 'lisp:double-float))
+
+
+;;; Assumes rationals are represented as a 2-tuple of integers
+
+(define (prim.rational-to-float x)
+  (let ((n (tuple-select 2 0 x))
+	(d (tuple-select 2 1 x)))
+    (if (eqv? d 0)
+	(haskell-runtime-error "Divide by 0.")
+	(prim.rational-to-float-aux n d))))
+
+(define (prim.rational-to-float-aux n d)
+  (declare (type integer n d))
+  (/ (lisp:coerce n 'lisp:single-float)
+     (lisp:coerce d 'lisp:single-float)))
+
+(define (prim.rational-to-double x)
+  (let ((n (tuple-select 2 0 x))
+	(d (tuple-select 2 1 x)))
+    (if (eqv? d 0)
+	(haskell-runtime-error "Divide by 0.")
+	(prim.rational-to-double-aux n d))))
+
+(define (prim.rational-to-double-aux n d)
+  (declare (type integer n d))
+  (/ (lisp:coerce n 'lisp:double-float)
+     (lisp:coerce d 'lisp:double-float)))
+
+(define (prim.float-to-rational x)
+  (let ((r  (lisp:rational (the lisp:single-float x))))
+    (declare (type rational r))
+    (make-tuple (lisp:numerator r) (lisp:denominator r))))
+
+(define (prim.double-to-rational x)
+  (let ((r  (lisp:rational (the lisp:double-float x))))
+    (declare (type rational r))
+    (make-tuple (lisp:numerator r) (lisp:denominator r))))
+
+
+(define-integrable prim.float-1 (lisp:coerce 1.0 'lisp:single-float))
+(define-integrable prim.double-1 (lisp:coerce 1.0 'lisp:double-float))
+
+(define-integrable prim.float-digits
+  (lisp:float-digits prim.float-1))
+
+(define-integrable prim.double-digits
+  (lisp:float-digits prim.double-1))
+
+(define-integrable prim.float-radix
+  (lisp:float-radix prim.float-1))
+
+(define-integrable prim.double-radix
+  (lisp:float-radix prim.double-1))
+
+
+;;; Sometimes least-positive-xxx-float is denormalized.
+
+(define-integrable prim.float-min-exp
+  (multiple-value-bind (m e)
+      (lisp:decode-float
+        #+lucid lcl:least-positive-normalized-single-float
+	#-lucid lisp:least-positive-single-float)
+    (declare (ignore m))
+    e))
+
+(define-integrable prim.double-min-exp
+  (multiple-value-bind (m e)
+      (lisp:decode-float
+        #+lucid lcl:least-positive-normalized-double-float
+	#-lucid lisp:least-positive-double-float)
+    (declare (ignore m))
+    e))
+
+(define-integrable prim.float-max-exp
+  (multiple-value-bind (m e)
+      (lisp:decode-float lisp:most-positive-single-float)
+    (declare (ignore m))
+    e))
+
+(define-integrable prim.double-max-exp
+  (multiple-value-bind (m e)
+      (lisp:decode-float lisp:most-positive-double-float)
+    (declare (ignore m))
+    e))
+
+(define-integrable (prim.float-range x)
+  (declare (ignore x))
+  (make-haskell-tuple2 prim.float-min-exp prim.float-max-exp))
+
+(define-integrable (prim.double-range x)
+  (declare (ignore x))
+  (make-haskell-tuple2 prim.double-min-exp prim.double-max-exp))
+
+
+;;; *** I'm not sure if these are correct.  Should the exponent value
+;;; *** be taken as the value that lisp:integer-decode-float returns,
+;;; *** or as the value that lisp:decode-float returns?  (They're
+;;; *** not the same because the significand is scaled differently.)
+;;; *** I'm guessing that Haskell's model is to use the actual numbers
+;;; *** that are in the bit fields 
+
+;;; jcp - I removed this since Haskell requires an integer instead of a
+;;; fractional mantissa.  My theory is that integer-decode-float returns
+;;; what Haskell wants without fiddling (except sign reattachment)
+
+(define (exponent-adjustment m)
+  (if (eqv? prim.float-radix 2)
+      ;; the usual case -- e.g. IEEE floating point
+      (lisp:integer-length m)
+      (lisp:ceiling (lisp:log m prim.float-radix))))
+
+(define (prim.decode-float f)
+  (multiple-value-bind (m e s)
+      (lisp:integer-decode-float (the-single-float f))
+    (make-haskell-tuple2 (* (the-integer m) (the-fixnum s))
+			 (the-fixnum e))))
+
+(define (prim.decode-double f)
+  (multiple-value-bind (m e s)
+      (lisp:integer-decode-float (the-double-float f))
+    (make-haskell-tuple2 (* (the-integer m) (the-fixnum s))
+			 (the-fixnum e))))
+
+(define (prim.encode-float m e)
+  (lisp:scale-float (lisp:coerce m 'lisp:single-float) (the-fixnum e)))
+
+(define (prim.encode-double m e)
+  (lisp:scale-float (lisp:coerce m 'lisp:double-float) (the-fixnum e)))
+
+
+;;; Integral
+
+(define-syntax (prim.eq-int i1 i2)
+  `(= (the-fixnum ,i1) (the-fixnum ,i2)))
+(define-syntax (prim.not-eq-int i1 i2)
+  `(not (= (the-fixnum ,i1) (the-fixnum ,i2))))
+(define-syntax (prim.le-int i1 i2)
+  `(<= (the-fixnum ,i1) (the-fixnum ,i2)))
+(define-syntax (prim.not-le-int i1 i2)
+  `(> (the-fixnum ,i1) (the-fixnum ,i2)))
+(define-syntax (prim.not-lt-int i1 i2)
+  `(>= (the-fixnum ,i1) (the-fixnum ,i2)))
+(define-syntax (prim.lt-int i1 i2)
+  `(< (the-fixnum ,i1) (the-fixnum ,i2)))
+(define-syntax (prim.int-max i1 i2)
+  `(the-fixnum (max (the-fixnum ,i1) (the-fixnum ,i2))))
+(define-syntax (prim.int-min i1 i2)
+  `(the-fixnum (min (the-fixnum ,i1) (the-fixnum ,i2))))
+
+(define-syntax (prim.eq-integer i1 i2)
+  `(= (the-integer ,i1) (the-integer ,i2)))
+(define-syntax (prim.not-eq-integer i1 i2)
+  `(not (= (the-integer ,i1) (the-integer ,i2))))
+(define-syntax (prim.le-integer i1 i2)
+  `(<= (the-integer ,i1) (the-integer ,i2)))
+(define-syntax (prim.not-le-integer i1 i2)
+  `(> (the-integer ,i1) (the-integer ,i2)))
+(define-syntax (prim.not-lt-integer i1 i2)
+  `(>= (the-integer ,i1) (the-integer ,i2)))
+(define-syntax (prim.lt-integer i1 i2)
+  `(< (the-integer ,i1) (the-integer ,i2)))
+(define-syntax (prim.integer-max i1 i2)
+  `(the-integer (max (the-integer ,i1) (the-integer ,i2))))
+(define-syntax (prim.integer-min i1 i2)
+  `(the-integer (min (the-integer ,i1) (the-integer ,i2))))
+
+
+(define-syntax (prim.plus-int i1 i2)
+  `(the-fixnum (+ (the-fixnum ,i1) (the-fixnum ,i2))))
+(define-syntax (prim.minus-int i1 i2)
+  `(the-fixnum (- (the-fixnum ,i1) (the-fixnum ,i2))))
+(define-syntax (prim.mul-int i1 i2)
+  `(the-fixnum (* (the-fixnum ,i1) (the-fixnum ,i2))))
+(define-syntax (prim.neg-int i)
+  `(the-fixnum (- (the-fixnum ,i))))
+(define-syntax (prim.abs-int i)
+  `(the-fixnum (lisp:abs (the-fixnum ,i))))
+
+(define-integrable prim.minint lisp:most-negative-fixnum)
+(define-integrable prim.maxint lisp:most-positive-fixnum)
+
+(define-syntax (prim.plus-integer i1 i2)
+  `(the-integer (+ (the-integer ,i1) (the-integer ,i2))))
+(define-syntax (prim.minus-integer i1 i2)
+  `(the-integer (- (the-integer ,i1) (the-integer ,i2))))
+(define-syntax (prim.mul-integer i1 i2)
+  `(the-integer (* (the-integer ,i1) (the-integer ,i2))))
+(define-syntax (prim.neg-integer i)
+  `(the-integer (- (the-integer ,i))))
+(define-syntax (prim.abs-integer i)
+  `(the-integer (lisp:abs (the-integer ,i))))
+
+
+(define (prim.div-rem-int i1 i2)
+  (multiple-value-bind (q r)
+      (lisp:truncate (the-fixnum i1) (the-fixnum i2))
+    (make-tuple (box (the-fixnum q)) (box (the-fixnum r)))))
+
+(define (prim.div-rem-integer i1 i2)
+  (multiple-value-bind (q r)
+      (lisp:truncate (the-integer i1) (the-integer i2))
+    (make-tuple (box (the-integer q)) (box (the-integer r)))))
+
+(define (prim.integer-to-int i)
+  (if (is-fixnum? i)
+      (the-fixnum i)
+      (haskell-runtime-error "Integer -> Int overflow.")))
+
+(define-syntax (prim.int-to-integer i)
+  i)
+
+;;; Binary
+
+(define prim.nullbin '())
+
+(define (prim.is-null-bin x)
+  (null? x))
+
+(define (prim.show-bin-int i b)
+  (cons i b))
+
+(define (prim.show-bin-integer i b)
+  (cons i b))
+
+(define (prim.show-bin-float f b)
+  (cons f b))
+
+(define (prim.show-bin-double f b)
+  (cons f b))
+
+(define (prim.bin-read-error)
+  (haskell-runtime-error "Error: attempt to read from an incompatible Bin."))
+
+(define (prim.read-bin-int b)
+  (if (or (null? b) (not (is-fixnum? (car b))))
+      (prim.bin-read-error)
+      (make-haskell-tuple2 (car b) (cdr b))))
+
+(define (prim.read-bin-integer b)
+  (if (or (null? b) (not (is-integer? (car b))))
+      (prim.bin-read-error)
+      (make-haskell-tuple2 (car b) (cdr b))))
+
+(define (prim.read-bin-float b)
+  (if (or (null? b) (not (is-single-float? (car b))))
+      (prim.bin-read-error)
+      (make-haskell-tuple2 (car b) (cdr b))))
+
+(define (prim.read-bin-double b)
+  (if (or (null? b) (not (is-double-float? (car b))))
+      (prim.bin-read-error)
+      (make-haskell-tuple2 (car b) (cdr b))))
+
+(define (prim.read-bin-small-int b m)
+  (if (or (null? b)
+	  (not (is-fixnum? (car b)))
+	  (> (the-fixnum (car b)) (the-fixnum m)))
+      (prim.bin-read-error)
+      (make-haskell-tuple2 (car b) (cdr b))))
+
+(define (prim.append-bin x y)
+  (append x y))
+
+
+;;; String primitives
+
+;;; Calls to prim.string-eq are generated by the CFN to pattern match
+;;; against string constants.  So normally one of the arguments will be
+;;; a constant string.  Treat this case specially to avoid consing up
+;;; a haskell string whenever it's called.
+;;; This function is strict in both its arguments.
+
+(define-syntax (prim.string-eq s1 s2)
+  (cond ((and (pair? s1)
+	      (eq? (car s1) 'make-haskell-string))
+	 `(prim.string-eq-inline ,(cadr s1) 0 ,(string-length (cadr s1)) ,s2))
+	((and (pair? s2)
+	      (eq? (car s2) 'make-haskell-string))
+	 `(prim.string-eq-inline ,(cadr s2) 0 ,(string-length (cadr s2)) ,s1))
+	(else
+	 `(prim.string-eq-notinline ,s1 ,s2))))
+
+(define (prim.string-eq-inline lisp-string i n haskell-string)
+  (declare (type fixnum i n))
+  (cond ((eqv? i n)
+	 ;; Reached end of Lisp string constant -- better be at the end
+	 ;; of the Haskell string, too.
+	 (if (null? haskell-string) '#t '#f))
+	((null? haskell-string)
+	 ;; The Haskell string is too short.
+	 '#f)
+	((eqv? (the fixnum (char->integer (string-ref lisp-string i)))
+	       (the fixnum (force (car haskell-string))))
+	 ;; Next characters match, recurse
+	 (prim.string-eq-inline
+	   lisp-string (the fixnum (+ i 1)) n (force (cdr haskell-string))))
+	(else
+	 ;; No match
+	 '#f)))
+
+(define (prim.string-eq-notinline s1 s2)
+  (cond ((null? s1)
+	 ;; Reached end of first string.
+	 (if (null? s2) '#t '#f))
+	((null? s2)
+	 ;; Second string too short.
+	 '#f)
+	((eqv? (the fixnum (force (car s1))) (the fixnum (force (car s2))))
+	 (prim.string-eq-notinline (force (cdr s1)) (force (cdr s2))))
+	(else
+	 '#f)))
+
+  
+;;; List primitives
+
+
+;;; The first argument is strict and the second is a delay.
+
+(define-syntax (prim.append l1 l2)
+  (cond ((and (pair? l1)
+	      (eq? (car l1) 'make-haskell-string))
+	 `(make-haskell-string-tail ,(cadr l1) ,l2))
+	((equal? l1 ''())
+	 `(force ,l2))
+	((equal? l2 '(box '()))
+	 l1)
+	;; *** could also look for
+	;; *** (append (cons x (box y)) z) => (cons x (box (append y z)))
+	;; *** but I don't think this happens very often anyway
+	(else
+	 `(prim.append-aux ,l1 ,l2))))
+
+(define (prim.append-aux l1 l2)
+  (cond ((null? l1)
+	 (force l2))
+	((and (forced? l2) (eq? (unbox l2) '()))
+	 ;; Appending nil is identity.
+	 l1)
+	((forced? (cdr l1))
+	 ;; Append eagerly if the tail of the first list argument has 
+         ;; already been forced.
+	 (cons (car l1)
+	       (if (null? (unbox (cdr l1)))
+		   l2  ; don't force this!!
+		   (box (prim.append-aux (unbox (cdr l1)) l2)))))
+	(else
+	 (cons (car l1) (delay (prim.append-aux (force (cdr l1)) l2))))
+	))
+
+
+;;; Both arguments are forced here.  Have to be careful not to call
+;;; recursively with an argument of 0.
+;;; *** This is no longer used.
+
+(define (prim.take n l)
+  (declare (type fixnum n))
+  (cond ((not (pair? l))
+	 '())
+	((eqv? n 1)
+	 ;; Only one element to take.
+	 (cons (car l) (box '())))
+	((forced? (cdr l))
+	 ;; Take eagerly if the tail of the list has already been forced.
+	 (cons (car l) (box (prim.take (- n 1) (unbox (cdr l))))))
+	(else
+	 (cons (car l) (delay (prim.take (- n 1) (force (cdr l))))))
+	))
+      
+
+;;; The optimizer gets rid of all first-order calls to these functions.
+
+(define (prim.foldr k z l)
+  ;; k and z are nonstrict, l is strict
+  (if (null? l)
+      (force z)
+      (funcall (force k)
+	       (car l)
+	       (delay (prim.foldr k z (force (cdr l)))))))
+
+(define (prim.build g)
+  ;; g is strict
+  (funcall g
+	   (box (function make-cons-constructor))
+	   (box '())))
diff --git a/runtime/runtime-utils.scm b/runtime/runtime-utils.scm
new file mode 100644
index 0000000..f43c930
--- /dev/null
+++ b/runtime/runtime-utils.scm
@@ -0,0 +1,384 @@
+;;; runtime-utils.scm -- basic runtime support
+;;;
+;;; author :  Sandra Loosemore
+;;; date   :  9 Jun 1992
+;;;
+;;; This file contains definitions (beyond the normal mumble stuff)
+;;; that is referenced directly in code built by the code generator.
+;;; See backend/codegen.scm.
+;;;
+
+
+
+;;; (delay form)
+;;;   returns a delay object with unevaluated "form".
+
+(define-syntax (delay form)
+  `(cons '#f (lambda () ,form)))
+
+
+;;; (box form)
+;;;   returns a delay object with evaluated "form".
+
+(define-syntax (box form)
+  (cond ((number? form)
+	 `(quote ,(cons '#t form)))
+	((and (pair? form) (eq? (car form) 'quote))
+	 `(quote ,(cons '#t (cadr form))))
+	(else
+	 `(cons '#t ,form))))
+
+(define-syntax (unbox form)
+  `(cdr ,form))
+
+(define-syntax (forced? form)
+  `(car ,form))
+
+
+;;; (force delay)
+;;;   return the value of the delay object.
+
+(define (force delay-object)
+  (declare (type pair delay-object))
+  (if (car delay-object)
+      (cdr delay-object)
+      (begin
+        (let ((result  (funcall (cdr delay-object))))
+	  (setf (car delay-object) '#t)
+	  (setf (cdr delay-object) result)))))
+
+;;; Inline version of the above.  Not good to use everywhere because
+;;; of code bloat problems, but handy for helper functions.
+
+(define-syntax (force-inline delay-object)
+  (let ((temp1  (gensym))
+	(temp2  (gensym)))
+    `(let ((,temp1  ,delay-object))
+       (declare (type pair ,temp1))
+       (if (car ,temp1)
+	   (cdr ,temp1)
+	   (let ((,temp2  (funcall (cdr ,temp1))))
+	     (setf (car ,temp1) '#t)
+	     (setf (cdr ,temp1) ,temp2))))))
+
+
+;;; (make-curried-fn opt-fn strictness)
+;;; The basic idea is to compare the number of arguments received against
+;;; the number expected.
+;;; If the same, call the optimized entry point opt-fn.
+;;; If more, apply the result of calling the optimized entry to the
+;;;   leftover arguments.
+;;; If less, make a closure that accepts the additional arguments.
+
+(define (make-curried-fn opt-fn strictness)
+  (lambda args
+    (curried-fn-body '() args opt-fn strictness)))
+
+(define (curried-fn-body previous-args args opt-fn strictness)
+  (multiple-value-bind
+      (saturated? actual-args leftover-args leftover-strictness)
+      (process-curried-fn-args strictness args '())
+    (setf actual-args (append previous-args actual-args))
+    (if saturated?
+	(if (null? leftover-args)
+	    (apply opt-fn actual-args)
+	    (apply (apply opt-fn actual-args) leftover-args))
+	(lambda more-args
+	  (curried-fn-body actual-args more-args opt-fn leftover-strictness)))
+    ))
+
+(define (process-curried-fn-args strictness args actual-args)
+  (cond ((null? strictness)
+	 ;; At least as many arguments as expected.
+	 (values '#t (nreverse actual-args) args strictness))
+	((null? args)
+	 ;; Not enough arguments supplied.
+  	 (values '#f (nreverse actual-args) args strictness))
+	(else
+	 ;; Process the next argument.
+	 (if (car strictness)
+	     (push (force-inline (car args)) actual-args)
+	     (push (car args) actual-args))
+ 	 (process-curried-fn-args (cdr strictness) (cdr args) actual-args))
+	))
+
+
+;;; Special cases of the above.
+
+(define (make-curried-fn-1-strict opt-fn)
+  (lambda (arg1 . moreargs)
+    (setf arg1 (force-inline arg1))
+    (if (null? moreargs)
+	(funcall opt-fn arg1)
+	(apply (funcall opt-fn arg1) moreargs))))
+
+(define (make-curried-fn-1-nonstrict opt-fn)
+  (lambda (arg1 . moreargs)
+    (if (null? moreargs)
+	(funcall opt-fn arg1)
+	(apply (funcall opt-fn arg1) moreargs))))
+
+
+;;; Here's a similar helper function used for making data constructors.
+
+(define (constructor-body previous-args args arity fn)
+  (declare (type fixnum arity))
+  (let ((n  (length args)))
+    (declare (type fixnum n))
+    (setf args (append previous-args args))
+    (cond ((eqv? n arity)
+	   (apply fn args))
+	  ((< n arity)
+	   (lambda more-args
+	     (constructor-body args more-args (- arity n) fn)))
+	  (else
+	   (error "Too many arguments supplied to constructor.")))))
+
+
+;;; Special case for cons constructor
+
+(define (make-cons-constructor . args)
+  (constructor-body '() args 2 (function cons)))
+
+
+;;; (make-tuple-constructor arity)
+;;;   return a function that makes an untagged data structure with "arity" 
+;;;   slots.  "arity" is a constant.
+
+(define-integrable *max-predefined-tuple-arity* 10)
+
+(define (make-tuple-constructor-aux arity)
+  (cond ((eqv? arity 0)
+	 ;; Actually, should never happen -- this is the unit constructor
+	 0)
+	((eqv? arity 1)
+	 (lambda args
+	   (constructor-body '() args 2 (lambda (x) x))))
+	((eqv? arity 2)
+	 (lambda args
+	   (constructor-body '() args 2 (function cons))))
+	(else
+	 (lambda args
+	   (constructor-body '() args arity (function vector))))))
+
+(define *predefined-tuple-constructors*
+  (let ((result  '()))
+    (dotimes (i *max-predefined-tuple-arity*)
+      (push (make-tuple-constructor-aux i) result))
+    (list->vector (nreverse result))))
+
+(define-syntax (make-tuple-constructor arity)
+  (declare (type fixnum arity))
+  (if (< arity *max-predefined-tuple-arity*)
+      `(vector-ref *predefined-tuple-constructors* ,arity)
+      `(make-tuple-constructor-aux ,arity)))
+
+
+;;; (make-tuple . args)
+;;;   uncurried version of the above
+
+(define-syntax (make-tuple . args)
+  (let ((arity  (length args)))
+    (cond ((eqv? arity 0)
+	   ;; Actually, should never happen -- this is the unit constructor
+	   0)
+	  ((eqv? arity 1)
+	   (car args))
+	  ((eqv? arity 2)
+	   `(cons ,@args))
+	  (else
+	   `(vector ,@args)))))
+
+
+;;; (make-tagged-data-constructor n arity)
+;;;   return a function that makes a data structure with tag "n" and
+;;;   "arity" slots.
+
+(define-integrable *max-predefined-tagged-data-tag* 10)
+(define-integrable *max-predefined-tagged-data-arity* 10)
+
+(define (make-tagged-data-constructor-aux n arity)
+  (if (eqv? arity 0)
+      (vector n)
+      (lambda args
+	(constructor-body (list n) args arity (function vector)))))
+
+(define *predefined-tagged-data-constructors*
+  (let ((result  '()))
+    (dotimes (i *max-predefined-tagged-data-arity*)
+      (let ((inner-result  '()))
+	(dotimes (j *max-predefined-tagged-data-tag*)
+	  (push (make-tagged-data-constructor-aux j i) inner-result))
+	(push (list->vector (nreverse inner-result)) result)))
+    (list->vector (nreverse result))))
+
+(define-syntax (make-tagged-data-constructor n arity)
+  (declare (type fixnum arity n))
+  (if (and (< arity *max-predefined-tagged-data-arity*)
+	   (< n *max-predefined-tagged-data-tag*))
+      `(vector-ref (vector-ref *predefined-tagged-data-constructors* ,arity)
+		   ,n)
+      `(make-tagged-data-constructor-aux ,n ,arity)))
+
+
+;;; (make-tagged-data n . args)
+;;;   uncurried version of the above
+
+(define-syntax (make-tagged-data n . args)
+  `(vector ,n ,@args))
+
+
+;;; (tuple-select arity i object)
+;;;   extract component "i" from untagged "object"
+
+(define-syntax (tuple-select arity i object)
+  (cond ((eqv? arity 1)
+	 object)
+	((eqv? arity 2)
+	 (if (eqv? i 0)
+	     `(car ,object)
+	     `(cdr ,object)))
+	(else
+	 `(vector-ref (the vector ,object) (the fixnum ,i)))))
+
+
+;;; (tagged-data-select arity i object)
+;;;   extract component "i" from tagged "object"
+
+(define-syntax (tagged-data-select arity i object)
+  (declare (ignore arity))
+  `(vector-ref (the vector ,object) (the fixnum ,(1+ i))))
+
+
+;;; (constructor-number object)
+;;;   return the tag from "object"
+
+(define-syntax (constructor-number object)
+  `(vector-ref (the vector ,object) 0))
+
+(define-syntax (funcall-force fn . args)
+  (let* ((n    (length args))
+	 (junk (assv n '((1 . funcall-force-1)
+			 (2 . funcall-force-2)
+			 (3 . funcall-force-3)
+			 (4 . funcall-force-4)))))
+    `(,(if junk (cdr junk) 'funcall-force-n) ,fn ,@args)))
+
+(define (funcall-force-1 fn a1)
+  (funcall (force-inline fn) a1))
+(define (funcall-force-2 fn a1 a2)
+  (funcall (force-inline fn) a1 a2))
+(define (funcall-force-3 fn a1 a2 a3)
+  (funcall (force-inline fn) a1 a2 a3))
+(define (funcall-force-4 fn a1 a2 a3 a4)
+  (funcall (force-inline fn) a1 a2 a3 a4))
+(define-syntax (funcall-force-n fn . args)
+  `(funcall (force ,fn) ,@args))
+
+
+;;; (make-haskell-string string)
+;;;   Converts a Lisp string lazily to a boxed haskell string (makes
+;;;   a delay with a magic function).  Returns an unboxed result.
+
+(define (make-haskell-string string)
+  (declare (type string string))
+  (let ((index   1)
+	(size    (string-length string)))
+    (declare (type fixnum index size))
+    (cond ((eqv? size 0)
+	   '())
+	  ((eqv? size 1)
+	   (cons (box (char->integer (string-ref string 0)))
+		 (box '())))
+	  (else
+	   (letrec ((next-fn
+		      (lambda ()
+			(let ((ch  (char->integer (string-ref string index))))
+			  (incf index)
+			  (cons (box ch)
+				(if (eqv? index size)
+				    (box '())
+				    (cons '#f next-fn)))))))
+	     (cons (box (char->integer (string-ref string 0)))
+		   (cons '#f next-fn))))
+	  )))
+
+
+;;; Similar, but accepts an arbitrary tail (which must be a delay object)
+
+(define (make-haskell-string-tail string tail-delay)
+  (declare (type string string))
+  (let ((index   1)
+	(size    (string-length string)))
+    (declare (type fixnum index size))
+    (cond ((eqv? size 0)
+	   (force-inline tail-delay))
+	  ((eqv? size 1)
+	   (cons (box (char->integer (string-ref string 0)))
+		 tail-delay))
+	  (else
+	   (letrec ((next-fn
+		      (lambda ()
+			(let ((ch  (char->integer (string-ref string index))))
+			  (incf index)
+			  (cons (box ch)
+				(if (eqv? index size)
+				    tail-delay
+				    (cons '#f next-fn)))))))
+	     (cons (box (char->integer (string-ref string 0)))
+		   (cons '#f next-fn))))
+	  )))
+
+
+(define (haskell-string->string s)
+  (let ((length  0))
+    (declare (type fixnum length))
+    (do ((s s (force (cdr s))))
+	((null? s))
+	(setf length (+ length 1)))
+    (let ((result  (make-string length)))
+      (declare (type string result))
+      (do ((s s (unbox (cdr s)))
+	   (i 0 (+ i 1)))
+	  ((null? s))
+	  (declare (type fixnum i))
+	  (setf (string-ref result i) (integer->char (force (car s)))))
+      result)))
+
+
+(define (print-haskell-string s port)
+   (do ((s1 s (force (cdr s1))))
+       ((null? s1))
+     (write-char (integer->char (force (car s1))) port)))
+
+;;; This explicates the value returned by a proc (the IO () type).
+
+(define (insert-unit-value x)
+  (declare (ignore x))
+  0)
+
+;;; These handle list conversions
+
+(define (haskell-list->list fn l)
+  (if (null? l)
+      '()
+      (cons (funcall fn (force (car l))) 
+	    (haskell-list->list fn (force (cdr l))))))
+
+(define (list->haskell-list fn l)
+  (if (null? l)
+      '()
+      (cons (box (funcall fn (car l)))
+	    (box (list->haskell-list fn (cdr l))))))
+
+(define (haskell-list->list/identity l)
+  (if (null? l)
+      '()
+      (cons (force (car l))
+	    (haskell-list->list/identity (force (cdr l))))))
+
+(define (list->haskell-list/identity l)
+  (if (null? l)
+      '()
+      (cons (box (car l))
+	    (box (list->haskell-list/identity (cdr l))))))
diff --git a/runtime/runtime.scm b/runtime/runtime.scm
new file mode 100644
index 0000000..bd5713e
--- /dev/null
+++ b/runtime/runtime.scm
@@ -0,0 +1,26 @@
+;;; runtime.scm
+;;;
+;;; author :  John
+;;;
+
+
+(define-compilation-unit runtime
+  (source-filename "$Y2/runtime/")
+  (require global)
+  (unit runtime-utils
+	(source-filename "runtime-utils.scm"))
+  (unit prims
+	(require runtime-utils)
+	(source-filename "prims.scm"))
+  (unit io-primitives
+	(require runtime-utils)
+	(source-filename "io-primitives.scm"))
+  (unit array-prims
+	(require runtime-utils)
+	(source-filename "array-prims.scm"))
+  (unit debug-utils
+	(require runtime-utils)
+	(source-filename "debug-utils.scm"))
+  (unit tuple-prims
+        (require runtime-utils)
+	(source-filename "tuple-prims.scm")))
diff --git a/runtime/tuple-prims.scm b/runtime/tuple-prims.scm
new file mode 100644
index 0000000..6eb0cbf
--- /dev/null
+++ b/runtime/tuple-prims.scm
@@ -0,0 +1,86 @@
+;; these primitives support arbitrary sized tuples.
+
+(define (prim.tupleSize x)
+  (vector-length x))
+
+(define (prim.tupleSel tuple i n)
+ (force
+  (if (eqv? n 2)
+      (if (eqv? i 0)
+	  (car tuple)
+	  (cdr tuple))
+      (vector-ref tuple i))))
+
+(define (prim.list->tuple l)
+  (let ((l (haskell-list->list/non-strict l)))
+    (if (null? (cddr l))
+	(cons (car l) (cadr l))
+	(list->vector l))))
+
+(define (haskell-list->list/non-strict l)
+  (if (null? l)
+      '()
+      (cons (car l)
+	    (haskell-list->list/non-strict (force (cdr l))))))
+
+(define (prim.dict-sel dicts i)
+  (force (vector-ref dicts i)))
+
+;;; These generate dictionaries.
+
+(define-local-syntax (create-dict dicts vars other-dicts)
+  `(let ((dict-vector (box (list->vector ,dicts))))
+     (make-tuple
+       ,@(map (lambda (v)
+		`(delay (funcall (dynamic ,v) dict-vector)))
+	   vars)
+       ,@(map (lambda (sd)
+		`(delay (,(car sd)
+			 (map (lambda (d)
+			       (tuple-select ,(cadr sd) ,(caddr sd) (force d)))
+			      ,dicts))))
+	      other-dicts))))
+
+(define prim.tupleEqdict
+  (lambda dicts
+    (tupleEqDict/l dicts)))
+
+(define (tupleEqDict/l dicts)
+  (create-dict dicts
+     (|PreludeTuple:tupleEq| |PreludeTuple:tupleNeq|)
+     ()))
+
+(define prim.tupleOrdDict
+ (lambda dicts
+   (tupleOrdDict/l dicts)))
+
+(define (tupleOrdDict/l d)
+  (create-dict d
+   (|PreludeTuple:tupleLe| |PreludeTuple:tupleLeq|
+    |PreludeTuple:tupleGe| |PreludeTuple:tupleGeq|
+    |PreludeTuple:tupleMax| |PreludeTuple:tupleMin|)
+   ((tupleEqDict/l 7 6))))
+
+(define prim.tupleIxDict
+ (lambda dicts
+   (create-dict dicts
+      (|PreludeTuple:tupleRange| |PreludeTuple:tupleIndex|
+       |PreludeTuple:tupleInRange|)
+      ((tupleEqDict/l 6 3) (tupleTextDict/l 6 4) (tupleOrdDict/l 6 5)))))
+
+(define prim.tupleTextDict
+ (lambda dicts
+   (tupleTextDict/l dicts)))
+
+(define (tupleTextDict/l d)
+  (create-dict d
+     (|PreludeTuple:tupleReadsPrec| |PreludeTuple:tupleShowsPrec|
+      |PreludeTuple:tupleReadList| |PreludeTuple:tupleShowList|)
+     ()))
+
+(define prim.tupleBinaryDict
+ (lambda dicts
+   (create-dict dicts
+    (|PreludeTuple:tupleReadBin| |PreludeTuple:tupleShowBin|)
+    ())))
+