2007-10-25 16:27:34 -04:00
|
|
|
;;; Ikarus Scheme -- A compiler for R6RS Scheme.
|
2008-01-29 00:34:34 -05:00
|
|
|
;;; Copyright (C) 2006,2007,2008 Abdulaziz Ghuloum
|
2007-10-25 16:27:34 -04:00
|
|
|
;;;
|
|
|
|
;;; This program is free software: you can redistribute it and/or modify
|
|
|
|
;;; it under the terms of the GNU General Public License version 3 as
|
|
|
|
;;; published by the Free Software Foundation.
|
|
|
|
;;;
|
|
|
|
;;; This program is distributed in the hope that it will be useful, but
|
|
|
|
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
|
|
;;; General Public License for more details.
|
|
|
|
;;;
|
|
|
|
;;; You should have received a copy of the GNU General Public License
|
|
|
|
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
|
2006-11-23 19:44:29 -05:00
|
|
|
|
2008-02-14 17:45:15 -05:00
|
|
|
(library (ikarus.compiler)
|
2008-06-23 01:10:05 -04:00
|
|
|
(export compile-core-expr-to-port
|
2008-06-29 15:35:34 -04:00
|
|
|
assembler-output optimize-cp
|
2008-02-18 02:02:00 -05:00
|
|
|
current-primitive-locations eval-core
|
2009-05-29 22:16:04 -04:00
|
|
|
current-core-eval compile-core-expr
|
2009-06-14 05:06:48 -04:00
|
|
|
expand expand/optimize expand/scc-letrec optimizer-output
|
2008-07-07 02:48:16 -04:00
|
|
|
cp0-effort-limit cp0-size-limit optimize-level
|
2009-05-14 02:09:58 -04:00
|
|
|
perform-tag-analysis tag-analysis-output
|
2009-07-06 05:07:18 -04:00
|
|
|
strip-source-info generate-debug-calls current-letrec-pass)
|
2007-05-05 21:18:41 -04:00
|
|
|
(import
|
2007-10-09 09:22:02 -04:00
|
|
|
(rnrs hashtables)
|
2007-06-02 03:21:05 -04:00
|
|
|
(ikarus system $fx)
|
|
|
|
(ikarus system $pairs)
|
2007-05-06 17:55:04 -04:00
|
|
|
(only (ikarus system $codes) $code->closure)
|
2007-10-12 02:59:27 -04:00
|
|
|
(only (ikarus system $structs) $struct-ref $struct/rtd?)
|
2007-05-06 20:12:25 -04:00
|
|
|
(except (ikarus)
|
2008-06-28 05:25:44 -04:00
|
|
|
optimize-level debug-optimizer
|
2009-06-14 05:06:48 -04:00
|
|
|
fasl-write optimize-cp
|
2007-05-05 21:18:41 -04:00
|
|
|
compile-core-expr-to-port assembler-output
|
2008-06-23 01:10:05 -04:00
|
|
|
current-primitive-locations eval-core
|
2008-06-29 15:35:34 -04:00
|
|
|
cp0-size-limit cp0-effort-limit
|
2009-06-14 05:06:48 -04:00
|
|
|
expand/optimize expand/scc-letrec expand optimizer-output
|
2009-05-10 18:35:38 -04:00
|
|
|
tag-analysis-output perform-tag-analysis
|
2009-07-06 05:07:18 -04:00
|
|
|
current-core-eval current-letrec-pass)
|
2009-05-30 03:46:45 -04:00
|
|
|
(ikarus include)
|
2008-02-14 17:45:15 -05:00
|
|
|
(ikarus.fasl.write)
|
|
|
|
(ikarus.intel-assembler))
|
2007-05-01 04:37:35 -04:00
|
|
|
|
|
|
|
|
2009-05-14 02:09:58 -04:00
|
|
|
(define strip-source-info (make-parameter #f))
|
2009-05-17 19:08:02 -04:00
|
|
|
(define generate-debug-calls (make-parameter #f))
|
2009-04-06 11:47:40 -04:00
|
|
|
|
2007-10-12 02:59:27 -04:00
|
|
|
(define-syntax struct-case
|
2006-11-23 19:44:29 -05:00
|
|
|
(lambda (x)
|
2006-12-16 18:18:11 -05:00
|
|
|
(define (enumerate fld* i)
|
|
|
|
(syntax-case fld* ()
|
|
|
|
[() #'()]
|
|
|
|
[(x . x*)
|
|
|
|
(with-syntax ([i i] [i* (enumerate #'x* (fx+ i 1))])
|
|
|
|
#'(i . i*))]))
|
|
|
|
(define (generate-body ctxt cls*)
|
|
|
|
(syntax-case cls* (else)
|
2007-10-25 14:32:26 -04:00
|
|
|
[() (with-syntax ([x x]) #'(error #f "unmatched " v 'x))]
|
2006-12-16 18:18:11 -05:00
|
|
|
[([else b b* ...]) #'(begin b b* ...)]
|
|
|
|
[([(rec-name rec-field* ...) b b* ...] . rest) (identifier? #'rec-name)
|
|
|
|
(with-syntax ([altern (generate-body ctxt #'rest)]
|
|
|
|
[(id* ...) (enumerate #'(rec-field* ...) 0)]
|
|
|
|
[rtd #'(type-descriptor rec-name)])
|
2007-10-12 02:59:27 -04:00
|
|
|
#'(if ($struct/rtd? v rtd)
|
|
|
|
(let ([rec-field* ($struct-ref v id*)] ...)
|
2006-12-16 18:18:11 -05:00
|
|
|
b b* ...)
|
|
|
|
altern))]))
|
2006-11-23 19:44:29 -05:00
|
|
|
(syntax-case x ()
|
2006-12-16 18:18:11 -05:00
|
|
|
[(_ expr cls* ...)
|
|
|
|
(with-syntax ([body (generate-body #'_ #'(cls* ...))])
|
|
|
|
#'(let ([v expr]) body))])))
|
2006-11-23 19:44:29 -05:00
|
|
|
|
2007-10-17 22:50:15 -04:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define (remq1 x ls)
|
|
|
|
(cond
|
|
|
|
[(null? ls) '()]
|
|
|
|
[(eq? x (car ls)) (cdr ls)]
|
|
|
|
[else
|
|
|
|
(let ([t (remq1 x (cdr ls))])
|
|
|
|
(cond
|
|
|
|
[(eq? t (cdr ls)) ls]
|
|
|
|
[else (cons (car ls) t)]))]))
|
|
|
|
|
|
|
|
(define (singleton x) (list x))
|
|
|
|
|
|
|
|
(define (union s1 s2)
|
|
|
|
(define (add* s1 s2)
|
|
|
|
(cond
|
|
|
|
[(null? s1) s2]
|
|
|
|
[else (add (car s1) (add* (cdr s1) s2))]))
|
|
|
|
(define (add x s)
|
|
|
|
(cond
|
|
|
|
[(memq x s) s]
|
|
|
|
[else (cons x s)]))
|
|
|
|
(cond
|
|
|
|
[(null? s1) s2]
|
|
|
|
[(null? s2) s1]
|
|
|
|
[else (add* s1 s2)]))
|
|
|
|
|
|
|
|
(define (difference s1 s2)
|
|
|
|
(define (rem* s1 s2)
|
|
|
|
(cond
|
|
|
|
[(null? s1) s2]
|
|
|
|
[else (remq1 (car s1) (rem* (cdr s1) s2))]))
|
|
|
|
(cond
|
|
|
|
[(null? s1) '()]
|
|
|
|
[(null? s2) s1]
|
|
|
|
[else (rem* s2 s1)]))
|
|
|
|
|
2006-11-23 19:44:29 -05:00
|
|
|
|
|
|
|
|
2007-10-12 02:59:27 -04:00
|
|
|
(define-struct constant (value))
|
|
|
|
(define-struct code-loc (label))
|
|
|
|
(define-struct foreign-label (label))
|
|
|
|
(define-struct var
|
2008-06-29 15:35:34 -04:00
|
|
|
(name reg-conf frm-conf var-conf reg-move frm-move var-move
|
|
|
|
loc index referenced global-loc))
|
2007-10-12 02:59:27 -04:00
|
|
|
(define-struct cp-var (idx))
|
|
|
|
(define-struct frame-var (idx))
|
|
|
|
(define-struct new-frame (base-idx size body))
|
|
|
|
(define-struct save-cp (loc))
|
|
|
|
(define-struct eval-cp (check body))
|
|
|
|
(define-struct return (value))
|
|
|
|
(define-struct call-cp
|
2006-12-04 22:43:42 -05:00
|
|
|
(call-convention label save-cp? rp-convention base-idx arg-count live-mask))
|
2007-10-12 02:59:27 -04:00
|
|
|
(define-struct tailcall-cp (convention label arg-count))
|
|
|
|
(define-struct primcall (op arg*))
|
|
|
|
(define-struct primref (name))
|
|
|
|
(define-struct conditional (test conseq altern))
|
|
|
|
(define-struct interrupt-call (test handler))
|
|
|
|
(define-struct bind (lhs* rhs* body))
|
|
|
|
(define-struct recbind (lhs* rhs* body))
|
|
|
|
(define-struct rec*bind (lhs* rhs* body))
|
|
|
|
(define-struct fix (lhs* rhs* body))
|
|
|
|
|
|
|
|
(define-struct seq (e0 e1))
|
|
|
|
(define-struct case-info (label args proper))
|
|
|
|
(define-struct clambda-case (info body))
|
2007-11-21 04:00:10 -05:00
|
|
|
(define-struct clambda (label cases cp free name))
|
2008-02-11 22:18:32 -05:00
|
|
|
(define-struct closure (code free* well-known?))
|
2007-10-12 02:59:27 -04:00
|
|
|
(define-struct funcall (op rand*))
|
|
|
|
(define-struct jmpcall (label op rand*))
|
|
|
|
(define-struct forcall (op rand*))
|
|
|
|
(define-struct codes (list body))
|
|
|
|
(define-struct assign (lhs rhs))
|
|
|
|
(define-struct mvcall (producer consumer))
|
|
|
|
|
2008-07-07 02:48:16 -04:00
|
|
|
(define-struct known (expr type))
|
2007-10-12 02:59:27 -04:00
|
|
|
|
|
|
|
(define-struct shortcut (body handler))
|
|
|
|
|
|
|
|
(define-struct fvar (idx))
|
|
|
|
(define-struct object (val))
|
|
|
|
(define-struct locals (vars body))
|
|
|
|
(define-struct nframe (vars live body))
|
|
|
|
(define-struct nfv (conf loc var-conf frm-conf nfv-conf))
|
|
|
|
(define-struct ntcall (target value args mask size))
|
|
|
|
(define-struct asm-instr (op dst src))
|
|
|
|
(define-struct disp (s0 s1))
|
2007-02-11 04:12:09 -05:00
|
|
|
|
2008-06-29 15:35:34 -04:00
|
|
|
;;; this define-structure definition for compatibility with the
|
|
|
|
;;; notation used in Oscar's thesis.
|
|
|
|
(define-syntax define-structure
|
|
|
|
(lambda (stx)
|
|
|
|
(define (fmt ctxt)
|
|
|
|
(lambda (str . args)
|
|
|
|
(datum->syntax ctxt
|
|
|
|
(string->symbol
|
|
|
|
(apply format str (map syntax->datum args))))))
|
|
|
|
(syntax-case stx ()
|
|
|
|
[(_ (name fields ...))
|
|
|
|
#'(define-struct name (fields ...))]
|
|
|
|
[(_ (name fields ...) ([others defaults] ...))
|
|
|
|
(with-syntax ([(pred maker (getters ...) (setters ...))
|
|
|
|
(let ([fmt (fmt #'name)])
|
|
|
|
(list (fmt "~s?" #'name)
|
|
|
|
(fmt "make-~s" #'name)
|
|
|
|
(map (lambda (x) (fmt "~s-~s" #'name x))
|
|
|
|
#'(fields ... others ...))
|
|
|
|
(map (lambda (x) (fmt "set-~s-~s!" #'name x))
|
|
|
|
#'(fields ... others ...))))])
|
|
|
|
#'(module (name pred getters ... setters ... maker)
|
|
|
|
(module P (name pred getters ... setters ... maker)
|
|
|
|
(define-struct name (fields ... others ...)))
|
|
|
|
(module (maker)
|
|
|
|
(define (maker fields ...)
|
|
|
|
(import P)
|
|
|
|
(maker fields ... defaults ...)))
|
|
|
|
(module (name pred getters ... setters ...)
|
|
|
|
(import P))))])))
|
|
|
|
;;;
|
|
|
|
(define-structure (prelex name operand)
|
|
|
|
([source-referenced? #f]
|
|
|
|
[source-assigned? #f]
|
|
|
|
[residual-referenced? #f]
|
|
|
|
[residual-assigned? #f]
|
|
|
|
[global-location #f]))
|
|
|
|
|
2007-02-11 04:12:09 -05:00
|
|
|
(define mkfvar
|
|
|
|
(let ([cache '()])
|
|
|
|
(lambda (i)
|
|
|
|
(cond
|
|
|
|
[(fixnum? i)
|
|
|
|
(cond
|
|
|
|
[(assv i cache) => cdr]
|
|
|
|
[else
|
|
|
|
(let ([fv (make-fvar i)])
|
|
|
|
(set! cache (cons (cons i fv) cache))
|
|
|
|
fv)])]
|
2007-10-25 14:32:26 -04:00
|
|
|
[else (error 'mkfvar "not a fixnum" i)]))))
|
2007-02-10 18:51:12 -05:00
|
|
|
|
2008-06-29 15:35:34 -04:00
|
|
|
(define (unique-var name)
|
|
|
|
(make-var name #f #f #f #f #f #f #f #f #f #f))
|
2006-11-23 19:44:29 -05:00
|
|
|
|
|
|
|
(define (recordize x)
|
2006-12-06 21:33:33 -05:00
|
|
|
(define *cookie* (gensym))
|
2006-11-23 19:44:29 -05:00
|
|
|
(define (gen-fml* fml*)
|
|
|
|
(cond
|
|
|
|
[(pair? fml*)
|
2008-06-29 15:35:34 -04:00
|
|
|
(let ([v (make-prelex (car fml*) #f)])
|
2006-12-06 21:33:33 -05:00
|
|
|
(putprop (car fml*) *cookie* v)
|
|
|
|
(cons v (gen-fml* (cdr fml*))))]
|
2006-11-23 19:44:29 -05:00
|
|
|
[(symbol? fml*)
|
2008-06-29 15:35:34 -04:00
|
|
|
(let ([v (make-prelex fml* #f)])
|
2006-12-06 21:33:33 -05:00
|
|
|
(putprop fml* *cookie* v)
|
|
|
|
v)]
|
2006-11-23 19:44:29 -05:00
|
|
|
[else '()]))
|
2006-12-06 21:33:33 -05:00
|
|
|
(define (ungen-fml* fml*)
|
|
|
|
(cond
|
|
|
|
[(pair? fml*)
|
|
|
|
(remprop (car fml*) *cookie*)
|
|
|
|
(ungen-fml* (cdr fml*))]
|
|
|
|
[(symbol? fml*)
|
|
|
|
(remprop fml* *cookie*)]))
|
2006-11-23 19:44:29 -05:00
|
|
|
(define (properize fml*)
|
|
|
|
(cond
|
|
|
|
[(pair? fml*)
|
|
|
|
(cons (car fml*) (properize (cdr fml*)))]
|
|
|
|
[(null? fml*) '()]
|
|
|
|
[else (list fml*)]))
|
|
|
|
(define (quoted-sym x)
|
|
|
|
(if (and (list? x)
|
|
|
|
(fx= (length x) 2)
|
|
|
|
(eq? 'quote (car x))
|
|
|
|
(symbol? (cadr x)))
|
|
|
|
(cadr x)
|
2007-10-25 14:32:26 -04:00
|
|
|
(error 'quoted-sym "not a quoted symbol" x)))
|
2006-12-06 21:33:33 -05:00
|
|
|
(define (quoted-string x)
|
2006-11-23 19:44:29 -05:00
|
|
|
(if (and (list? x)
|
|
|
|
(fx= (length x) 2)
|
|
|
|
(eq? 'quote (car x))
|
|
|
|
(string? (cadr x)))
|
|
|
|
(cadr x)
|
2007-10-25 14:32:26 -04:00
|
|
|
(error 'quoted-string "not a quoted string" x)))
|
2007-10-09 08:54:28 -04:00
|
|
|
(define (lexical x)
|
|
|
|
(getprop x *cookie*))
|
2007-10-10 05:06:31 -04:00
|
|
|
(define (get-fmls x args)
|
|
|
|
(define (matching? fmls args)
|
|
|
|
(cond
|
|
|
|
[(null? fmls) (null? args)]
|
|
|
|
[(pair? fmls) (and (pair? args) (matching? (cdr fmls) (cdr args)))]
|
|
|
|
[else #t]))
|
2009-03-30 05:28:30 -04:00
|
|
|
(define (get-cls* x)
|
|
|
|
(if (pair? x)
|
|
|
|
(case (car x)
|
|
|
|
[(case-lambda) (cdr x)]
|
|
|
|
[(annotated-case-lambda) (cddr x)]
|
|
|
|
[else '()])
|
|
|
|
'()))
|
|
|
|
(let f ([cls* (get-cls* x)])
|
|
|
|
(cond
|
|
|
|
[(null? cls*) '()]
|
|
|
|
[(matching? (caar cls*) args)
|
|
|
|
(caar cls*)]
|
|
|
|
[else (f (cdr cls*))])))
|
2007-11-17 11:06:17 -05:00
|
|
|
(define (make-global-set! lhs rhs)
|
|
|
|
(make-funcall (make-primref '$init-symbol-value!)
|
|
|
|
(list (make-constant lhs) rhs)))
|
2008-06-19 04:58:59 -04:00
|
|
|
(define-syntax equal-case
|
|
|
|
(lambda (x)
|
|
|
|
(syntax-case x ()
|
|
|
|
[(_ val clause* ...)
|
|
|
|
(with-syntax ([body
|
|
|
|
(let f ([clause* #'(clause* ...)])
|
|
|
|
(syntax-case clause* (else)
|
|
|
|
[([else e e* ...])
|
|
|
|
#'(begin e e* ...)]
|
|
|
|
[([(datum* ...) e e* ...] . rest)
|
|
|
|
(with-syntax ([rest (f #'rest)])
|
|
|
|
#'(if (member t '(datum* ...))
|
|
|
|
(begin e e* ...)
|
|
|
|
rest))]))])
|
|
|
|
#'(let ([t val]) body))])))
|
2009-03-30 05:28:30 -04:00
|
|
|
|
|
|
|
(define (E-clambda-clause* cls* ctxt)
|
|
|
|
(map
|
|
|
|
(let ([ctxt (if (pair? ctxt) (car ctxt) #f)])
|
|
|
|
(lambda (cls)
|
|
|
|
(let ([fml* (car cls)] [body (cadr cls)])
|
|
|
|
(let ([nfml* (gen-fml* fml*)])
|
|
|
|
(let ([body (E body ctxt)])
|
|
|
|
(ungen-fml* fml*)
|
|
|
|
(make-clambda-case
|
|
|
|
(make-case-info
|
|
|
|
(gensym)
|
|
|
|
(properize nfml*)
|
|
|
|
(list? fml*))
|
|
|
|
body))))))
|
|
|
|
cls*))
|
2009-05-17 19:08:02 -04:00
|
|
|
(define (E-make-parameter mk-call args ctxt)
|
2009-05-14 02:52:05 -04:00
|
|
|
(case (length args)
|
|
|
|
[(1)
|
|
|
|
(let ([val-expr (car args)]
|
|
|
|
[t (gensym 't)]
|
|
|
|
[x (gensym 'x)])
|
|
|
|
(E `((lambda (,t)
|
|
|
|
(case-lambda
|
|
|
|
[() ,t]
|
|
|
|
[(,x) (set! ,t ,x)]))
|
|
|
|
,val-expr)
|
|
|
|
ctxt))]
|
|
|
|
[(2)
|
|
|
|
(let ([val-expr (car args)]
|
|
|
|
[guard-expr (cadr args)]
|
|
|
|
[f (gensym 'f)]
|
|
|
|
[t (gensym 't)]
|
|
|
|
[t0 (gensym 't)]
|
|
|
|
[x (gensym 'x)])
|
|
|
|
(E `((case-lambda
|
|
|
|
[(,t ,f)
|
|
|
|
(if ((primitive procedure?) ,f)
|
|
|
|
((case-lambda
|
|
|
|
[(,t0)
|
|
|
|
(case-lambda
|
|
|
|
[() ,t0]
|
|
|
|
[(,x) (set! ,t0 (,f ,x))])])
|
|
|
|
(,f ,t))
|
|
|
|
((primitive die)
|
|
|
|
'make-parameter
|
|
|
|
'"not a procedure"
|
|
|
|
,f))])
|
|
|
|
,val-expr
|
|
|
|
,guard-expr)
|
|
|
|
ctxt))]
|
|
|
|
[else
|
2009-05-17 19:08:02 -04:00
|
|
|
(mk-call
|
2009-05-14 02:52:05 -04:00
|
|
|
(make-primref 'make-parameter)
|
|
|
|
(map (lambda (x) (E x #f)) args))]))
|
2009-05-17 19:08:02 -04:00
|
|
|
(define (E-app mk-call rator args ctxt)
|
2009-05-14 02:52:05 -04:00
|
|
|
(equal-case rator
|
2009-05-17 19:08:02 -04:00
|
|
|
[((primitive make-parameter)) (E-make-parameter mk-call args ctxt)]
|
2009-05-14 02:52:05 -04:00
|
|
|
[else
|
|
|
|
(let ([names (get-fmls rator args)])
|
2009-05-17 19:08:02 -04:00
|
|
|
(mk-call
|
2009-05-14 02:52:05 -04:00
|
|
|
(E rator (list ctxt))
|
|
|
|
(let f ([args args] [names names])
|
|
|
|
(cond
|
|
|
|
[(pair? names)
|
|
|
|
(cons
|
|
|
|
(E (car args) (car names))
|
|
|
|
(f (cdr args) (cdr names)))]
|
|
|
|
[else
|
|
|
|
(map (lambda (x) (E x #f)) args)]))))]))
|
2007-10-10 04:41:11 -04:00
|
|
|
(define (E x ctxt)
|
2006-11-23 19:44:29 -05:00
|
|
|
(cond
|
|
|
|
[(pair? x)
|
2008-06-19 04:58:59 -04:00
|
|
|
(equal-case (car x)
|
2006-12-06 21:33:33 -05:00
|
|
|
[(quote) (make-constant (cadr x))]
|
2006-11-23 19:44:29 -05:00
|
|
|
[(if)
|
|
|
|
(make-conditional
|
2007-10-10 04:41:11 -04:00
|
|
|
(E (cadr x) #f)
|
|
|
|
(E (caddr x) ctxt)
|
|
|
|
(E (cadddr x) ctxt))]
|
2006-11-23 19:44:29 -05:00
|
|
|
[(set!)
|
|
|
|
(let ([lhs (cadr x)] [rhs (caddr x)])
|
2007-10-09 08:54:28 -04:00
|
|
|
(cond
|
|
|
|
[(lexical lhs) =>
|
2007-10-10 04:41:11 -04:00
|
|
|
(lambda (var)
|
2008-06-29 15:35:34 -04:00
|
|
|
(set-prelex-source-assigned?! var #t)
|
2007-10-10 04:41:11 -04:00
|
|
|
(make-assign var (E rhs lhs)))]
|
2007-11-17 11:06:17 -05:00
|
|
|
[else (make-global-set! lhs (E rhs lhs))]))]
|
2006-11-23 19:44:29 -05:00
|
|
|
[(begin)
|
2007-10-10 04:41:11 -04:00
|
|
|
(let f ([a (cadr x)] [d (cddr x)])
|
2006-11-23 19:44:29 -05:00
|
|
|
(cond
|
2007-10-10 04:41:11 -04:00
|
|
|
[(null? d) (E a ctxt)]
|
2006-12-06 21:39:13 -05:00
|
|
|
[else
|
2007-10-10 04:41:11 -04:00
|
|
|
(make-seq (E a #f) (f (car d) (cdr d)))]))]
|
2006-11-23 19:44:29 -05:00
|
|
|
[(letrec)
|
|
|
|
(let ([bind* (cadr x)] [body (caddr x)])
|
2007-01-09 01:44:00 -05:00
|
|
|
(let ([lhs* (map car bind*)]
|
2006-11-23 19:44:29 -05:00
|
|
|
[rhs* (map cadr bind*)])
|
|
|
|
(let ([nlhs* (gen-fml* lhs*)])
|
2007-10-10 04:41:11 -04:00
|
|
|
(let ([expr (make-recbind nlhs* (map E rhs* lhs*) (E body ctxt))])
|
2007-05-09 05:59:32 -04:00
|
|
|
(ungen-fml* lhs*)
|
|
|
|
expr))))]
|
|
|
|
[(letrec*)
|
|
|
|
(let ([bind* (cadr x)] [body (caddr x)])
|
|
|
|
(let ([lhs* (map car bind*)]
|
|
|
|
[rhs* (map cadr bind*)])
|
|
|
|
(let ([nlhs* (gen-fml* lhs*)])
|
2007-10-10 04:41:11 -04:00
|
|
|
(let ([expr (make-rec*bind nlhs* (map E rhs* lhs*) (E body ctxt))])
|
2006-12-06 21:33:33 -05:00
|
|
|
(ungen-fml* lhs*)
|
|
|
|
expr))))]
|
2007-11-17 09:53:22 -05:00
|
|
|
[(library-letrec*)
|
|
|
|
(let ([bind* (cadr x)] [body (caddr x)])
|
|
|
|
(let ([lhs* (map car bind*)]
|
|
|
|
[loc* (map cadr bind*)]
|
|
|
|
[rhs* (map caddr bind*)])
|
|
|
|
(let ([nlhs* (gen-fml* lhs*)])
|
2007-11-17 11:06:17 -05:00
|
|
|
(for-each
|
|
|
|
(lambda (lhs loc)
|
2008-06-29 15:35:34 -04:00
|
|
|
(set-prelex-global-location! lhs loc))
|
2007-11-17 11:06:17 -05:00
|
|
|
nlhs* loc*)
|
2007-11-17 09:53:22 -05:00
|
|
|
(let ([expr (make-rec*bind nlhs* (map E rhs* lhs*)
|
2007-11-17 11:06:17 -05:00
|
|
|
(let f ([lhs* nlhs*] [loc* loc*])
|
|
|
|
(cond
|
|
|
|
[(null? lhs*) (E body ctxt)]
|
|
|
|
[(not (car loc*)) (f (cdr lhs*) (cdr loc*))]
|
2008-06-29 15:35:34 -04:00
|
|
|
[else (f (cdr lhs*) (cdr loc*))])))])
|
2007-11-17 09:53:22 -05:00
|
|
|
(ungen-fml* lhs*)
|
|
|
|
expr))))]
|
2006-11-23 19:44:29 -05:00
|
|
|
[(case-lambda)
|
2009-03-30 05:28:30 -04:00
|
|
|
(let ([cls* (E-clambda-clause* (cdr x) ctxt)])
|
2008-06-19 01:47:56 -04:00
|
|
|
(make-clambda (gensym) cls* #f #f
|
|
|
|
(and (symbol? ctxt) ctxt)))]
|
2009-03-30 05:28:30 -04:00
|
|
|
[(annotated-case-lambda)
|
|
|
|
(let ([ae (cadr x)])
|
|
|
|
(let ([cls* (E-clambda-clause* (cddr x) ctxt)])
|
|
|
|
(make-clambda (gensym) cls* #f #f
|
|
|
|
(cons
|
|
|
|
(and (symbol? ctxt) ctxt)
|
2009-05-14 02:09:58 -04:00
|
|
|
(and (not (strip-source-info))
|
|
|
|
(annotation? ae)
|
|
|
|
(annotation-source ae))))))]
|
2007-10-10 09:18:11 -04:00
|
|
|
[(lambda)
|
|
|
|
(E `(case-lambda ,(cdr x)) ctxt)]
|
2006-11-23 19:44:29 -05:00
|
|
|
[(foreign-call)
|
|
|
|
(let ([name (quoted-string (cadr x))] [arg* (cddr x)])
|
2007-10-10 04:41:11 -04:00
|
|
|
(make-forcall name (map (lambda (x) (E x #f)) arg*)))]
|
2007-10-09 08:54:28 -04:00
|
|
|
[(primitive)
|
|
|
|
(let ([var (cadr x)])
|
|
|
|
(make-primref var))]
|
2009-05-14 02:52:05 -04:00
|
|
|
[(annotated-call)
|
2009-05-17 19:08:02 -04:00
|
|
|
(E-app
|
|
|
|
(if (generate-debug-calls)
|
|
|
|
(lambda (op rands)
|
|
|
|
(define (operator? x)
|
|
|
|
(struct-case x
|
|
|
|
[(primref x)
|
|
|
|
(guard (con [(assertion-violation? con) #t])
|
|
|
|
(system-value x)
|
|
|
|
#f)]
|
|
|
|
[else #f]))
|
|
|
|
(define (get-src/expr ae)
|
|
|
|
(if (annotation? ae)
|
|
|
|
(cons (annotation-source ae) (annotation-stripped ae))
|
|
|
|
(cons #f (syntax->datum ae))))
|
|
|
|
(define src/expr
|
|
|
|
(make-constant (get-src/expr (cadr x))))
|
|
|
|
(if (operator? op)
|
|
|
|
(make-funcall op rands)
|
|
|
|
(make-funcall (make-primref 'debug-call)
|
|
|
|
(cons* src/expr op rands))))
|
|
|
|
make-funcall)
|
|
|
|
(caddr x) (cdddr x) ctxt)]
|
|
|
|
[else (E-app make-funcall (car x) (cdr x) ctxt)])]
|
2007-10-09 08:54:28 -04:00
|
|
|
[(symbol? x)
|
2008-06-29 15:35:34 -04:00
|
|
|
(cond
|
|
|
|
[(lexical x) =>
|
|
|
|
(lambda (var)
|
|
|
|
(set-prelex-source-referenced?! var #t)
|
|
|
|
var)]
|
|
|
|
[else
|
|
|
|
(make-funcall
|
|
|
|
(make-primref 'top-level-value)
|
|
|
|
(list (make-constant x)))])]
|
2007-10-25 14:32:26 -04:00
|
|
|
[else (error 'recordize "invalid expression" x)]))
|
2007-10-10 04:41:11 -04:00
|
|
|
(E x #f))
|
2006-11-23 19:44:29 -05:00
|
|
|
|
|
|
|
(define (unparse x)
|
|
|
|
(define (E-args proper x)
|
|
|
|
(if proper
|
|
|
|
(map E x)
|
|
|
|
(let f ([a (car x)] [d (cdr x)])
|
|
|
|
(cond
|
|
|
|
[(null? d) (E a)]
|
|
|
|
[else (cons (E a) (f (car d) (cdr d)))]))))
|
|
|
|
(define (E x)
|
2007-10-12 02:59:27 -04:00
|
|
|
(struct-case x
|
2006-11-23 19:44:29 -05:00
|
|
|
[(constant c) `(quote ,c)]
|
2008-07-07 02:48:16 -04:00
|
|
|
[(known x t) `(known ,(E x) ,(T:description t))]
|
2006-11-23 19:44:29 -05:00
|
|
|
[(code-loc x) `(code-loc ,x)]
|
2008-06-29 15:35:34 -04:00
|
|
|
[(var x) (string->symbol (format ":~a" x))]
|
2008-07-07 02:48:16 -04:00
|
|
|
[(prelex name) (string->symbol (format ":~a" name))]
|
2006-11-23 19:44:29 -05:00
|
|
|
[(primref x) x]
|
|
|
|
[(conditional test conseq altern)
|
|
|
|
`(if ,(E test) ,(E conseq) ,(E altern))]
|
2006-12-21 09:49:30 -05:00
|
|
|
[(interrupt-call e0 e1)
|
|
|
|
`(interrupt-call ,(E e0) ,(E e1))]
|
2006-11-23 19:44:29 -05:00
|
|
|
[(primcall op arg*) `(,op . ,(map E arg*))]
|
|
|
|
[(bind lhs* rhs* body)
|
|
|
|
`(let ,(map (lambda (lhs rhs) (list (E lhs) (E rhs))) lhs* rhs*)
|
|
|
|
,(E body))]
|
|
|
|
[(recbind lhs* rhs* body)
|
|
|
|
`(letrec ,(map (lambda (lhs rhs) (list (E lhs) (E rhs))) lhs* rhs*)
|
|
|
|
,(E body))]
|
2007-05-09 05:59:32 -04:00
|
|
|
[(rec*bind lhs* rhs* body)
|
|
|
|
`(letrec* ,(map (lambda (lhs rhs) (list (E lhs) (E rhs))) lhs* rhs*)
|
|
|
|
,(E body))]
|
2007-11-17 11:06:17 -05:00
|
|
|
;[(library-recbind lhs* loc* rhs* body)
|
|
|
|
; `(letrec ,(map (lambda (lhs loc rhs) (list (E lhs) loc (E rhs)))
|
|
|
|
; lhs* loc* rhs*)
|
|
|
|
; ,(E body))]
|
2006-11-23 19:44:29 -05:00
|
|
|
[(fix lhs* rhs* body)
|
|
|
|
`(fix ,(map (lambda (lhs rhs) (list (E lhs) (E rhs))) lhs* rhs*)
|
|
|
|
,(E body))]
|
2007-02-10 18:51:12 -05:00
|
|
|
[(seq e0 e1)
|
|
|
|
(let ()
|
|
|
|
(define (f x ac)
|
2007-10-12 02:59:27 -04:00
|
|
|
(struct-case x
|
2007-02-10 18:51:12 -05:00
|
|
|
[(seq e0 e1) (f e0 (f e1 ac))]
|
|
|
|
[else (cons (E x) ac)]))
|
|
|
|
(cons 'begin (f e0 (f e1 '()))))]
|
2006-12-04 19:58:24 -05:00
|
|
|
[(clambda-case info body)
|
2008-06-28 05:25:44 -04:00
|
|
|
`( ; label: ,(case-info-label info)
|
2008-06-23 01:10:05 -04:00
|
|
|
,(E-args (case-info-proper info) (case-info-args info))
|
|
|
|
,(E body))]
|
2007-11-21 04:00:10 -05:00
|
|
|
[(clambda g cls* cp free)
|
2008-06-23 01:10:05 -04:00
|
|
|
`(clambda (label: ,g) ; cp: ,(E cp) ) ;free: ,(map E free))
|
2008-02-11 22:18:32 -05:00
|
|
|
,@(map E cls*))]
|
2006-12-04 19:05:02 -05:00
|
|
|
[(clambda label clauses free)
|
2006-11-23 19:44:29 -05:00
|
|
|
`(code ,label . ,(map E clauses))]
|
2008-02-11 22:18:32 -05:00
|
|
|
[(closure code free* wk?)
|
|
|
|
`(closure ,@(if wk? '(wk) '()) ,(E code) ,(map E free*))]
|
2006-11-23 19:44:29 -05:00
|
|
|
[(codes list body)
|
|
|
|
`(codes ,(map E list)
|
|
|
|
,(E body))]
|
|
|
|
[(funcall rator rand*) `(funcall ,(E rator) . ,(map E rand*))]
|
2006-12-04 22:05:44 -05:00
|
|
|
[(jmpcall label rator rand*)
|
|
|
|
`(jmpcall ,label ,(E rator) . ,(map E rand*))]
|
2006-11-23 19:44:29 -05:00
|
|
|
[(forcall rator rand*) `(foreign-call ,rator . ,(map E rand*))]
|
|
|
|
[(assign lhs rhs) `(set! ,(E lhs) ,(E rhs))]
|
|
|
|
[(return x) `(return ,(E x))]
|
|
|
|
[(new-frame base-idx size body)
|
|
|
|
`(new-frame [base: ,base-idx]
|
|
|
|
[size: ,size]
|
|
|
|
,(E body))]
|
|
|
|
[(frame-var idx)
|
|
|
|
(string->symbol (format "fv.~a" idx))]
|
|
|
|
[(cp-var idx)
|
|
|
|
(string->symbol (format "cp.~a" idx))]
|
|
|
|
[(save-cp expr)
|
|
|
|
`(save-cp ,(E expr))]
|
|
|
|
[(eval-cp check body)
|
|
|
|
`(eval-cp ,check ,(E body))]
|
2006-12-04 22:43:42 -05:00
|
|
|
[(call-cp call-convention label save-cp? rp-convention base-idx arg-count live-mask)
|
2006-11-23 19:44:29 -05:00
|
|
|
`(call-cp [conv: ,call-convention]
|
2006-12-04 22:05:44 -05:00
|
|
|
[label: ,label]
|
2006-12-30 14:52:37 -05:00
|
|
|
[rpconv: ,(if (symbol? rp-convention)
|
|
|
|
rp-convention
|
|
|
|
(E rp-convention))]
|
2006-11-23 19:44:29 -05:00
|
|
|
[base-idx: ,base-idx]
|
|
|
|
[arg-count: ,arg-count]
|
|
|
|
[live-mask: ,live-mask])]
|
2006-12-30 14:52:37 -05:00
|
|
|
[(tailcall-cp convention label arg-count)
|
|
|
|
`(tailcall-cp ,convention ,label ,arg-count)]
|
2006-11-23 19:44:29 -05:00
|
|
|
[(foreign-label x) `(foreign-label ,x)]
|
2006-12-30 14:52:37 -05:00
|
|
|
[(mvcall prod cons) `(mvcall ,(E prod) ,(E cons))]
|
2007-02-10 18:51:12 -05:00
|
|
|
[(fvar idx) (string->symbol (format "fv.~a" idx))]
|
2007-02-17 18:09:03 -05:00
|
|
|
[(nfv idx) 'nfv]
|
2007-02-10 18:51:12 -05:00
|
|
|
[(locals vars body) `(locals ,(map E vars) ,(E body))]
|
2007-02-17 18:09:03 -05:00
|
|
|
[(asm-instr op d s)
|
|
|
|
`(asm ,op ,(E d) ,(E s))]
|
2007-02-17 19:22:14 -05:00
|
|
|
[(disp s0 s1)
|
|
|
|
`(disp ,(E s0) ,(E s1))]
|
2007-02-17 18:09:03 -05:00
|
|
|
[(nframe vars live body) `(nframe ;[vars: ,(map E vars)]
|
|
|
|
;[live: ,(map E live)]
|
2007-02-12 17:59:58 -05:00
|
|
|
,(E body))]
|
2007-02-22 21:58:38 -05:00
|
|
|
[(shortcut body handler)
|
2007-02-22 23:02:50 -05:00
|
|
|
`(shortcut ,(E body) ,(E handler))]
|
2007-03-11 20:00:08 -04:00
|
|
|
[(ntcall target valuw args mask size)
|
|
|
|
`(ntcall ,target ,size)]
|
2007-02-17 18:09:03 -05:00
|
|
|
[else
|
|
|
|
(if (symbol? x)
|
|
|
|
x
|
|
|
|
"#<unknown>")]))
|
2006-11-23 19:44:29 -05:00
|
|
|
(E x))
|
|
|
|
|
2008-06-29 15:35:34 -04:00
|
|
|
|
|
|
|
(define (unparse-pretty x)
|
|
|
|
(define n 0)
|
|
|
|
(define h (make-eq-hashtable))
|
|
|
|
(define (Var x)
|
|
|
|
(or (hashtable-ref h x #f)
|
|
|
|
(let ([v (string->symbol (format "~a_~a" (prelex-name x) n))])
|
|
|
|
(hashtable-set! h x v)
|
|
|
|
(set! n (+ n 1))
|
|
|
|
v)))
|
|
|
|
(define (map f ls)
|
|
|
|
(cond
|
|
|
|
[(null? ls) '()]
|
|
|
|
[else
|
|
|
|
(let ([a (f (car ls))])
|
|
|
|
(cons a (map f (cdr ls))))]))
|
|
|
|
(define (E-args proper x)
|
|
|
|
(if proper
|
|
|
|
(map Var x)
|
|
|
|
(let f ([a (car x)] [d (cdr x)])
|
|
|
|
(cond
|
|
|
|
[(null? d) (Var a)]
|
|
|
|
[else
|
|
|
|
(let ([a (Var a)])
|
|
|
|
(cons a (f (car d) (cdr d))))]))))
|
|
|
|
(define (clambda-clause x)
|
|
|
|
(struct-case x
|
|
|
|
[(clambda-case info body)
|
|
|
|
(let ([args (E-args (case-info-proper info) (case-info-args info)) ])
|
|
|
|
(list args (E body)))]))
|
|
|
|
(define (build-let b* body)
|
|
|
|
(cond
|
|
|
|
[(and (= (length b*) 1)
|
|
|
|
(pair? body)
|
|
|
|
(or (eq? (car body) 'let*)
|
|
|
|
(and (eq? (car body) 'let)
|
|
|
|
(= (length (cadr body)) 1))))
|
|
|
|
(list 'let* (append b* (cadr body)) (caddr body))]
|
|
|
|
[else
|
|
|
|
(list 'let b* body)]))
|
|
|
|
(define (E x)
|
|
|
|
(struct-case x
|
|
|
|
[(constant c) `(quote ,c)]
|
|
|
|
[(prelex) (Var x)]
|
|
|
|
[(primref x) x]
|
2008-07-12 01:31:40 -04:00
|
|
|
[(known x t) `(known ,(E x) ,(T:description t))]
|
2008-06-29 15:35:34 -04:00
|
|
|
[(conditional test conseq altern)
|
|
|
|
(cons 'if (map E (list test conseq altern)))]
|
|
|
|
[(primcall op arg*) (cons op (map E arg*))]
|
|
|
|
[(bind lhs* rhs* body)
|
|
|
|
(let* ([lhs* (map Var lhs*)]
|
|
|
|
[rhs* (map E rhs*)]
|
|
|
|
[body (E body)])
|
|
|
|
(import (only (ikarus) map))
|
|
|
|
(build-let (map list lhs* rhs*) body))]
|
|
|
|
[(fix lhs* rhs* body)
|
|
|
|
(let* ([lhs* (map Var lhs*)]
|
|
|
|
[rhs* (map E rhs*)]
|
|
|
|
[body (E body)])
|
|
|
|
(import (only (ikarus) map))
|
|
|
|
(list 'letrec (map list lhs* rhs*) body))]
|
2009-05-30 06:18:43 -04:00
|
|
|
[(recbind lhs* rhs* body)
|
|
|
|
(let* ([lhs* (map Var lhs*)]
|
|
|
|
[rhs* (map E rhs*)]
|
|
|
|
[body (E body)])
|
|
|
|
(import (only (ikarus) map))
|
|
|
|
(list 'letrec (map list lhs* rhs*) body))]
|
|
|
|
[(rec*bind lhs* rhs* body)
|
|
|
|
(let* ([lhs* (map Var lhs*)]
|
|
|
|
[rhs* (map E rhs*)]
|
|
|
|
[body (E body)])
|
|
|
|
(import (only (ikarus) map))
|
|
|
|
(list 'letrec* (map list lhs* rhs*) body))]
|
2008-06-29 15:35:34 -04:00
|
|
|
[(seq e0 e1)
|
|
|
|
(cons 'begin
|
|
|
|
(let f ([e0 e0] [e* (list e1)])
|
|
|
|
(struct-case e0
|
|
|
|
[(seq e00 e01)
|
|
|
|
(f e00 (cons e01 e*))]
|
|
|
|
[else
|
|
|
|
(let ([x (E e0)])
|
|
|
|
(if (null? e*)
|
|
|
|
(list x)
|
|
|
|
(cons x (f (car e*) (cdr e*)))))])))]
|
|
|
|
[(clambda g cls* cp free)
|
|
|
|
(let ([cls* (map clambda-clause cls*)])
|
|
|
|
(cond
|
|
|
|
[(= (length cls*) 1) (cons 'lambda (car cls*))]
|
|
|
|
[else (cons 'case-lambda cls*)]))]
|
|
|
|
[(funcall rator rand*)
|
|
|
|
(let ([rator (E rator)])
|
|
|
|
(cons rator (map E rand*)))]
|
|
|
|
[(forcall rator rand*) `(foreign-call ,rator . ,(map E rand*))]
|
|
|
|
[(assign lhs rhs) `(set! ,(E lhs) ,(E rhs))]
|
|
|
|
[(foreign-label x) `(foreign-label ,x)]
|
|
|
|
[else x]))
|
|
|
|
(E x))
|
|
|
|
|
2007-02-12 13:58:04 -05:00
|
|
|
(define open-mvcalls (make-parameter #t))
|
2007-01-09 01:24:07 -05:00
|
|
|
|
2006-11-23 19:44:29 -05:00
|
|
|
(define (optimize-direct-calls x)
|
|
|
|
(define who 'optimize-direct-calls)
|
|
|
|
(define (make-conses ls)
|
|
|
|
(cond
|
|
|
|
[(null? ls) (make-constant '())]
|
|
|
|
[else
|
2007-06-05 20:11:12 -04:00
|
|
|
(make-funcall (make-primref 'cons)
|
2006-11-23 19:44:29 -05:00
|
|
|
(list (car ls) (make-conses (cdr ls))))]))
|
|
|
|
(define (properize lhs* rhs*)
|
|
|
|
(cond
|
|
|
|
[(null? lhs*) (error who "improper improper")]
|
|
|
|
[(null? (cdr lhs*))
|
|
|
|
(list (make-conses rhs*))]
|
|
|
|
[else (cons (car rhs*) (properize (cdr lhs*) (cdr rhs*)))]))
|
|
|
|
(define (inline-case cls rand*)
|
2007-10-12 02:59:27 -04:00
|
|
|
(struct-case cls
|
2006-12-04 19:58:24 -05:00
|
|
|
[(clambda-case info body)
|
2007-10-12 02:59:27 -04:00
|
|
|
(struct-case info
|
2006-12-04 20:13:21 -05:00
|
|
|
[(case-info label fml* proper)
|
2006-12-04 19:58:24 -05:00
|
|
|
(if proper
|
|
|
|
(and (fx= (length fml*) (length rand*))
|
|
|
|
(make-bind fml* rand* body))
|
|
|
|
(and (fx<= (length fml*) (length rand*))
|
|
|
|
(make-bind fml* (properize fml* rand*) body)))])]))
|
2006-11-23 19:44:29 -05:00
|
|
|
(define (try-inline cls* rand* default)
|
|
|
|
(cond
|
|
|
|
[(null? cls*) default]
|
|
|
|
[(inline-case (car cls*) rand*)]
|
|
|
|
[else (try-inline (cdr cls*) rand* default)]))
|
2009-05-17 19:08:02 -04:00
|
|
|
(define (inline mk rator rand*)
|
2006-12-30 14:52:37 -05:00
|
|
|
(define (valid-mv-consumer? x)
|
2007-10-12 02:59:27 -04:00
|
|
|
(struct-case x
|
2006-12-30 14:52:37 -05:00
|
|
|
[(clambda L cases F)
|
|
|
|
(and (fx= (length cases) 1)
|
2007-10-12 02:59:27 -04:00
|
|
|
(struct-case (car cases)
|
2006-12-30 14:52:37 -05:00
|
|
|
[(clambda-case info body)
|
2007-10-12 02:59:27 -04:00
|
|
|
(struct-case info
|
2006-12-30 14:52:37 -05:00
|
|
|
[(case-info L args proper) proper])]))]
|
|
|
|
[else #f]))
|
2007-01-26 10:23:07 -05:00
|
|
|
(define (single-value-consumer? x)
|
2007-10-12 02:59:27 -04:00
|
|
|
(struct-case x
|
2007-01-26 10:23:07 -05:00
|
|
|
[(clambda L cases F)
|
|
|
|
(and (fx= (length cases) 1)
|
2007-10-12 02:59:27 -04:00
|
|
|
(struct-case (car cases)
|
2007-01-26 10:23:07 -05:00
|
|
|
[(clambda-case info body)
|
2007-10-12 02:59:27 -04:00
|
|
|
(struct-case info
|
2007-01-26 10:23:07 -05:00
|
|
|
[(case-info L args proper)
|
|
|
|
(and proper (fx= (length args) 1))])]))]
|
|
|
|
[else #f]))
|
2006-12-30 14:52:37 -05:00
|
|
|
(define (valid-mv-producer? x)
|
2007-10-12 02:59:27 -04:00
|
|
|
(struct-case x
|
2006-12-30 14:52:37 -05:00
|
|
|
[(funcall) #t]
|
|
|
|
[(conditional) #f]
|
|
|
|
[(bind lhs* rhs* body) (valid-mv-producer? body)]
|
2007-05-01 02:19:05 -04:00
|
|
|
[else #f] ;; FIXME BUG
|
|
|
|
))
|
2007-10-12 02:59:27 -04:00
|
|
|
(struct-case rator
|
2006-12-04 19:00:43 -05:00
|
|
|
[(clambda g cls*)
|
2006-11-23 19:44:29 -05:00
|
|
|
(try-inline cls* rand*
|
2009-05-17 19:08:02 -04:00
|
|
|
(mk rator rand*))]
|
2006-12-30 14:52:37 -05:00
|
|
|
[(primref op)
|
|
|
|
(case op
|
|
|
|
;;; FIXME HERE
|
2006-12-31 17:46:47 -05:00
|
|
|
[(call-with-values)
|
2006-12-30 14:52:37 -05:00
|
|
|
(cond
|
2007-02-12 13:58:04 -05:00
|
|
|
[(and (open-mvcalls) (fx= (length rand*) 2))
|
2006-12-30 14:52:37 -05:00
|
|
|
(let ([producer (inline (car rand*) '())]
|
|
|
|
[consumer (cadr rand*)])
|
|
|
|
(cond
|
2007-01-26 10:23:07 -05:00
|
|
|
[(single-value-consumer? consumer)
|
|
|
|
(inline consumer (list producer))]
|
2006-12-30 14:52:37 -05:00
|
|