diff options
Diffstat (limited to 'runtime/runtime-utils.scm')
| -rw-r--r-- | runtime/runtime-utils.scm | 384 |
1 files changed, 384 insertions, 0 deletions
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)))))) |