2006-11-23 19:44:29 -05:00
|
|
|
|
2007-05-15 10:18:58 -04:00
|
|
|
(library (ikarus compiler)
|
2007-06-02 03:26:06 -04:00
|
|
|
(export compile-core-expr-to-port
|
|
|
|
assembler-output
|
2007-05-05 21:18:41 -04:00
|
|
|
current-primitive-locations eval-core)
|
|
|
|
(import
|
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)
|
|
|
|
(only (ikarus system $records) $record-ref $record/rtd?)
|
2007-05-06 20:12:25 -04:00
|
|
|
(except (ikarus)
|
2007-05-05 21:18:41 -04:00
|
|
|
compile-core-expr-to-port assembler-output
|
|
|
|
current-primitive-locations eval-core)
|
2007-05-15 10:18:58 -04:00
|
|
|
(ikarus intel-assembler)
|
2007-09-15 00:14:47 -04:00
|
|
|
;(ikarus fasl write)
|
|
|
|
)
|
2007-05-01 04:37:35 -04:00
|
|
|
|
|
|
|
|
2006-12-16 18:18:11 -05:00
|
|
|
(define-syntax record-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-05-01 17:25:43 -04:00
|
|
|
[() (with-syntax ([x x]) #'(error #f "unmatched ~s in ~s" 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)])
|
|
|
|
#'(if ($record/rtd? v rtd)
|
|
|
|
(let ([rec-field* ($record-ref v id*)] ...)
|
|
|
|
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
|
|
|
|
|
|
|
(include "set-operations.ss")
|
|
|
|
|
|
|
|
|
|
|
|
(define-record constant (value))
|
|
|
|
(define-record code-loc (label))
|
|
|
|
(define-record foreign-label (label))
|
2007-02-19 18:21:35 -05:00
|
|
|
(define-record var
|
|
|
|
(name assigned referenced
|
|
|
|
reg-conf frm-conf var-conf reg-move frm-move var-move
|
2007-03-10 16:47:13 -05:00
|
|
|
loc index))
|
2006-11-23 19:44:29 -05:00
|
|
|
(define-record cp-var (idx))
|
|
|
|
(define-record frame-var (idx))
|
|
|
|
(define-record new-frame (base-idx size body))
|
|
|
|
(define-record save-cp (loc))
|
|
|
|
(define-record eval-cp (check body))
|
|
|
|
(define-record return (value))
|
|
|
|
(define-record call-cp
|
2006-12-04 22:43:42 -05:00
|
|
|
(call-convention label save-cp? rp-convention base-idx arg-count live-mask))
|
2006-12-04 22:05:44 -05:00
|
|
|
(define-record tailcall-cp (convention label arg-count))
|
2006-11-23 19:44:29 -05:00
|
|
|
(define-record primcall (op arg*))
|
|
|
|
(define-record primref (name))
|
|
|
|
(define-record conditional (test conseq altern))
|
2006-12-21 09:49:30 -05:00
|
|
|
(define-record interrupt-call (test handler))
|
2006-11-23 19:44:29 -05:00
|
|
|
(define-record bind (lhs* rhs* body))
|
|
|
|
(define-record recbind (lhs* rhs* body))
|
2007-05-09 05:59:32 -04:00
|
|
|
(define-record rec*bind (lhs* rhs* body))
|
2006-11-23 19:44:29 -05:00
|
|
|
(define-record fix (lhs* rhs* body))
|
|
|
|
|
|
|
|
(define-record seq (e0 e1))
|
2006-12-04 20:13:21 -05:00
|
|
|
(define-record case-info (label args proper))
|
2006-12-04 19:58:24 -05:00
|
|
|
(define-record clambda-case (info body))
|
2006-12-04 19:05:02 -05:00
|
|
|
(define-record clambda (label cases free))
|
2006-11-23 19:44:29 -05:00
|
|
|
(define-record closure (code free*))
|
|
|
|
(define-record funcall (op rand*))
|
2006-12-04 22:05:44 -05:00
|
|
|
(define-record jmpcall (label op rand*))
|
2006-11-23 19:44:29 -05:00
|
|
|
(define-record forcall (op rand*))
|
|
|
|
(define-record codes (list body))
|
|
|
|
(define-record assign (lhs rhs))
|
2006-12-30 14:52:37 -05:00
|
|
|
(define-record mvcall (producer consumer))
|
2006-11-23 19:44:29 -05:00
|
|
|
|
2007-02-10 18:51:12 -05:00
|
|
|
|
|
|
|
|
2007-02-22 21:58:38 -05:00
|
|
|
(define-record shortcut (body handler))
|
|
|
|
|
2007-02-10 18:51:12 -05:00
|
|
|
(define-record fvar (idx))
|
|
|
|
(define-record object (val))
|
|
|
|
(define-record locals (vars body))
|
2007-02-11 04:12:09 -05:00
|
|
|
(define-record nframe (vars live body))
|
2007-02-17 18:09:03 -05:00
|
|
|
(define-record nfv (conf loc var-conf frm-conf nfv-conf))
|
2007-02-12 13:58:04 -05:00
|
|
|
(define-record ntcall (target value args mask size))
|
2007-02-12 17:59:58 -05:00
|
|
|
(define-record asm-instr (op dst src))
|
|
|
|
(define-record disp (s0 s1))
|
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)])]
|
|
|
|
[else (error 'mkfvar "~s is not a fixnum" i)]))))
|
2007-02-10 18:51:12 -05:00
|
|
|
|
2006-11-23 19:44:29 -05:00
|
|
|
(define (unique-var x)
|
2007-03-10 16:47:13 -05:00
|
|
|
(make-var (gensym x) #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*)
|
2006-12-06 21:33:33 -05:00
|
|
|
(let ([v (unique-var (car fml*))])
|
|
|
|
(putprop (car fml*) *cookie* v)
|
|
|
|
(cons v (gen-fml* (cdr fml*))))]
|
2006-11-23 19:44:29 -05:00
|
|
|
[(symbol? fml*)
|
2006-12-06 21:33:33 -05:00
|
|
|
(let ([v (unique-var fml*)])
|
|
|
|
(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)
|
|
|
|
(error 'quoted-sym "not a quoted symbol ~s" 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)
|
|
|
|
(error 'quoted-string "not a quoted string ~s" x)))
|
2006-12-06 21:33:33 -05:00
|
|
|
(define (Var x)
|
|
|
|
(or (getprop x *cookie*)
|
|
|
|
(error 'recordize "unbound ~s" x)))
|
|
|
|
(define (E x)
|
2006-11-23 19:44:29 -05:00
|
|
|
(cond
|
|
|
|
[(pair? x)
|
|
|
|
(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
|
2006-12-06 21:33:33 -05:00
|
|
|
(E (cadr x))
|
|
|
|
(E (caddr x))
|
|
|
|
(E (cadddr x)))]
|
2006-11-23 19:44:29 -05:00
|
|
|
[(set!)
|
|
|
|
(let ([lhs (cadr x)] [rhs (caddr x)])
|
2006-12-06 21:33:33 -05:00
|
|
|
(make-assign (Var lhs) (E rhs)))]
|
2006-11-23 19:44:29 -05:00
|
|
|
[(begin)
|
2006-12-06 21:39:13 -05:00
|
|
|
(let f ([a (E (cadr x))] [d (cddr x)])
|
2006-11-23 19:44:29 -05:00
|
|
|
(cond
|
2006-12-06 21:39:13 -05:00
|
|
|
[(null? d) a]
|
|
|
|
[else
|
|
|
|
(f (make-seq a (E (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-05-09 05:59:32 -04:00
|
|
|
(let ([expr (make-recbind nlhs* (map E rhs*) (E body))])
|
|
|
|
(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*)])
|
|
|
|
(let ([expr (make-rec*bind nlhs* (map E rhs*) (E body))])
|
2006-12-06 21:33:33 -05:00
|
|
|
(ungen-fml* lhs*)
|
|
|
|
expr))))]
|
2006-11-23 19:44:29 -05:00
|
|
|
[(case-lambda)
|
|
|
|
(let ([cls*
|
|
|
|
(map
|
|
|
|
(lambda (cls)
|
|
|
|
(let ([fml* (car cls)] [body (cadr cls)])
|
|
|
|
(let ([nfml* (gen-fml* fml*)])
|
2006-12-06 21:33:33 -05:00
|
|
|
(let ([body (E body)])
|
|
|
|
(ungen-fml* fml*)
|
2006-11-23 19:44:29 -05:00
|
|
|
(make-clambda-case
|
2006-12-04 19:58:24 -05:00
|
|
|
(make-case-info
|
2006-12-04 20:13:21 -05:00
|
|
|
(gensym)
|
2006-12-04 19:58:24 -05:00
|
|
|
(properize nfml*)
|
|
|
|
(list? fml*))
|
2006-11-23 19:44:29 -05:00
|
|
|
body)))))
|
|
|
|
(cdr x))])
|
2006-12-04 19:05:02 -05:00
|
|
|
(make-clambda (gensym) cls* #f))]
|
2006-11-23 19:44:29 -05:00
|
|
|
[(foreign-call)
|
|
|
|
(let ([name (quoted-string (cadr x))] [arg* (cddr x)])
|
2006-12-06 21:33:33 -05:00
|
|
|
(make-forcall name (map E arg*)))]
|
2006-11-23 19:44:29 -05:00
|
|
|
[(|#primitive|)
|
|
|
|
(let ([var (cadr x)])
|
|
|
|
(make-primref var))]
|
|
|
|
[(top-level-value)
|
|
|
|
(let ([var (quoted-sym (cadr x))])
|
2007-05-02 20:36:23 -04:00
|
|
|
(make-funcall
|
|
|
|
(make-primref 'top-level-value)
|
|
|
|
(list (make-constant var))))]
|
2006-11-23 19:44:29 -05:00
|
|
|
[(set-top-level-value!)
|
|
|
|
(make-funcall (make-primref 'set-top-level-value!)
|
2006-12-06 21:33:33 -05:00
|
|
|
(map E (cdr x)))]
|
2006-11-23 19:44:29 -05:00
|
|
|
[(void)
|
|
|
|
(make-constant (void))]
|
|
|
|
[else
|
2006-12-06 21:33:33 -05:00
|
|
|
(make-funcall (E (car x)) (map E (cdr x)))])]
|
|
|
|
[(symbol? x) (Var x)]
|
2006-11-23 19:44:29 -05:00
|
|
|
[else (error 'recordize "invalid expression ~s" x)]))
|
2006-12-06 21:33:33 -05:00
|
|
|
(E x))
|
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)
|
|
|
|
(record-case x
|
|
|
|
[(constant c) `(quote ,c)]
|
|
|
|
[(code-loc x) `(code-loc ,x)]
|
|
|
|
[(var x) (string->symbol (format "v:~a" x))]
|
|
|
|
[(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))]
|
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)
|
|
|
|
(record-case x
|
|
|
|
[(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)
|
2007-02-10 18:51:12 -05:00
|
|
|
`(,(E-args (case-info-proper info)
|
2006-12-04 19:58:24 -05:00
|
|
|
(case-info-args info))
|
|
|
|
,(E body))]
|
2006-12-30 14:52:37 -05:00
|
|
|
[(clambda g cls* free)
|
2007-02-10 18:51:12 -05:00
|
|
|
`(,g (case-lambda . ,(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))]
|
|
|
|
[(closure code free*)
|
|
|
|
`(closure ,(E code) ,(map E free*))]
|
|
|
|
[(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))
|
|
|
|
|
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*)
|
|
|
|
(record-case cls
|
2006-12-04 19:58:24 -05:00
|
|
|
[(clambda-case info body)
|
|
|
|
(record-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)]))
|
|
|
|
(define (inline rator rand*)
|
2006-12-30 14:52:37 -05:00
|
|
|
(define (valid-mv-consumer? x)
|
|
|
|
(record-case x
|
|
|
|
[(clambda L cases F)
|
|
|
|
(and (fx= (length cases) 1)
|
|
|
|
(record-case (car cases)
|
|
|
|
[(clambda-case info body)
|
|
|
|
(record-case info
|
|
|
|
[(case-info L args proper) proper])]))]
|
|
|
|
[else #f]))
|
2007-01-26 10:23:07 -05:00
|
|
|
(define (single-value-consumer? x)
|
|
|
|
(record-case x
|
|
|
|
[(clambda L cases F)
|
|
|
|
(and (fx= (length cases) 1)
|
|
|
|
(record-case (car cases)
|
|
|
|
[(clambda-case info body)
|
|
|
|
(record-case info
|
|
|
|
[(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)
|
|
|
|
(record-case x
|
|
|
|
[(funcall) #t]
|
|
|
|
[(conditional) #f]
|
|
|
|
[(bind lhs* rhs* body) (valid-mv-producer? body)]
|
2007-05-01 02:19:05 -04:00
|
|
|
[else #f] ;; FIXME BUG
|
|
|
|
; [else (error 'valid-mv-producer? "unhandles ~s"
|
|
|
|
; (unparse x))]
|
|
|
|
))
|
2006-11-23 19:44:29 -05:00
|
|
|
(record-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*
|
2006-12-04 19:00:43 -05:00
|
|
|
(make-funcall 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
|
|
|
[(and (valid-mv-consumer? consumer)
|
|
|
|
(valid-mv-producer? producer))
|
|
|
|
(make-mvcall producer consumer)]
|
|
|
|
[else
|
|
|
|
(make-funcall rator rand*)]))]
|
|
|
|
[else
|
|
|
|
(make-funcall rator rand*)])]
|
|
|
|
[else
|
|
|
|
(make-funcall rator rand*)])]
|
2006-11-23 19:44:29 -05:00
|
|
|
[else (make-funcall rator rand*)]))
|
|
|
|
(define (Expr x)
|
|
|
|
(record-case x
|
|
|
|
[(constant) x]
|
|
|
|
[(var) x]
|
|
|
|
[(primref) x]
|
|
|
|
[(bind lhs* rhs* body)
|
|
|
|
(make-bind lhs* (map Expr rhs*) (Expr body))]
|
|
|
|
[(recbind lhs* rhs* body)
|
|
|
|
(make-recbind lhs* (map Expr rhs*) (Expr body))]
|
2007-05-09 05:59:32 -04:00
|
|
|
[(rec*bind lhs* rhs* body)
|
|
|
|
(make-rec*bind lhs* (map Expr rhs*) (Expr body))]
|
2006-11-23 19:44:29 -05:00
|
|
|
[(conditional test conseq altern)
|
|
|
|
(make-conditional
|
|
|
|
(Expr test)
|
|
|
|
(Expr conseq)
|
|
|
|
(Expr altern))]
|
|
|
|
[(seq e0 e1)
|
|
|
|
(make-seq (Expr e0) (Expr e1))]
|
2006-12-04 19:00:43 -05:00
|
|
|
[(clambda g cls*)
|
|
|
|
(make-clambda g
|
2006-11-23 19:44:29 -05:00
|
|
|
(map (lambda (x)
|
|
|
|
(record-case x
|
2006-12-04 19:58:24 -05:00
|
|
|
[(clambda-case info body)
|
|
|
|
(make-clambda-case info (Expr body))]))
|
2006-12-04 19:05:02 -05:00
|
|
|
cls*)
|
|
|
|
#f)]
|
2006-11-23 19:44:29 -05:00
|
|
|
[(funcall rator rand*)
|
|
|
|
(inline (Expr rator) (map Expr rand*))]
|
|
|
|
[(forcall rator rand*)
|
|
|
|
(make-forcall rator (map Expr rand*))]
|
|
|
|
[(assign lhs rhs)
|
|
|
|
(make-assign lhs (Expr rhs))]
|
|
|
|
[else (error who "invalid expression ~s" (unparse x))]))
|
|
|
|
(Expr x))
|
|
|
|
|
|
|
|
|
2007-05-09 06:30:09 -04:00
|
|
|
(define simple-primitives
|
|
|
|
;;; primitives that are side-effect-free
|
|
|
|
;;; FIXME: surely something must go here, no?
|
|
|
|
'())
|
|
|
|
|
2006-11-23 19:44:29 -05:00
|
|
|
(define (optimize-letrec x)
|
|
|
|
(define who 'optimize-letrec)
|
|
|
|
(define (extend-hash lhs* h ref)
|
|
|
|
(for-each (lambda (lhs) (put-hash-table! h lhs #t)) lhs*)
|
|
|
|
(lambda (x)
|
|
|
|
(unless (get-hash-table h x #f)
|
|
|
|
(put-hash-table! h x #t)
|
|
|
|
(ref x))))
|
|
|
|
(define (E* x* ref comp)
|
|
|
|
(cond
|
|
|
|
[(null? x*) '()]
|
|
|
|
[else
|
|
|
|
(cons (E (car x*) ref comp)
|
|
|
|
(E* (cdr x*) ref comp))]))
|
2007-06-06 03:14:07 -04:00
|
|
|
(define (do-rhs*-old i lhs* rhs* ref comp vref vcomp)
|
2006-11-23 19:44:29 -05:00
|
|
|
(cond
|
|
|
|
[(null? rhs*) '()]
|
|
|
|
[else
|
|
|
|
(let ([h (make-hash-table)])
|
|
|
|
(let ([ref
|
|
|
|
(lambda (x)
|
|
|
|
(unless (get-hash-table h x #f)
|
|
|
|
(put-hash-table! h x #t)
|
|
|
|
(ref x)
|
|
|
|
(when (memq x lhs*)
|
|
|
|
(vector-set! vref i #t))))]
|
|
|
|
[comp
|
|
|
|
(lambda ()
|
|
|
|
(vector-set! vcomp i #t)
|
|
|
|
(comp))])
|
|
|
|
(cons (E (car rhs*) ref comp)
|
2007-06-06 03:14:07 -04:00
|
|
|
(do-rhs* (fxadd1 i) lhs* (cdr rhs*) ref comp vref vcomp))))]))
|
|
|
|
(define (do-rhs* i lhs* rhs* ref comp vref vcomp)
|
|
|
|
(cond
|
|
|
|
[(null? rhs*) '()]
|
|
|
|
[else
|
|
|
|
(let ([h (make-hash-table)]
|
|
|
|
[rest (do-rhs* (fxadd1 i) lhs* (cdr rhs*) ref comp vref vcomp)])
|
|
|
|
(let ([ref
|
|
|
|
(lambda (x)
|
|
|
|
(unless (get-hash-table h x #f)
|
|
|
|
(put-hash-table! h x #t)
|
|
|
|
(ref x)
|
|
|
|
(when (memq x lhs*)
|
|
|
|
(vector-set! vref i #t))))]
|
|
|
|
[comp
|
|
|
|
(lambda ()
|
|
|
|
(vector-set! vcomp i #t)
|
|
|
|
(comp))])
|
|
|
|
(cons (E (car rhs*) ref comp) rest)))]))
|
2006-11-23 19:44:29 -05:00
|
|
|
(define (partition-rhs* i lhs* rhs* vref vcomp)
|
|
|
|
(cond
|
|
|
|
[(null? lhs*) (values '() '() '() '() '() '())]
|
|
|
|
[else
|
|
|
|
(let-values
|
|
|
|
([(slhs* srhs* llhs* lrhs* clhs* crhs*)
|
|
|
|
(partition-rhs* (fxadd1 i) (cdr lhs*) (cdr rhs*) vref vcomp)]
|
|
|
|
[(lhs rhs) (values (car lhs*) (car rhs*))])
|
|
|
|
(cond
|
|
|
|
[(var-assigned lhs)
|
|
|
|
(values slhs* srhs* llhs* lrhs* (cons lhs clhs*) (cons rhs crhs*))]
|
|
|
|
[(clambda? rhs)
|
|
|
|
(values slhs* srhs* (cons lhs llhs*) (cons rhs lrhs*) clhs* crhs*)]
|
|
|
|
[(or (vector-ref vref i) (vector-ref vcomp i))
|
|
|
|
(values slhs* srhs* llhs* lrhs* (cons lhs clhs*) (cons rhs crhs*))]
|
|
|
|
[else
|
|
|
|
(values (cons lhs slhs*) (cons rhs srhs*) llhs* lrhs* clhs* crhs*)]
|
|
|
|
))]))
|
2007-05-09 05:59:32 -04:00
|
|
|
(define (do-recbind lhs* rhs* body ref comp letrec?)
|
2006-11-23 19:44:29 -05:00
|
|
|
(let ([h (make-hash-table)]
|
|
|
|
[vref (make-vector (length lhs*) #f)]
|
|
|
|
[vcomp (make-vector (length lhs*) #f)])
|
|
|
|
(let* ([ref (extend-hash lhs* h ref)]
|
|
|
|
[body (E body ref comp)])
|
|
|
|
(let ([rhs* (do-rhs* 0 lhs* rhs* ref comp vref vcomp)])
|
|
|
|
(let-values ([(slhs* srhs* llhs* lrhs* clhs* crhs*)
|
|
|
|
(partition-rhs* 0 lhs* rhs* vref vcomp)])
|
2007-06-05 20:11:12 -04:00
|
|
|
(let ([v* (map (lambda (x) (make-constant (void))) clhs*)])
|
2007-06-06 03:14:07 -04:00
|
|
|
;(let ([ls
|
|
|
|
; (let f ([ls clhs*])
|
|
|
|
; (cond
|
|
|
|
; [(null? ls) '()]
|
|
|
|
; [(var-assigned (car ls)) (f (cdr ls))]
|
|
|
|
; [else (cons (var-name (car ls)) (f (cdr ls)))]))])
|
|
|
|
; (unless (null? ls) (printf "complex: ~s\n" ls)))
|
2007-05-09 05:59:32 -04:00
|
|
|
(make-bind slhs* srhs*
|
|
|
|
(make-bind clhs* v*
|
|
|
|
(make-fix llhs* lrhs*
|
|
|
|
(if letrec?
|
|
|
|
(let ([t* (map (lambda (x) (unique-var 'tmp)) clhs*)])
|
|
|
|
(make-bind t* crhs*
|
|
|
|
(build-assign* clhs* t* body)))
|
|
|
|
(build-assign* clhs* crhs* body)))))))))))
|
2006-11-23 19:44:29 -05:00
|
|
|
(define (build-assign* lhs* rhs* body)
|
|
|
|
(cond
|
2007-05-09 05:59:32 -04:00
|
|
|
[(null? lhs*) body]
|
2006-11-23 19:44:29 -05:00
|
|
|
[else
|
|
|
|
(make-seq
|
|
|
|
(make-assign (car lhs*) (car rhs*))
|
|
|
|
(build-assign* (cdr lhs*) (cdr rhs*) body))]))
|
|
|
|
(define (E x ref comp)
|
|
|
|
(record-case x
|
|
|
|
[(constant) x]
|
|
|
|
[(var) (ref x) x]
|
|
|
|
[(assign lhs rhs)
|
|
|
|
(set-var-assigned! lhs #t)
|
|
|
|
(ref lhs)
|
|
|
|
(make-assign lhs (E rhs ref comp))]
|
|
|
|
[(primref) x]
|
|
|
|
[(bind lhs* rhs* body)
|
|
|
|
(let ([rhs* (E* rhs* ref comp)])
|
|
|
|
(let ([h (make-hash-table)])
|
|
|
|
(let ([body (E body (extend-hash lhs* h ref) comp)])
|
|
|
|
(make-bind lhs* rhs* body))))]
|
|
|
|
[(recbind lhs* rhs* body)
|
|
|
|
(if (null? lhs*)
|
|
|
|
(E body ref comp)
|
2007-05-09 05:59:32 -04:00
|
|
|
(do-recbind lhs* rhs* body ref comp #t))]
|
|
|
|
[(rec*bind lhs* rhs* body)
|
|
|
|
(if (null? lhs*)
|
|
|
|
(E body ref comp)
|
|
|
|
(do-recbind lhs* rhs* body ref comp #f))]
|
2006-11-23 19:44:29 -05:00
|
|
|
[(conditional e0 e1 e2)
|
|
|
|
(make-conditional (E e0 ref comp) (E e1 ref comp) (E e2 ref comp))]
|
|
|
|
[(seq e0 e1) (make-seq (E e0 ref comp) (E e1 ref comp))]
|
2006-12-04 19:00:43 -05:00
|
|
|
[(clambda g cls*)
|
|
|
|
(make-clambda g
|
2006-11-23 19:44:29 -05:00
|
|
|
(map (lambda (x)
|
|
|
|
(record-case x
|
2006-12-04 19:58:24 -05:00
|
|
|
[(clambda-case info body)
|
2006-11-23 19:44:29 -05:00
|
|
|
(let ([h (make-hash-table)])
|
2006-12-04 19:58:24 -05:00
|
|
|
(let ([body (E body (extend-hash (case-info-args info) h ref) void)])
|
|
|
|
(make-clambda-case info body)))]))
|
2006-12-04 19:05:02 -05:00
|
|
|
cls*)
|
|
|
|
#f)]
|
2006-11-23 19:44:29 -05:00
|
|
|
[(funcall rator rand*)
|
|
|
|
(let ([rator (E rator ref comp)] [rand* (E* rand* ref comp)])
|
|
|
|
(record-case rator
|
|
|
|
[(primref op)
|
2007-05-09 06:30:09 -04:00
|
|
|
(unless (memq op simple-primitives)
|
2006-11-23 19:44:29 -05:00
|
|
|
(comp))]
|
|
|
|
[else
|
|
|
|
(comp)])
|
|
|
|
(make-funcall rator rand*))]
|
2006-12-30 14:52:37 -05:00
|
|
|
[(mvcall p c)
|
|
|
|
(let ([p (E p ref comp)] [c (E c ref comp)])
|
|
|
|
(comp)
|
|
|
|
(make-mvcall p c))]
|
2006-11-23 19:44:29 -05:00
|
|
|
[(forcall rator rand*)
|
|
|
|
(make-forcall rator (E* rand* ref comp))]
|
|
|
|
[else (error who "invalid expression ~s" (unparse x))]))
|
|
|
|
(E x (lambda (x) (error who "free var ~s found" x))
|
|
|
|
void))
|
|
|
|
|
|
|
|
|
2006-12-03 11:23:03 -05:00
|
|
|
(define (uncover-assigned/referenced x)
|
|
|
|
(define who 'uncover-assigned/referenced)
|
2006-11-23 19:44:29 -05:00
|
|
|
(define (Expr* x*)
|
|
|
|
(for-each Expr x*))
|
2006-12-03 13:45:51 -05:00
|
|
|
(define (init-var x)
|
|
|
|
(set-var-assigned! x #f)
|
|
|
|
(set-var-referenced! x #f))
|
2006-11-23 19:44:29 -05:00
|
|
|
(define (Expr x)
|
|
|
|
(record-case x
|
|
|
|
[(constant) (void)]
|
2006-12-03 11:23:03 -05:00
|
|
|
[(var) (set-var-referenced! x #t)]
|
2006-11-23 19:44:29 -05:00
|
|
|
[(primref) (void)]
|
|
|
|
[(bind lhs* rhs* body)
|
2006-12-03 13:45:51 -05:00
|
|
|
(for-each init-var lhs*)
|
2006-11-23 19:44:29 -05:00
|
|
|
(begin (Expr body) (Expr* rhs*))]
|
|
|
|
[(fix lhs* rhs* body)
|
2006-12-03 13:45:51 -05:00
|
|
|
(for-each init-var lhs*)
|
|
|
|
(Expr* rhs*)
|
2006-11-23 19:44:29 -05:00
|
|
|
(Expr body)
|
|
|
|
(when (ormap var-assigned lhs*)
|
2006-12-03 11:23:03 -05:00
|
|
|
(error who "a fix lhs is assigned"))]
|
2006-11-23 19:44:29 -05:00
|
|
|
[(conditional test conseq altern)
|
|
|
|
(begin (Expr test) (Expr conseq) (Expr altern))]
|
|
|
|
[(seq e0 e1) (begin (Expr e0) (Expr e1))]
|
2006-12-04 19:00:43 -05:00
|
|
|
[(clambda g cls*)
|
2006-11-23 19:44:29 -05:00
|
|
|
(for-each
|
|
|
|
(lambda (cls)
|
2006-12-04 19:58:24 -05:00
|
|
|
(record-case cls
|
|
|
|
[(clambda-case info body)
|
|
|
|
(for-each init-var (case-info-args info))
|
|
|
|
(Expr body)]))
|
2006-11-23 19:44:29 -05:00
|
|
|
cls*)]
|
|
|
|
[(primcall rator rand*) (Expr* rand*)]
|
|
|
|
[(funcall rator rand*)
|
|
|
|
(begin (Expr rator) (Expr* rand*))]
|
2006-12-30 14:52:37 -05:00
|
|
|
[(mvcall p c) (begin (Expr p) (Expr c))]
|
2006-11-23 19:44:29 -05:00
|
|
|
[(forcall rator rand*) (Expr* rand*)]
|
|
|
|
[(assign lhs rhs)
|
|
|
|
(set-var-assigned! lhs #t)
|
|
|
|
(Expr rhs)]
|
|
|
|
[else (error who "invalid expression ~s" (unparse x))]))
|
2006-12-03 11:23:03 -05:00
|
|
|
(Expr x)
|
|
|
|
x)
|
2006-11-23 19:44:29 -05:00
|
|
|
|
2006-12-05 22:29:00 -05:00
|
|
|
|
|
|
|
#|FIXME:missing-optimizations
|
|
|
|
111 cadr
|
|
|
|
464 $record/rtd?
|
|
|
|
404 memq
|
|
|
|
249 map
|
|
|
|
114 not
|
|
|
|
451 car
|
|
|
|
224 syntax-error
|
|
|
|
248 $syntax-dispatch
|
|
|
|
237 pair?
|
|
|
|
125 length
|
|
|
|
165 $cdr
|
|
|
|
137 $car
|
|
|
|
805 $record-ref
|
|
|
|
181 fixnum?
|
|
|
|
328 null?
|
|
|
|
136 fx-
|
|
|
|
207 eq?
|
|
|
|
153 call-with-values
|
|
|
|
165 values
|
|
|
|
336 apply
|
|
|
|
384 cdr
|
|
|
|
898 cons
|
|
|
|
747 error
|
|
|
|
555 void
|
|
|
|
645 list
|
|
|
|
|#
|
2006-12-05 20:45:36 -05:00
|
|
|
|
2007-06-05 20:11:12 -04:00
|
|
|
|
2007-05-09 19:37:24 -04:00
|
|
|
;;; FIXME URGENT: should handle (+ x k), (- x k) where k is a fixnum
|
|
|
|
;;; also fx+, fx-
|
2006-12-06 01:26:44 -05:00
|
|
|
(module (optimize-primcall)
|
|
|
|
(define (optimize-primcall ctxt op rand*)
|
|
|
|
(cond
|
|
|
|
[(getprop op *cookie*) =>
|
|
|
|
(lambda (proc)
|
|
|
|
(proc ctxt op rand*
|
|
|
|
(lambda ()
|
|
|
|
(make-funcall (make-primref op) rand*))))]
|
|
|
|
[else
|
|
|
|
(make-funcall (make-primref op) rand*)]))
|
2006-12-05 21:30:42 -05:00
|
|
|
(define (constant-value x k)
|
2006-12-05 21:05:04 -05:00
|
|
|
(record-case x
|
2006-12-05 21:30:42 -05:00
|
|
|
[(constant t) (k t)] ; known
|
|
|
|
[(bind lhs* rhs* body) (constant-value body k)]
|
|
|
|
[(fix lhs* rhs* body) (constant-value body k)]
|
|
|
|
[(seq e0 e1) (constant-value e1 k)]
|
2006-12-05 21:05:04 -05:00
|
|
|
[else #f]))
|
|
|
|
(define (mk-seq e0 e1) ;;; keep e1 seq-free.
|
|
|
|
(cond
|
|
|
|
[(and (primcall? e0) (eq? (primcall-op e0) 'void)) e1]
|
|
|
|
[(seq? e1)
|
|
|
|
(make-seq (make-seq e0 (seq-e0 e1)) (seq-e1 e1))]
|
|
|
|
[else
|
|
|
|
(make-seq e0 e1)]))
|
2006-12-05 23:26:02 -05:00
|
|
|
(define (equable? x)
|
|
|
|
(if (number? x) (fixnum? x) #t))
|
2006-12-06 01:26:44 -05:00
|
|
|
(define *cookie* (gensym "optimizer-cookie"))
|
|
|
|
(define-syntax set-cases
|
|
|
|
(syntax-rules ()
|
|
|
|
[(_ ctxt op rand* giveup
|
|
|
|
[(op** ...) b* b** ...] ...)
|
|
|
|
(begin
|
|
|
|
(let ([p (lambda (ctxt op rand* giveup) b* b** ...)])
|
|
|
|
(putprop 'op** *cookie* p) ...
|
|
|
|
(void)) ...)]))
|
|
|
|
(set-cases ctxt op rand* giveup
|
2006-12-05 23:26:02 -05:00
|
|
|
[(eq?)
|
|
|
|
(or (and (fx= (length rand*) 2)
|
|
|
|
(let ([a0 (car rand*)] [a1 (cadr rand*)])
|
|
|
|
(or
|
|
|
|
(constant-value a0
|
|
|
|
(lambda (x0)
|
|
|
|
(constant-value a1
|
|
|
|
(lambda (x1)
|
|
|
|
(mk-seq (mk-seq a0 a1)
|
|
|
|
(make-constant (eq? x0 x1)))))
|
|
|
|
(and (eq? ctxt 'e)
|
|
|
|
(mk-seq a0 a1)))))))
|
|
|
|
(giveup))]
|
|
|
|
[(eqv?)
|
|
|
|
(or (and (fx= (length rand*) 2)
|
|
|
|
(let ([a0 (car rand*)] [a1 (cadr rand*)])
|
|
|
|
(or
|
|
|
|
(constant-value a0
|
|
|
|
(lambda (x0)
|
|
|
|
(or (constant-value a1
|
|
|
|
(lambda (x1)
|
|
|
|
(mk-seq (mk-seq a0 a1)
|
|
|
|
(make-constant (eqv? x0 x1)))))
|
|
|
|
(and (equable? x0)
|
|
|
|
(optimize-primcall ctxt 'eq? rand*)))))
|
|
|
|
(constant-value a1
|
|
|
|
(lambda (x1)
|
|
|
|
(and (equable? x1)
|
|
|
|
(optimize-primcall ctxt 'eq? rand*))))
|
|
|
|
(and (eq? ctxt 'e)
|
|
|
|
(mk-seq a0 a1)))))
|
|
|
|
(giveup))]
|
2006-12-05 21:05:04 -05:00
|
|
|
[(memv)
|
2006-12-05 21:30:42 -05:00
|
|
|
(or (and (fx= (length rand*) 2)
|
|
|
|
(let ([a0 (car rand*)] [a1 (cadr rand*)])
|
|
|
|
(constant-value a1
|
|
|
|
(lambda (ls)
|
|
|
|
(cond
|
|
|
|
[(not (list? ls)) #f]
|
|
|
|
[(eq? ctxt 'e) (mk-seq a0 a1)]
|
|
|
|
[(constant-value a0
|
|
|
|
(lambda (x)
|
|
|
|
(mk-seq (mk-seq a0 a1)
|
|
|
|
(case ctxt
|
|
|
|
[(v) (make-constant (memv x ls))]
|
|
|
|
[else (make-constant
|
|
|
|
(if (memv x ls) #t #f))]))))]
|
2006-12-05 23:26:02 -05:00
|
|
|
[(andmap equable? ls)
|
2006-12-05 21:30:42 -05:00
|
|
|
(optimize-primcall ctxt 'memq rand*)]
|
2006-12-05 23:26:02 -05:00
|
|
|
[(fx= (length ls) 1)
|
|
|
|
(mk-seq a1
|
|
|
|
(optimize-primcall ctxt 'eqv?
|
|
|
|
(list a0 (make-constant (car ls)))))]
|
2006-12-05 21:30:42 -05:00
|
|
|
[else #f])))))
|
|
|
|
(giveup))]
|
2006-12-05 22:29:00 -05:00
|
|
|
[(memq)
|
|
|
|
(or (and (fx= (length rand*) 2)
|
|
|
|
(let ([a0 (car rand*)] [a1 (cadr rand*)])
|
|
|
|
(constant-value a1
|
|
|
|
(lambda (ls)
|
|
|
|
(cond
|
|
|
|
[(not (list? ls)) #f]
|
|
|
|
[(eq? ctxt 'e) (make-seq a0 a1)]
|
|
|
|
[(constant-value a0
|
|
|
|
(lambda (x)
|
|
|
|
(mk-seq (mk-seq a0 a1)
|
|
|
|
(case ctxt
|
|
|
|
[(v) (make-constant (memq x ls))]
|
|
|
|
[else (make-constant
|
|
|
|
(if (memq x ls) #t #f))]))))]
|
2006-12-05 23:26:02 -05:00
|
|
|
[(fx= (length ls) 1)
|
|
|
|
(mk-seq a1
|
|
|
|
(optimize-primcall ctxt 'eq?
|
|
|
|
(list a0 (make-constant (car ls)))))]
|
2007-06-05 20:11:12 -04:00
|
|
|
[else (make-funcall (make-primref '$memq) rand*)])))))
|
2006-12-05 22:29:00 -05:00
|
|
|
(giveup))]
|
2007-06-06 03:14:07 -04:00
|
|
|
[(length)
|
|
|
|
(or (and (fx= (length rand*) 1)
|
|
|
|
(let ([a0 (car rand*)])
|
|
|
|
(constant-value a0
|
|
|
|
(lambda (ls)
|
|
|
|
(cond
|
|
|
|
[(not (list? ls)) #f]
|
|
|
|
[(eq? ctxt 'v) (make-constant (length ls))]
|
|
|
|
[(eq? ctxt 'e) a0]
|
|
|
|
[else (mk-seq a0 (make-constant #t))])))))
|
|
|
|
(giveup))]
|
2006-12-06 00:33:25 -05:00
|
|
|
[(list)
|
|
|
|
(case ctxt
|
|
|
|
[(v) (if (null? rand*) (make-constant '()) (giveup))]
|
|
|
|
[else
|
|
|
|
(if (null? rand*)
|
|
|
|
(make-constant #t)
|
|
|
|
(let f ([a (car rand*)] [d (cdr rand*)])
|
|
|
|
(cond
|
|
|
|
[(null? d) (make-seq a (make-constant #t))]
|
|
|
|
[else
|
|
|
|
(f (make-seq a (car d)) (cdr d))])))])]
|
2007-09-09 23:41:12 -04:00
|
|
|
[(cons*)
|
2006-12-06 00:33:25 -05:00
|
|
|
(case ctxt
|
|
|
|
[(e)
|
|
|
|
(cond
|
|
|
|
[(null? rand*) (giveup)]
|
|
|
|
[else
|
|
|
|
(let f ([a (car rand*)] [d (cdr rand*)])
|
|
|
|
(cond
|
|
|
|
[(null? d) a]
|
|
|
|
[else (f (mk-seq a (car d)) (cdr d))]))])]
|
|
|
|
[ |