ikarus/lib/libcompile.ss

4657 lines
167 KiB
Scheme
Raw Normal View History

2006-11-23 19:44:29 -05:00
2006-11-23 19:48:14 -05:00
;;; 9.0: * calls (gensym <symbol>) instead of
;;; (gensym (symbol->string <symbol>)) in order to avoid incrementing
;;; gensym-count.
2006-11-23 19:44:29 -05:00
;;; 6.7: * open-coded top-level-value, car, cdr
;;; 6.2: * side-effects now modify the dirty-vector
;;; * added bwp-object?
;;; * added pointer-value
;;; * added tcbuckets
;;; 6.1: * added case-lambda, dropped lambda
;;; 6.0: * basic compiler
(let ()
(define-syntax cond-expand
(lambda (x)
(syntax-case x ()
[(_ test conseq altern)
(if (eval (syntax-object->datum #'test))
#'conseq
#'altern)])))
(cond-expand (eq? "" "")
(include "record-case.chez.ss")
(include "record-case.ss"))
(include "set-operations.ss")
(define open-coded-primitives
;;; these primitives, when found in operator position with the correct
;;; number of arguments, will be open-coded by the generator. If an
;;; incorrect number of args is detected, or if they appear in non-operator
;;; position, then they cannot be open-coded, and the pcb-primitives table
;;; is consulted for a reference of the pcb slot containing the primitive.
;;; If it's not found there, an error is signalled.
;;;
;;; prim-name args
'([$constant-ref 1 value]
[$constant-set! 2 effect]
[$pcb-ref 1 value]
[$pcb-set! 2 effect]
;;; type predicates
[fixnum? 1 pred]
[immediate? 1 pred]
[boolean? 1 pred]
[char? 1 pred]
[pair? 1 pred]
[symbol? 1 pred]
[vector? 1 pred]
[string? 1 pred]
[procedure? 1 pred]
[null? 1 pred]
[eof-object? 1 pred]
[bwp-object? 1 pred]
[$unbound-object? 1 pred]
[$forward-ptr? 1 pred]
[not 1 pred]
[pointer-value 1 value]
[eq? 2 pred]
;;; fixnum primitives
[$fxadd1 1 value]
[$fxsub1 1 value]
[$fx+ 2 value]
[$fx- 2 value]
[$fx* 2 value]
[$fxsll 2 value]
[$fxsra 2 value]
[$fxlogand 2 value]
[$fxlogor 2 value]
[$fxlogxor 2 value]
[$fxlognot 1 value]
[$fxquotient 2 value]
[$fxmodulo 2 value]
;;; fixnum predicates
[$fxzero? 1 pred]
[$fx= 2 pred]
[$fx< 2 pred]
[$fx<= 2 pred]
[$fx> 2 pred]
[$fx>= 2 pred]
;;; character predicates
[$char= 2 pred]
[$char< 2 pred]
[$char<= 2 pred]
[$char> 2 pred]
[$char>= 2 pred]
;;; character conversion
[$fixnum->char 1 value]
[$char->fixnum 1 value]
;;; lists/pairs
[cons 2 value]
[list* positive value]
[list any value]
[car 1 value]
[cdr 1 value]
[$car 1 value]
[$cdr 1 value]
[$set-car! 2 effect]
[$set-cdr! 2 effect]
;;; vectors
[$make-vector 1 value]
[vector any value]
[$vector-length 1 value]
[$vector-ref 2 value]
[$vector-set! 3 effect]
;;; strings
[$make-string 1 value]
[$string any value]
[$string-length 1 value]
[$string-ref 2 value]
[$string-set! 3 effect]
;;; symbols
[$make-symbol 1 value]
[$symbol-value 1 value]
[$symbol-string 1 value]
[$symbol-unique-string 1 value]
[$set-symbol-value! 2 effect]
[$set-symbol-string! 2 effect]
[$set-symbol-unique-string! 2 effect]
[$symbol-plist 1 value]
[$set-symbol-plist! 2 effect]
[primitive-ref 1 value]
[primitive-set! 2 effect]
[top-level-value 1 value]
2006-11-23 19:48:14 -05:00
;;; ports
[port? 1 pred]
[input-port? 1 pred]
[output-port? 1 pred]
[$make-port/input 7 value]
[$make-port/output 7 value]
[$make-port/both 7 value]
[$port-handler 1 value]
[$port-input-buffer 1 value]
[$port-input-index 1 value]
[$port-input-size 1 value]
[$port-output-buffer 1 value]
[$port-output-index 1 value]
[$port-output-size 1 value]
[$set-port-input-index! 2 effect]
[$set-port-input-size! 2 effect]
[$set-port-output-index! 2 effect]
[$set-port-output-size! 2 effect]
2006-11-23 19:44:29 -05:00
;;; tcbuckets
[$make-tcbucket 4 value]
[$tcbucket-key 1 value]
[$tcbucket-val 1 value]
[$tcbucket-next 1 value]
2006-11-23 19:48:14 -05:00
[$tcbucket-dlink-next 1 value]
[$tcbucket-dlink-prev 1 value]
2006-11-23 19:44:29 -05:00
[$set-tcbucket-val! 2 effect]
[$set-tcbucket-next! 2 effect]
2006-11-23 19:48:14 -05:00
[$set-tcbucket-dlink-next! 2 effect]
[$set-tcbucket-dlink-prev! 2 effect]
2006-11-23 19:44:29 -05:00
[$set-tcbucket-tconc! 2 effect]
;;; misc
[eof-object 0 value]
[void 0 value]
[$exit 1 effect]
[$fp-at-base 0 pred]
[$current-frame 0 value]
[$arg-list 0 value]
2006-11-23 19:44:29 -05:00
[$seal-frame-and-call 1 tail]
[$frame->continuation 1 value]
;;;
;;; records
;;;
[$make-record 2 value]
[$record? 1 pred]
[$record/rtd? 2 pred]
[$record-rtd 1 value]
[$record-ref 2 value]
[$record-set! 3 effect]
[$record any value]
;;;
;;; asm
;;;
[$code? 1 pred]
[$code-size 1 value]
[$code-reloc-vector 1 value]
[$code-freevars 1 value]
[$code-ref 2 value]
[$code-set! 3 value]
[$code->closure 1 value]
[$closure-code 1 value]
2006-11-23 19:44:29 -05:00
;;;
[$make-call-with-values-procedure 0 value]
[$make-values-procedure 0 value]
))
(define (primitive-context x)
(cond
[(assq x open-coded-primitives) => caddr]
[else (error 'primitive-context "unknown prim ~s" x)]))
(define (open-codeable? x)
(cond
[(assq x open-coded-primitives) #t]
[else #f]))
(define (open-coded-primitive-args x)
(cond
[(assq x open-coded-primitives) => cadr]
[else (error 'open-coded-primitive-args "invalid ~s" x)]))
;;; end of primitives table section
(define-record constant (value))
(define-record code-loc (label))
(define-record foreign-label (label))
(define-record var (name assigned referenced))
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
(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))
(define-record bind (lhs* rhs* body))
(define-record recbind (lhs* rhs* body))
(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 appcall (op rand*))
(define-record forcall (op rand*))
(define-record codes (list body))
(define-record assign (lhs rhs))
(define (unique-var x)
(make-var (gensym x) #f #f))
2006-11-23 19:44:29 -05:00
2006-12-06 21:20:15 -05:00
2006-11-23 19:44:29 -05:00
(define (recordize x)
(define (gen-fml* fml*)
(cond
[(pair? fml*)
(cons (unique-var (car fml*))
(gen-fml* (cdr fml*)))]
[(symbol? fml*)
(unique-var fml*)]
[else '()]))
(define (properize fml*)
(cond
[(pair? fml*)
(cons (car fml*) (properize (cdr fml*)))]
[(null? fml*) '()]
[else (list fml*)]))
(define (extend-env fml* nfml* env)
(cons (cons fml* nfml*) env))
(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)))
(define (quoted-string x)
(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)))
(define (lookup^ x lhs* rhs*)
(cond
[(pair? lhs*)
(if (eq? x (car lhs*))
(car rhs*)
(lookup^ x (cdr lhs*) (cdr rhs*)))]
[(eq? x lhs*) rhs*]
[else #f]))
(define (lookup x env)
(cond
[(pair? env)
(or (lookup^ x (caar env) (cdar env))
(lookup x (cdr env)))]
[else #f]))
(define (E x env)
(cond
[(pair? x)
(case (car x)
[(quote) (make-constant (cadr x))]
[(if)
(make-conditional
(E (cadr x) env)
(E (caddr x) env)
(E (cadddr x) env))]
[(set!)
(let ([lhs (cadr x)] [rhs (caddr x)])
(make-assign
(or (lookup lhs env)
(error 'recordize "invalid assignment ~s" x))
(E rhs env)))]
[(begin)
(let f ([a (cadr x)] [d (cddr x)])
(cond
[(null? d) (E a env)]
[else
(make-seq
(E a env)
(f (car d) (cdr d)))]))]
[(letrec)
(unless (fx= (length x) 3) (syntax-error x))
(let ([bind* (cadr x)] [body (caddr x)])
(let ([lhs* (map car bind*)]
[rhs* (map cadr bind*)])
(let ([nlhs* (gen-fml* lhs*)])
(let ([env (extend-env lhs* nlhs* env)])
(make-recbind nlhs*
(map (lambda (rhs) (E rhs env)) rhs*)
(E body env))))))]
[(letrec)
(unless (fx= (length x) 3) (syntax-error x))
(let ([bind* (cadr x)] [body (caddr x)])
(let ([lhs* (map car bind*)]
[rhs* (map cadr bind*)]
[v* (map (lambda (x) '(void)) bind*)]
[t* (map (lambda (x) (gensym)) bind*)])
(E `((case-lambda
[,lhs*
((case-lambda
[,t*
(begin ,@(map (lambda (x v) `(set! ,x ,v)) lhs* t*)
,body)])
,@rhs*)])
,@v*)
env)))]
[(case-lambda)
(let ([cls*
(map
(lambda (cls)
(let ([fml* (car cls)] [body (cadr cls)])
(let ([nfml* (gen-fml* fml*)])
(let ([body (E body (extend-env fml* nfml* env))])
(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)])
(make-forcall name
(map (lambda (x) (E x env)) arg*)))]
[(|#primitive|)
(let ([var (cadr x)])
(make-primref var))]
;;; [(|#primitive|)
;;; (let ([var (cadr x)])
;;; (if (primitive? var)
;;; (make-primref var)
;;; (error 'recordize "invalid primitive ~s" var)))]
[(top-level-value)
(let ([var (quoted-sym (cadr x))])
(if (eq? (expand-mode) 'bootstrap)
(error 'compile "reference to ~s in bootstrap mode" var)
2006-11-23 19:48:14 -05:00
;(make-primref var)
2006-11-23 19:44:29 -05:00
(make-funcall
(make-primref 'top-level-value)
(list (make-constant var)))))]
;;; [(top-level-value)
;;; (let ([var (quoted-sym (cadr x))])
;;; (if (eq? (expand-mode) 'bootstrap)
;;; (if (primitive? var)
;;; (make-primref var)
;;; (error 'compile "invalid primitive ~s" var))
;;; (make-funcall
;;; (make-primref 'top-level-value)
;;; (list (make-constant var)))))]
[(set-top-level-value!)
(make-funcall (make-primref 'set-top-level-value!)
(map (lambda (x) (E x env)) (cdr x)))]
[(memv)
(make-funcall
(make-primref 'memq)
(map (lambda (x) (E x env)) (cdr x)))]
[($apply)
(let ([proc (cadr x)] [arg* (cddr x)])
(make-appcall
(E proc env)
(map (lambda (x) (E x env)) arg*)))]
[(void)
(make-constant (void))]
[else
(make-funcall
(E (car x) env)
(map (lambda (x) (E x env)) (cdr x)))])]
[(symbol? x)
(or (lookup x env)
(error 'recordize "invalid reference in ~s" x))]
[else (error 'recordize "invalid expression ~s" x)]))
(E x '()))
(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))]
[(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))]
[(fix lhs* rhs* body)
`(fix ,(map (lambda (lhs rhs) (list (E lhs) (E rhs))) lhs* rhs*)
,(E body))]
[(seq e0 e1) `(begin ,(E e0) ,(E e1))]
2006-12-04 19:58:24 -05:00
[(clambda-case info body)
`(clambda-case ,(E-args (case-info-proper info)
(case-info-args info))
,(E body))]
[(clambda g cls*)
2006-11-23 19:44:29 -05:00
`(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
[(appcall rator rand*) `(appcall ,(E rator) . ,(map E rand*))]
[(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))]
[(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-11-23 19:44:29 -05:00
[rpconv: ,rp-convention]
[base-idx: ,base-idx]
[arg-count: ,arg-count]
[live-mask: ,live-mask])]
[(foreign-label x) `(foreign-label ,x)]
[else (error 'unparse "invalid record ~s" x)]))
(E x))
(define (optimize-direct-calls x)
(define who 'optimize-direct-calls)
(define (make-conses ls)
(cond
[(null? ls) (make-constant '())]
[else
(make-primcall 'cons
(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*)
(record-case rator
[(clambda g cls*)
2006-11-23 19:44:29 -05:00
(try-inline cls* rand*
(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))]
[(conditional test conseq altern)
(make-conditional
(Expr test)
(Expr conseq)
(Expr altern))]
[(seq e0 e1)
(make-seq (Expr e0) (Expr e1))]
[(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
[(primcall rator rand*)
(make-primcall rator (map Expr rand*))]
[(funcall rator rand*)
(inline (Expr rator) (map Expr rand*))]
[(appcall rator rand*)
(make-appcall (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))
(define lambda-both 0)
(define lambda-producer 0)
(define lambda-consumer 0)
(define lambda-none 0)
(define branching-producer 0)
(define (analyze-cwv x)
(define who 'analyze-cwv)
(define (lambda? x)
(record-case x
[(clambda) #t]
[else #f]))
(define (branching-producer? x)
(define (bt? x)
(record-case x
[(bind lhs* rhs* body) (bt? body)]
[(recbind lhs* rhs* body) (bt? body)]
[(conditional test conseq altern) #t]
[(seq e0 e1) (bt? e1)]
[else #f]))
(define (branching-clause? x)
(record-case x
2006-12-04 19:58:24 -05:00
[(clambda-case info body)
2006-11-23 19:44:29 -05:00
(bt? body)]))
(record-case x
[(clambda g cls*)
2006-11-23 19:44:29 -05:00
(ormap branching-clause? cls*)]
[else #f]))
(define (analyze producer consumer)
(cond
[(and (lambda? producer) (lambda? consumer))
(set! lambda-both (fxadd1 lambda-both))]
[(lambda? producer)
(set! lambda-producer (fxadd1 lambda-producer))]
[(lambda? consumer)
(set! lambda-consumer (fxadd1 lambda-consumer))]
[else
(set! lambda-none (fxadd1 lambda-none))])
(when (branching-producer? producer)
(set! branching-producer (fxadd1 branching-producer)))
(printf "both=~s p=~s c=~s none=~s branching-prod=~s\n"
lambda-both lambda-producer lambda-consumer lambda-none
branching-producer))
(define (E x)
(record-case x
[(constant) (void)]
[(var) (void)]
[(primref) (void)]
[(bind lhs* rhs* body)
(for-each E rhs*) (E body)]
[(recbind lhs* rhs* body)
(for-each E rhs*) (E body)]
[(conditional test conseq altern)
(E test)
(E conseq)
(E altern)]
[(seq e0 e1) (E e0) (E e1)]
[(clambda g cls*)
2006-11-23 19:44:29 -05:00
(for-each
(lambda (x)
(record-case x
2006-12-04 19:58:24 -05:00
[(clambda-case info body) (E body)]))
2006-11-23 19:44:29 -05:00
cls*)]
[(primcall rator rand*)
(for-each E rand*)
(when (and (eq? rator 'call-with-values) (fx= (length rand*) 2))
(analyze (car rand*) (cadr rand*)))]
[(funcall rator rand*)
(E rator) (for-each E rand*)
(when (and (record-case rator
[(primref op) (eq? op 'call-with-values)]
[else #f])
(fx= (length rand*) 2))
(analyze (car rand*) (cadr rand*)))]
[(appcall rator rand*)
(E rator) (for-each E rand*)]
[(forcall rator rand*)
(for-each E rand*)]
[(assign lhs rhs)
(E rhs)]
[else (error who "invalid expression ~s" (unparse x))]))
(E x))
(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))]))
(define (do-rhs* i lhs* rhs* ref comp vref vcomp)
(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)
(do-rhs* (fxadd1 i) lhs* (cdr rhs*) ref comp vref vcomp))))]))
(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*)]
))]))
(define (do-recbind lhs* rhs* body ref comp)
(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)])
(let ([v* (map (lambda (x) (make-primcall 'void '())) clhs*)]
[t* (map (lambda (x) (unique-var 'tmp)) clhs*)])
(make-bind slhs* srhs*
(make-bind clhs* v*
(make-fix llhs* lrhs*
(make-bind t* crhs*
(build-assign* clhs* t* body)))))))))))
(define (build-assign* lhs* rhs* body)
(cond
[(null? lhs*) body]
[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)
(do-recbind lhs* rhs* body ref comp))]
[(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))]
[(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
[(primcall rator rand*)
(when (memq rator '(call/cc call/cf))
(comp))
(make-primcall rator (E* rand* ref comp))]
[(funcall rator rand*)
(let ([rator (E rator ref comp)] [rand* (E* rand* ref comp)])
(record-case rator
[(primref op)
(when (memq op '(call/cc call/cf))
(comp))]
[else
(comp)])
(make-funcall rator rand*))]
[(appcall rator rand*)
(let ([rator (E rator ref comp)] [rand* (E* rand* ref comp)])
(record-case rator
[(primref op)
(when (memq op '(call/cc call/cf))
(comp))]
[else
(comp)])
(make-appcall rator rand*))]
[(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))
;;; This pass was here before optimize-letrec was implemented.
2006-11-23 19:44:29 -05:00
(define (remove-letrec x)
(define who 'remove-letrec)
(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)
(let ([t* (map (lambda (lhs) (unique-var 'tmp)) lhs*)]
[v* (map (lambda (lhs) (make-primcall 'void '())) lhs*)])
(make-bind lhs* v*
(make-bind t* (map Expr rhs*)
(let f ([lhs* lhs*] [t* t*])
(cond
[(null? lhs*) (Expr body)]
[else
(make-seq
(make-assign (car lhs*) (car t*))
(f (cdr lhs*) (cdr t*)))])))))]
;[(fix lhs* rhs* body)
; (Expr (make-recbind lhs* rhs* body))]
[(fix lhs* rhs* body)
(make-fix lhs* (map Expr rhs*) (Expr body))]
[(conditional test conseq altern)
(make-conditional
(Expr test)
(Expr conseq)
(Expr altern))]
[(seq e0 e1)
(make-seq (Expr e0) (Expr e1))]
[(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
[(primcall rator rand*)
(make-primcall rator (map Expr rand*))]
[(funcall rator rand*)
(make-funcall (Expr rator) (map Expr rand*))]
[(appcall rator rand*)
(make-appcall (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))
(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*))
(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)]
[(var) (set-var-referenced! x #t)]
2006-11-23 19:44:29 -05:00
[(primref) (void)]
[(bind lhs* rhs* body)
(for-each init-var lhs*)
2006-11-23 19:44:29 -05:00
(begin (Expr body) (Expr* rhs*))]
[(fix lhs* rhs* body)
(for-each init-var lhs*)
(Expr* rhs*)
2006-11-23 19:44:29 -05:00
(Expr body)
(when (ormap var-assigned lhs*)
(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))]
[(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*))]
[(appcall rator rand*)
(begin (Expr rator) (Expr* rand*))]
[(forcall rator rand*) (Expr* rand*)]
[(assign lhs rhs)
(set-var-assigned! lhs #t)
(Expr rhs)]
[else (error who "invalid expression ~s" (unparse x))]))
(Expr x)
x)
2006-11-23 19:44:29 -05:00
(module (tally-giveup)
(define giveup-list '())
(define (tally-giveup op)
(cond
[(getprop op '*compiler-giveup-tally*) =>
(lambda (n)
(putprop op '*compiler-giveup-tally* (add1 n)))]
[else
(set! giveup-list (cons op giveup-list))
(putprop op '*compiler-giveup-tally* 1)]))
(define (print-tally)
(for-each
(lambda (x)
(let ([n (getprop x '*compiler-giveup-tally*)])
2006-12-06 01:26:44 -05:00
(when (>= n 40)
(printf "~s ~s\n" n x))))
giveup-list))
(primitive-set! 'compiler-giveup-tally print-tally))
#|FIXME:missing-optimizations
128 list*
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
331 primitive-set!
555 void
645 list
|#
2006-12-05 20:45:36 -05:00
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
(tally-giveup op)
(make-funcall (make-primref op) rand*)]))
2006-12-05 21:30:42 -05:00
(define (constant-value x k)
(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)]
[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))]
[(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