;;; Ikarus Scheme -- A compiler for R6RS Scheme.
;;; Copyright (C) 2006,2007,2008 Abdulaziz Ghuloum
;;;
;;; 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/>.
;;; Work in progress
;;; Oscar Waddell. "Extending the Scope of Syntactic Abstraction". PhD.
;;; Thesis. Indiana University Computer Science Department. August 1999.
;;; Available online:
;;; http://www.cs.indiana.edu/~owaddell/papers/thesis.ps.gz
(module (source-optimize optimize-level cp0-effort-limit cp0-size-limit)
(define who 'source-optimize)
;;; 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 operand)
([source-referenced? #f]
[source-assigned? #f]
[residual-referenced? #f]
[residual-assigned? #f]))
;;;
(define-structure (app rand* ctxt)
([inlined #f]))
;;;
(define-structure (operand expr env ec)
([value #f]
[residualize-for-effect #f]
[size 0]
[inner-pending #f]
[outer-pending #f]))
;;;
(define-structure (counter value ctxt k))
;;;
(define (passive-counter)
(make-counter (greatest-fixnum) #f
(lambda args
(error 'passive-counter "invalid abort"))))
;;;
(define (passive-counter-value x)
(- (greatest-fixnum) (counter-value x)))
;;;
(define (active-counter? x)
(and (counter? x) (counter-ctxt x)))
;;;
(define (decrement x amt)
(let ([n (- (counter-value x) amt)])
(set-counter-value! x n)
(when (< n 0)
(reset-integrated! (counter-ctxt x))
((counter-k x) #f))))
;;;
(define (abort-counter! x)
(reset-integrated! (counter-ctxt x))
((counter-k x) #f))
;;;
(define (reset-integrated! ctxt)
(set-app-inlined! ctxt #f)
(let ([ctxt (app-ctxt ctxt)])
(when (app? ctxt)
(reset-integrated! ctxt))))
;;;
;;;
(module (init-var! var-prelex)
(define (init-var! x)
(set-var-index! x (make-prelex #f)))
(define (var-prelex x)
(let ([v (var-index x)])
(if (prelex? v)
v
(error 'var-prelex "not initialized" x)))))
(module (with-extended-env copy-var)
(define (copy-var x)
(let ([xi (var-prelex x)])
(let ([y (unique-var (var-name x))]
[yi (make-prelex #f)])
(set-var-index! y yi)
(set-prelex-source-referenced?! yi
(prelex-source-referenced? xi))
(set-prelex-source-assigned?! yi
(prelex-source-assigned? xi))
(let ([loc (var-global-loc x)])
(when loc
(set-var-global-loc! y loc)
(set-prelex-source-referenced?! yi #t)
(set-prelex-residual-referenced?! yi #t)))
y)))
(define (extend env lhs* rands)
(let ([nlhs* (map copy-var lhs*)])
(when rands
(for-each
(lambda (lhs rhs)
(assert (operand? rhs))
(set-prelex-operand! (var-prelex lhs) rhs))
nlhs* rands))
(values (vector lhs* nlhs* env) nlhs*)))
(define-syntax with-extended-env
(syntax-rules ()
[(_ ((e2 args2) (e1 args1 rands)) b b* ...)
(let-values ([(e2 args2) (extend e1 args1 rands)])
b b* ...)])))
;;; purpose of prepare:
;;; 1. attach an info struct to every bound variable
;;; 2. set the plref and plset flags to indicate whether
;;; there is a reference/assignment to the variable.
;;; 3. verify well-formness of the input.
(define (prepare x)
(define who 'prepare)
(define (L x)
(for-each
(lambda (x)
(struct-case x
[(clambda-case info body)
(for-each init-var! (case-info-args info))
(E body)]))
(clambda-cases x)))
(define (E x)
(struct-case x
[(constant) (void)]
[(var) (set-prelex-source-referenced?! (var-prelex x) #t)]
[(primref) (void)]
[(clambda) (L x)]
[(seq e0 e1) (E e0) (E e1)]
[(conditional e0 e1 e2)
(E e0) (E e1) (E e2)]
[(assign x val)
(set-prelex-source-assigned?! (var-prelex x) #t)
(E val)]
[(bind lhs* rhs* body)
(for-each E rhs*)
(for-each init-var! lhs*)
(E body)]
[(fix lhs* rhs* body)
(for-each init-var! lhs*)
(for-each L rhs*)
(E body)
(for-each ;;; sanity check
(lambda (x)
(assert (not (prelex-source-assigned? (var-prelex x)))))
lhs*)]
[(funcall rator rand*)
(for-each E rand*)
(E rator)]
[(forcall name rand*)
(for-each E rand*)]
[else (error who "invalid expr in prepare" x)]))
(E x))
(define cp0-effort-limit (make-parameter 40))
(define cp0-size-limit (make-parameter 7))
;(define cp0-size-limit (make-parameter 0))
(define primitive-info-list
'(
[(cons _ _) effect-free result-true]
[(cons* _) foldable effect-free ]
[(cons* _ . _) effect-free result-true]
[(list) foldable effect-free result-true]
[(list . _) effect-free result-true]
[(reverse ()) foldable effect-free result-true]
[(string) foldable effect-free result-true]
[(string . _) result-true]
[(make-string 0) foldable effect-free result-true]
[(make-string 0 _) foldable effect-free result-true]
[(make-string . _) result-true]
[(make-bytevector 0) foldable effect-free result-true]
[(make-bytevector 0 _) foldable result-true]
[(make-bytevector . _) result-true]
[(string-length _) foldable result-true]
[(string-ref _ _) foldable result-true]
[(vector) foldable effect-free result-true]
[(vector . _) effect-free result-true]
[(make-vector 0) foldable effect-free result-true]
[(make-vector 0 _) foldable effect-free result-true]
[(make-vector . _) result-true]
[(vector-length _) foldable result-true]
[(vector-ref _ _) foldable ]
[(eq? _ _) foldable effect-free ]
[(eqv? _ _) foldable effect-free ]
[(assq _ _) foldable ]
[(assv _ _) foldable ]
[(assoc _ _) foldable ]
[(not _) foldable effect-free ]
[(null? _) foldable effect-free ]
[(pair? _) foldable effect-free ]
[(fixnum? _) foldable effect-free ]
[(vector? _) foldable effect-free ]
[(string? _) foldable effect-free ]
[(char? _) foldable effect-free ]
[(symbol? _) foldable effect-free ]
[(procedure? _) foldable effect-free ]
[(eof-object? _) foldable effect-free ]
[(flonum? _) foldable effect-free ]
[(cflonum? _) foldable effect-free ]
[(compnum? _) foldable effect-free ]
[(integer? _) foldable effect-free ]
[(bignum? _) foldable effect-free ]
[(ratnum? _) foldable effect-free ]
[(void) foldable effect-free result-true]
[(car _) foldable ]
[(cdr _) foldable ]
[(caar _) foldable ]
[(cadr _) foldable ]
[(cdar _) foldable ]
[(cddr _) foldable ]
[(caaar _) foldable ]
[(caadr _) foldable ]
[(cadar _) foldable ]
[(caddr _) foldable ]
[(cdaar _) foldable ]
[(cdadr _) foldable ]
[(cddar _) foldable ]
[(cdddr _) foldable ]
[(caaaar _) foldable ]
[(caaadr _) foldable ]
[(caadar _) foldable ]
[(caaddr _) foldable ]
[(cadaar _) foldable ]
[(cadadr _) foldable ]
[(caddar _) foldable ]
[(cadddr _) foldable ]
[(cdaaar _) foldable ]
[(cdaadr _) foldable ]
[(cdadar _) foldable ]
[(cdaddr _) foldable ]
[(cddaar _) foldable ]
[(cddadr _) foldable ]
[(cdddar _) foldable ]
[(cddddr _) foldable ]
[(memq _ _) foldable ]
[(memv _ _) foldable ]
[(length _) foldable result-true]
[(+ . _) foldable result-true]
[(* . _) foldable result-true]
[(/ _ . _) foldable result-true]
[(- _ . _) foldable result-true]
[(fx+ _ _) foldable result-true]
[(fx- _ _) foldable result-true]
[(fx* _ _) foldable result-true]
[(fxior . _) foldable result-true]
[(fxlogor . _) foldable result-true]
[(fxnot _) foldable result-true]
[(fxadd1 _) foldable result-true]
[(fxsub1 _) foldable result-true]
[(fx=? _ . _) foldable ]
[(fx<? _ . _) foldable ]
[(fx<=? _ . _) foldable ]
[(fx>? _ . _) foldable ]
[(fx>=? _ . _) foldable ]
[(fx= _ . _) foldable ]
[(fx< _ . _) foldable ]
[(fx<= _ . _) foldable ]
[(fx> _ . _) foldable ]
[(fx>= _ . _) foldable ]
[(real-part _) foldable result-true]
[(imag-part _) foldable result-true]
[(fxsll _ _) foldable result-true]
[(fxsra _ _) foldable result-true]
[(fxremainder _ _) foldable result-true]
[(fxquotient _ _) foldable result-true]
[(greatest-fixnum) foldable effect-free result-true]
[(least-fixnum) foldable effect-free result-true]
[(fixnum-width) foldable effect-free result-true]
[(char->integer _) foldable result-true]
[(integer->char _) foldable result-true]
[(eof-object) foldable effect-free result-true]
[(zero? _) foldable ]
[(= _ . _) foldable ]
[(< _ . _) foldable ]
[(<= _ . _) foldable ]
[(> _ . _) foldable ]
[(>= _ . _) foldable ]
[(expt _ _) foldable result-true]
[(log _) foldable result-true]
[(sll _ _) foldable result-true]
[(sra _ _) foldable result-true]
[(inexact _) foldable result-true]
[(exact _) foldable result-true]
[(add1 _) foldable result-true]
[(sub1 _) foldable result-true]
[(bitwise-and _ _) foldable result-true]
[(make-rectangular _ _) foldable result-true]
[(make-eq-hashtable) effect-free result-true]
[(string->number _) foldable ]
[(string->number _ _) foldable ]
[($fixnum->flonum _) foldable effect-free result-true]
[($char->fixnum _) foldable effect-free result-true]
[($fixnum->char _) foldable effect-free result-true]
[($fxzero? _) foldable effect-free ]
[($fx+ _ _) foldable effect-free result-true]
[($fx* _ _) foldable effect-free result-true]
[($fx- _ _) foldable effect-free result-true]
[($fx= _ _) foldable effect-free ]
[($fx>= _ _) foldable effect-free ]
[($fx> _ _) foldable effect-free ]
[($fx<= _ _) foldable effect-free ]
[($fx< _ _) foldable effect-free ]
[($car _) foldable effect-free ]
[($cdr _) foldable effect-free ]
[($struct-ref _ _) foldable effect-free ]
[($struct/rtd? _ _) foldable effect-free ]
[($fxsll _ _) foldable effect-free result-true]
[($fxsra _ _) foldable effect-free result-true]
[($fxlogor _ _) foldable effect-free result-true]
[($fxlogand _ _) foldable effect-free result-true]
[($fxadd1 _) foldable effect-free result-true]
[($fxsub1 _) foldable effect-free result-true]
[($vector-length _) foldable effect-free result-true]
[($vector-ref _ _) foldable effect-free result-true]
[($make-bytevector 0) foldable effect-free result-true]
[($make-bytevector 0 _) foldable effect-free result-true]
[($make-bytevector . _) effect-free result-true]
[($bytevector-u8-ref _ _) foldable effect-free result-true]
[($bytevector-length _) foldable effect-free result-true]
;;;
[(annotation? #f) foldable effect-free result-false]
[(annotation-stripped #f) foldable effect-free result-false]
;;; unoptimizable
[(condition . _)]
[($make-flonum . _)]
[(top-level-value . _)]
[($struct . _)]
[(make-message-condition . _)]
[(make-lexical-violation . _)]
[(make-who-condition . _)]
[(make-error . _)]
[(make-i/o-error . _)]
[(make-i/o-write-error . _)]
[(make-i/o-read-error . _)]
[(make-i/o-file-already-exists-error . _)]
[(make-i/o-file-is-read-only-error . _)]
[(make-i/o-file-protection-error . _)]
[(make-i/o-file-does-not-exist-error . _)]
[(make-undefined-violation . _)]
[(die . _)]
[(gensym . _)]
[(values . _)]
[(error . _)]
[(assertion-violation . _)]
[(console-input-port . _)]
[(console-output-port . _)]
[(console-error-port . _)]
[(printf . _)] ;;; FIXME: reduce to display
[(newline . _)]
[(native-transcoder . _)]
[(open-string-output-port . _)]
[(open-string-input-port . _)]
[(environment . _)]
[(print-gensym . _)]
[(exit . _)]
[(interrupt-handler . _)]
[(display . _)]
[(write-char . _)]
[(current-input-port . _)]
[(current-output-port . _)]
[(current-error-port . _)]
[(standard-input-port . _)]
[(standard-output-port . _)]
[(standard-error-port . _)]
[($current-frame . _)]
[(pretty-width . _)]
[($fp-at-base . _)]
[(read-annotated . _)]
[($collect-key . _)]
[(make-non-continuable-violation . _)]
[(format . _)] ;;; FIXME, reduce to string-copy
[(uuid . _)]
[(print-graph . _)]
[(interaction-environment . _)]
[(make-guardian)]
[(command-line-arguments)]
[(make-record-type-descriptor . _)] ;;; FIXME
[(make-assertion-violation . _)]
[(new-cafe . _)]
[(getenv . _)]
[(gensym-prefix . _)]
[($arg-list . _)]
[($make-symbol . _)]
[(string->utf8 . _)]
[($make-call-with-values-procedure . _)]
[($make-values-procedure . _)]
[($unset-interrupted! . _)]
[(make-interrupted-condition . _)]
[($interrupted? . _)]
[($symbol-value . _)]
[(library-extensions . _)]
[(base-rtd . _)]
[($data->transcoder . _)]
[(current-time . _)]
))
(module (primprop)
(define-syntax ct-gensym
(lambda (x)
(with-syntax ([g (datum->syntax #'here (gensym))])
#'(quote g))))
(define g (ct-gensym))
(define (primprop p)
(or (getprop p g) '()))
(define (get prim ls)
(cond
[(null? ls) (values '() '())]
[else
(let ([a (car ls)])
(let ([cc (car a)])
(cond
[(eq? (car cc) prim)
(let-values ([(p* ls) (get prim (cdr ls))])
(values (cons (cons (cdr cc) (cdr a)) p*) ls))]
[else (values '() ls)])))]))
(let f ([ls primitive-info-list])
(unless (null? ls)
(let ([a (car ls)])
(let ([cc (car a)] [cv (cdr a)])
(let ([prim (car cc)] [args (cdr cc)])
(let-values ([(p* ls) (get prim (cdr ls))])
(putprop prim g
(cons (cons args cv) p*))
(f ls))))))))
(define (primitive-info op args)
(define (matches? x)
(let f ([args args] [params (car x)])
(cond
[(pair? params)
(and (pair? args)
(case (car params)
[(_) (f (cdr args) (cdr params))]
[(#f 0 ())
(let ([v (value-visit-operand! (car args))])
(and (constant? v)
(equal? (constant-value v) (car params))
(f (cdr args) (cdr params))))]
[else
(error 'primitive-info "cannot happen" op (car params))]))]
[(eq? params '_) #t]
[(null? params) (null? args)]
[else (error 'primitive-info "cannot happen" op params)])))
(cond
[(find matches? (primprop op))]
[else '()]))
(define (info-foldable? info) (memq 'foldable info))
(define (info-effect-free? info) (memq 'effect-free info))
(define (info-result-true? info) (memq 'result-true info))
(define (info-result-false? info) (memq 'result-false info))
(define-syntax ctxt-case
(lambda (stx)
(define (test x)
(case (syntax->datum x)
[(p) #'(eq? t 'p)]
[(v) #'(eq? t 'v)]
[(e) #'(eq? t 'e)]
[(app) #'(app? t)]
[else (syntax-violation stx "invalid ctxt" x)]))
(define (extract cls*)
(syntax-case cls* (else)
[() #'(error 'extract "unmatched ctxt" t)]
[([else e e* ...]) #'(begin e e* ...)]
[([(t* ...) e e* ...] rest ...)
(with-syntax ([(t* ...) (map test #'(t* ...))]
[body (extract #'(rest ...))])
#'(if (or t* ...)
(begin e e* ...)
body))]))
(syntax-case stx ()
[(_ expr cls* ...)
(with-syntax ([body (extract #'(cls* ...))])
#'(let ([t expr])
body))])))
(define (mkseq e0 e1)
;;; returns a (seq e0 e1) with a seq-less e1 if both
;;; e0 and e1 are constructed properly.
(if (simple? e0)
e1
(let ([e0 (struct-case e0
[(seq e0a e0b) (if (simple? e0b) e0a e0)]
[else e0])])
(struct-case e1
[(seq e1a e1b) (make-seq (make-seq e0 e1a) e1b)]
[else (make-seq e0 e1)]))))
;;; simple?: check quickly whether something is effect-free
(define (simple? x)
(struct-case x
[(constant) #t]
[(var) #t]
[(primref) #t]
[(clambda) #t]
[else #f]))
;;; result returns the "last" value of an expression
(define (result-expr x)
(struct-case x
[(seq e0 e1) e1]
[else x]))
;;;
(define (records-equal? x y ctxt)
(struct-case x
[(constant kx)
(struct-case y
[(constant ky)
(ctxt-case ctxt
[(e) #t]
[(p) (if kx ky (not ky))]
[else (eq? kx ky)])]
[else #f])]
[else #f]))
;;;
(define (residualize-operands e rand* sc)
(cond
[(null? rand*) e]
[(not (operand-residualize-for-effect (car rand*)))
(residualize-operands e (cdr rand*) sc)]
[else
(let ([opnd (car rand*)])
(let ([e1 (or (operand-value opnd)
(struct-case opnd
[(operand expr env ec)
(E expr 'e env ec sc)]))])
(if (simple? e1)
(residualize-operands e (cdr rand*) sc)
(begin
(decrement sc (operand-size opnd))
(mkseq e1 (residualize-operands e (cdr rand*) sc))))))]))
(define (value-visit-operand! rand)
(or (operand-value rand)
(let ([sc (passive-counter)])
(let ([e (struct-case rand
[(operand expr env ec)
(E expr 'v env sc ec)])])
(set-operand-value! rand e)
(set-operand-size! rand (passive-counter-value sc))
e))))
(define (score-value-visit-operand! rand sc)
(let ([val (value-visit-operand! rand)])
(let ([score (operand-size rand)])
(decrement sc score))
val))
(define (E-call rator rand* env ctxt ec sc)
(let ([ctxt (make-app rand* ctxt)])
(let ([rator (E rator ctxt env ec sc)])
(if (app-inlined ctxt)
(residualize-operands rator rand* sc)
(begin
(decrement sc (if (primref? rator) 1 3))
(make-funcall rator
(map (lambda (x) (score-value-visit-operand! x sc))
rand*)))))))
;;;
(define (E-var x ctxt env ec sc)
(ctxt-case ctxt
[(e) (make-constant (void))]
[else
(let ([x (lookup x env)])
(let ([opnd (prelex-operand (var-prelex x))])
(if (and opnd (not (operand-inner-pending opnd)))
(begin
(dynamic-wind
(lambda () (set-operand-inner-pending! opnd #t))
(lambda () (value-visit-operand! opnd))
(lambda () (set-operand-inner-pending! opnd #f)))
(if (prelex-source-assigned? (var-prelex x))
(residualize-ref x sc)
(copy x opnd ctxt ec sc)))
(residualize-ref x sc))))]))
;;;
(define (copy x opnd ctxt ec sc)
(let ([rhs (result-expr (operand-value opnd))])
(struct-case rhs
[(constant) rhs]
[(var)
(if (prelex-source-assigned? (var-prelex rhs))
(residualize-ref x sc)
(let ([opnd (prelex-operand (var-prelex rhs))])
(if (and opnd (operand-value opnd))
(copy2 rhs opnd ctxt ec sc)
(residualize-ref rhs sc))))]
[else (copy2 x opnd ctxt ec sc)])))
;;;
(define (copy2 x opnd ctxt ec sc)
(let ([rhs (result-expr (operand-value opnd))])
(struct-case rhs
[(clambda)
(ctxt-case ctxt
[(v) (residualize-ref x sc)]
[(p) (make-constant #t)]
[(e) (make-constant (void))]
[(app)
(or (and (not (operand-outer-pending opnd))
(dynamic-wind
(lambda () (set-operand-outer-pending! opnd #t))
(lambda ()
(call/cc
(lambda (abort)
(inline rhs ctxt empty-env
(if (active-counter? ec)
ec
(make-counter
(cp0-effort-limit)
ctxt abort))
(make-counter
(if (active-counter? sc)
(counter-value sc)
(cp0-size-limit))
ctxt abort)))))
(lambda () (set-operand-outer-pending! opnd #f))))
(residualize-ref x sc))])]
[(primref p)
(ctxt-case ctxt
[(v) rhs]
[(p) (make-constant #t)]
[(e) (make-constant (void))]
[(app) (fold-prim p ctxt ec sc)])]
[else (residualize-ref x sc)])))
(define (inline proc ctxt env ec sc)
(define (get-case cases rand*)
(define (compatible? x)
(struct-case (clambda-case-info x)
[(case-info label args proper)
(cond
[proper (= (length rand*) (length args))]
[else (>= (length rand*) (- (length args) 1))])]))
(cond
[(memp compatible? cases) => car]
[else #f]))
(define (partition args rand*)
(cond
[(null? (cdr args))
(let ([r (car args)])
(let ([t* (map (lambda (x) (copy-var r)) rand*)])
(values '() t* r)))]
[else
(let ([x (car args)])
(let-values ([(x* t* r) (partition (cdr args) (cdr rand*))])
(values (cons x x*) t* r)))]))
(struct-case proc
[(clambda g cases cp free name)
(let ([rand* (app-rand* ctxt)])
(struct-case (get-case cases rand*)
[(clambda-case info body)
(struct-case info
[(case-info label args proper)
(cond
[proper
(with-extended-env ((env args) (env args rand*))
(let ([body (E body (app-ctxt ctxt) env ec sc)])
(let ([result (make-let-binding args rand* body sc)])
(set-app-inlined! ctxt #t)
result)))]
[else
(let-values ([(x* t* r) (partition args rand*)])
(with-extended-env ((env a*)
(env (append x* t*) rand*))
(let ([rarg (make-operand
(make-funcall (make-primref 'list) t*)
env ec)])
(with-extended-env ((env b*)
(env (list r) (list rarg)))
(let ([result
(make-let-binding a* rand*
(make-let-binding b* (list rarg)
(E body (app-ctxt ctxt) env ec sc)
sc)
sc)])
(set-app-inlined! ctxt #t)
result)))))])])]
[else
(E proc 'v env ec sc)]))]))
;;;
(define (do-bind lhs* rhs* body ctxt env ec sc)
(let ([rand* (map (lambda (x) (make-operand x env ec)) rhs*)])
(with-extended-env ((env lhs*) (env lhs* rand*))
(residualize-operands
(make-let-binding lhs* rand*
(E body ctxt env ec sc)
sc)
rand* sc))))
;;;
(define (make-let-binding var* rand* body sc)
(define (process1 var rand lhs* rhs*)
(cond
[(prelex-residual-referenced? (var-prelex var))
(assert (not (operand-residualize-for-effect rand)))
(values
(cons var lhs*)
(cons (score-value-visit-operand! rand sc) rhs*))]
[(prelex-residual-assigned? (var-prelex var))
(set-operand-residualize-for-effect! rand #t)
(values
(cons var lhs*)
(cons (make-constant (void)) rhs*))]
[else
(set-operand-residualize-for-effect! rand #t)
(values lhs* rhs*)]))
(define (process var* rand*)
(cond
[(null? var*) (values '() '())]
[else
(let ([var (car var*)] [rand (car rand*)])
(let-values ([(lhs* rhs*) (process (cdr var*) (cdr rand*))])
(process1 var rand lhs* rhs*)))]))
(let-values ([(lhs* rhs*) (process var* rand*)])
(if (null? lhs*) body (make-bind lhs* rhs* body))))
;;;
(define (fold-prim p ctxt ec sc)
(define (get-value p ls)
(call/cc
(lambda (k)
(with-exception-handler
(lambda (con)
(decrement ec 10)
(k #f))
(lambda ()
(make-constant (apply (system-value p) ls)))))))
(let ([rand* (app-rand* ctxt)])
(let ([info (primitive-info p rand*)])
(let ([result
(or (and (info-effect-free? info)
(ctxt-case (app-ctxt ctxt)
[(e) (make-constant (void))]
[(p)
(cond
[(info-result-true? info)
(make-constant #t)]
[(info-result-false? info)
(make-constant #f)]
[else #f])]
[else #f]))
(and (info-foldable? info)
(let ([val*
(map (lambda (x) (value-visit-operand! x)) rand*)])
(cond
[(andmap constant? val*)
(get-value p (map constant-value val*))]
[else #f]))))])
(if result
(begin
(decrement ec 1)
(for-each
(lambda (x)
(set-operand-residualize-for-effect! x #t))
rand*)
(set-app-inlined! ctxt #t)
result)
(begin
(decrement sc 1)
(make-primref p)))))))
;;;
(define (residualize-ref x sc)
(decrement sc 1)
(set-prelex-residual-referenced?! (var-prelex x) #t)
x)
;;;
(define (E x ctxt env ec sc)
(decrement ec 1)
(struct-case x
[(constant) (decrement sc 1) x]
[(var) (E-var x ctxt env ec sc)]
[(seq e0 e1)
(mkseq (E e0 'e env ec sc) (E e1 ctxt env ec sc))]
[(conditional e0 e1 e2)
(let ([e0 (E e0 'p env ec sc)])
(struct-case (result-expr e0)
[(constant k)
(mkseq e0 (E (if k e1 e2) ctxt env ec sc))]
[else
(let ([ctxt (ctxt-case ctxt [(app) 'v] [else ctxt])])
(let ([e1 (E e1 ctxt env ec sc)]
[e2 (E e2 ctxt env ec sc)])
(if (records-equal? e1 e2 ctxt)
(mkseq e0 e1)
(begin
(decrement sc 1)
(make-conditional e0 e1 e2)))))]))]
[(assign x v)
(mkseq
(let ([x (lookup x env)])
(let ([xi (var-prelex x)])
(cond
[(not (prelex-source-referenced? xi))
;;; dead on arrival
(E v 'e env ec sc)]
[else
(decrement sc 1)
(set-prelex-residual-assigned?! xi #t)
(make-assign x (E v 'v env ec sc))])))
(make-constant (void)))]
[(funcall rator rand*)
(E-call rator
(map (lambda (x) (make-operand x env ec)) rand*)
env ctxt ec sc)]
[(forcall name rand*)
(decrement sc 1)
(make-forcall name (map (lambda (x) (E x 'v env ec sc)) rand*))]
[(primref name)
(ctxt-case ctxt
[(app) (fold-prim name ctxt ec sc)]
[(v) (decrement sc 1) x]
[else (make-constant #t)])]
[(clambda g cases cp free name)
(ctxt-case ctxt
[(app) (inline x ctxt env ec sc)]
[(p e) (make-constant #t)]
[else
(decrement sc 2)
(make-clambda (gensym)
(map
(lambda (x)
(struct-case x
[(clambda-case info body)
(struct-case info
[(case-info label args proper)
(with-extended-env ((env args) (env args #f))
(make-clambda-case
(make-case-info (gensym) args proper)
(E body 'v env ec sc)))])]))
cases)
cp free name)])]
[(bind lhs* rhs* body)
(do-bind lhs* rhs* body ctxt env ec sc)]
[(fix lhs* rhs* body)
(with-extended-env ((env lhs*) (env lhs* #f))
(for-each
(lambda (lhs rhs)
(set-prelex-operand! (var-prelex lhs)
(make-operand rhs env ec)))
lhs* rhs*)
(let ([body (E body ctxt env ec sc)])
(let ([lhs* (remp
(lambda (x)
(not (prelex-residual-referenced? (var-prelex x))))
lhs*)])
(cond
[(null? lhs*) body]
[else
(decrement sc 1)
(make-fix lhs*
(map (lambda (x)
(let ([opnd (prelex-operand (var-prelex x))])
(decrement sc (+ (operand-size opnd) 1))
(value-visit-operand! opnd)))
lhs*)
body)]))))]
[else (error who "invalid expression" x)]))
(define empty-env '())
(define (lookup x orig-env)
(define (lookup env)
(cond
[(vector? env)
(let f ([lhs* (vector-ref env 0)] [rhs* (vector-ref env 1)])
(cond
[(null? lhs*) (lookup (vector-ref env 2))]
[(eq? x (car lhs*)) (car rhs*)]
[else (f (cdr lhs*) (cdr rhs*))]))]
[else x]))
(lookup orig-env))
(define optimize-level
(make-parameter 1
(lambda (x)
(if (memv x '(0 1 2))
x
(die 'optimize-level "valid levels are 0, 1, and 2")))))
(define (source-optimize expr)
(define (source-optimize expr)
(prepare expr)
(E expr 'v empty-env (passive-counter) (passive-counter)))
(case (optimize-level)
[(2) (source-optimize expr)]
[else expr]))
)