diff options
Diffstat (limited to 'runtime')
| -rw-r--r-- | runtime/README | 8 | ||||
| -rw-r--r-- | runtime/array-prims.scm | 55 | ||||
| -rw-r--r-- | runtime/debug-utils.scm | 33 | ||||
| -rw-r--r-- | runtime/io-primitives.scm | 178 | ||||
| -rw-r--r-- | runtime/prims.scm | 595 | ||||
| -rw-r--r-- | runtime/runtime-utils.scm | 384 | ||||
| -rw-r--r-- | runtime/runtime.scm | 26 | ||||
| -rw-r--r-- | runtime/tuple-prims.scm | 86 |
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|) + ()))) + |