(define $cp0

(let ()

(import (nanopass))

(include "base-lang.ss")

;;; set to #f for monovariant filter

(define-threaded polyvariant #t)

;;; set to #f to disable inlining of various primitives into code containing

;;; lambda expressions, e.g., for-each and record-accessor---generally not

;;; desirable when interpreting rather than compiling the residual code.

(define-threaded likely-to-be-compiled?)

;;; score-limit determines max amount of code any integration attempt

;;; can result in; effort-limit determines max amount of work that can

;;; be done attempting to integrate

(define-threaded score-limit 20)

(define-threaded effort-limit 200)

;;; inner unrolling doesn't work, and when set nonzero, effectively

;;; disables outer unrolling as well

(define-threaded inner-unroll-limit 0)

;;; outer-unroll-limit of 0 disables integration of recursive

;;; procedures. outer-unroll-limit of 1 is probably a more

;;; reasonable default, except we then trash cp1's loop recognition

(define-threaded outer-unroll-limit 0)

;;; used to memoize pure?, etc.

(define-threaded cp0-info-hashtable)

(module ()

(define-syntax define-cp0-param

(syntax-rules ()

[(_ global-name local-name filter)

(set! global-name

(case-lambda

[() local-name]

[(x) (set! local-name (filter 'global-name x))]))]))

(define filter-limit

(lambda (who x)

(unless (and (fixnum? x) (fx>= x 0))

($oops who "invalid limit ~s" x))

x))

(define filter-bool (lambda (who x) (and x #t)))

(define-cp0-param cp0-effort-limit effort-limit filter-limit)

(define-cp0-param cp0-score-limit score-limit filter-limit)

(define-cp0-param cp0-outer-unroll-limit outer-unroll-limit filter-limit)

(define-cp0-param $cp0-inner-unroll-limit inner-unroll-limit filter-limit)

(define-cp0-param $cp0-polyvariant polyvariant filter-bool))

(define (rappend ls1 ls2)

(if (null? ls1)

ls2

(rappend (cdr ls1) (cons (car ls1) ls2))))

; don't use rtd-* as defined in record.ss in case we're building a patch

; file for cross compilation, because the offsets may be incorrect

(define rtd-flds (csv7:record-field-accessor #!base-rtd 'flds))

(define rtd-parent (csv7:record-field-accessor #!base-rtd 'parent))

(define rtd-size (csv7:record-field-accessor #!base-rtd 'size))

(define rtd-pm (csv7:record-field-accessor #!base-rtd 'pm))

; compile-time rtds (ctrtds)

(define ctrtd-opaque-known #b0000001)

(define ctrtd-sealed-known #b0000010)

(define base-ctrtd ($make-record-type #!base-rtd #!base-rtd "ctrtd" '((immutable flags)) #t #f))

(define ctrtd? (record-predicate base-ctrtd))

(define ctrtd-flags (record-accessor base-ctrtd 0))

(define record-type-sealed-known?

(lambda (rtd)

(or (not (ctrtd? rtd))

(fxlogtest (ctrtd-flags rtd) ctrtd-sealed-known))))

(define record-type-opaque-known?

(lambda (rtd)

(or (not (ctrtd? rtd))

(fxlogtest (ctrtd-flags rtd) ctrtd-opaque-known))))

(with-output-language (Lsrc Expr)

(define void-rec `(quote ,(void)))

(define true-rec `(quote #t))

(define false-rec `(quote #f))

(define null-rec `(quote ()))

(define empty-vector-rec `(quote #()))

(define empty-string-rec `(quote ""))

(define empty-bytevector-rec `(quote #vu8()))

(define empty-fxvector-rec `(quote #vfx()))

;;; environments

(module (empty-env with-extended-env lookup)

(define empty-env '())

(define-record-type env

(nongenerative)

(fields old-ids new-ids next))

(define-syntax with-extended-env

(syntax-rules ()

[(_ ((new-env new-ids) (?old-env ?old-ids ?opnds)) e1 e2 ...)

(let-values ([(new-env new-ids) (extend-env ?old-env ?old-ids ?opnds)])

(let ([e (let () e1 e2 ...)])

(deinitialize-ids! new-ids)

e))]))

(define extend-env

(lambda (old-env old-ids opnds)

(let ([new-ids (let loop ([old-ids old-ids] [opnds opnds] [rnew-ids '()])

(if (null? old-ids)

(reverse rnew-ids)

(loop

(cdr old-ids)

(and opnds (cdr opnds))

(cons

(let ([old-id (car old-ids)])

(make-prelex

(prelex-name old-id)

(let ([flags (prelex-flags old-id)])

(fxlogor

(fxlogand flags (constant prelex-sticky-mask))

(fxsll (fxlogand flags (constant prelex-is-mask))

(constant prelex-was-flags-offset))))

(prelex-source old-id)

(and opnds

(let ([opnd (car opnds)])

(when (operand? opnd)

(operand-name-set! opnd (prelex-name old-id)))

opnd))))

rnew-ids))))])

(values (make-env (list->vector old-ids) (list->vector new-ids) old-env) new-ids))))

(define deinitialize-ids!

(lambda (ids)

; clear operand field (a) to release storage the operands occupy and (b) to

; prevent fasling of useless operands in cte-optimization-locs. clear even

; if we didn't set (i.e., even if opnds or the corresponding opnd is #f), for

; the benefit of cp0-rec-let, which sets operand fields after creating env

(for-each (lambda (id) (prelex-operand-set! id #f)) ids)))

(define lookup

(lambda (id env)

(let loop1 ([env env])

(if (eqv? env empty-env)

id

(let ([old-rib (env-old-ids env)] [new-rib (env-new-ids env)])

(let ([n (vector-length old-rib)])

(let loop2 ([i 0])

(if (fx= i n)

(loop1 (env-next env))

(if (eq? (vector-ref old-rib i) id)

(vector-ref new-rib i)

(let ([i (fx+ i 1)])

(if (fx= i n)

(loop1 (env-next env))

(if (eq? (vector-ref old-rib i) id)

(vector-ref new-rib i)

(loop2 (fx+ i 1)))))))))))))))

(define cp0-make-temp ; returns an unassigned temporary

(lambda (multiply-referenced?)

(let ([t (make-prelex*)])

(when multiply-referenced? (set-prelex-multiply-referenced! t #t))

(set-prelex-referenced! t #t)

t)))

;;; contexts

;; app context:

;; opnds are the operands at the call site

;; ctxt is the outer context

;; convention is a symbol: call, apply2 (safe), or apply3 (unsafe)

;; src is the call source

;; used is set to a list of operands used (let-bound) by integrated call

;; unused is set to a list of operands not used by integrated call

(define-record-type app

(fields opnds ctxt convention name preinfo (mutable used) (mutable unused))

(nongenerative)

(sealed #t)

(protocol

(lambda (new)

(lambda (opnds ctxt convention name preinfo)

(new opnds ctxt convention name preinfo #f #f)))))

(define-syntax context-case

(lambda (x)

(define predicate

(lambda (type)

(syntax-case type (app)

[app #'app?]

[_ (with-syntax ([type type])

#'(lambda (x) (eq? x 'type)))])))

(syntax-case x (else)

[(_ ctxt-exp [(type ...) e1 e2 ...] more ...)

(with-syntax (((pred ...) (map predicate #'(type ...))))

#'(let ((ctxt ctxt-exp))

(if (or (pred ctxt) ...)

(begin e1 e2 ...)

(context-case ctxt more ...))))]

[(_ ctxt-exp [else e1 e2 ...]) #'(begin e1 e2 ...)]

[(_ ctxt-exp)

#'($oops 'cp0-internal "unexpected context ~s" ctxt-exp)])))

(define-syntax convention-case

(lambda (x)

(syntax-case x (else)

[(_ conv-exp [(key ...) e1 e2 ...] more ...)

#'(let ((conv conv-exp))

(if (or (eq? conv 'key) ...)

(begin e1 e2 ...)

(convention-case conv more ...)))]

[(_ conv-exp [else e1 e2 ...]) #'(begin e1 e2 ...)]

[(_ conv-exp)

#'($oops 'cp0-internal "unexpected app convention ~s" conv-exp)])))

;;; operands

(define-record-type operand

(fields

(immutable exp)

(immutable env)

(immutable wd)

(immutable moi)

(mutable name)

(mutable score)

(mutable pending)

(mutable opending)

(mutable value)

(mutable singly-referenced-score)

(mutable lifted))

(nongenerative)

(protocol

(lambda (new)

(lambda (exp env wd moi)

(new exp env wd moi #f 0 0 0 #f #f #f)))))

(define-record-type lifted

(fields (immutable seq?) (immutable ids) (immutable vals))

(nongenerative)

(sealed #t))

(define build-operands

(lambda (args env wd moi)

(map (lambda (x) (make-operand x env wd moi)) args)))

(define build-cooked-opnd

(lambda (e)

(let ([o (make-operand #f #f #f #f)])

(operand-value-set! o e)

o)))

;;; cycle detection

(define inner-cyclic?

(lambda (opnd)

(when (fx> (operand-pending opnd) 0)

; seed outer pending flag if cycle is detected

(operand-opending-set! opnd 1))

(fx> (operand-pending opnd) inner-unroll-limit)))

(define outer-cyclic?

(lambda (opnd)

(fx> (operand-opending opnd) outer-unroll-limit)))

(define-threaded opending-list '())

(define unwind-pending!

(lambda (oplist)

(do ((ls opending-list (cdr ls)))

((eq? ls oplist) (set! opending-list ls))

(operand-opending-set! (car ls)

(fx- (operand-opending (car ls)) 1)))))

(define-syntax pending-protect

; we don't need to maintain list of inner pending operands to be

; unwound by bug-out, since we never abort a visit to an operand

; that we actually need. in other words, when we bug out of an

; inlining attempt, we abort the visiting of only operands created

; during the inlining attempt.

(syntax-rules ()

((_ opnd e1 e2 ...)

(let ((o opnd))

(operand-pending-set! o (fx+ (operand-pending o) 1))

(let ((t (begin e1 e2 ...)))

(operand-pending-set! o (fx- (operand-pending o) 1))

t)))))

(define-syntax opending-protect

; dynamic wind could be used but is much slower

(syntax-rules ()

((_ opnd e1 e2 ...)

(let ((o opnd))

(operand-opending-set! o (fx+ (operand-opending o) 1))

(set! opending-list (cons opnd opending-list))

(let ((t (begin e1 e2 ...)))

(set! opending-list (cdr opending-list))

(operand-opending-set! o (fx- (operand-opending o) 1))

t)))))

;;; scorers

(define-record-type scorer

(fields (mutable limit) (immutable ctxt) (immutable k) (immutable oplist))

(nongenerative)

(sealed #t)

(protocol

(lambda (new)

(lambda (limit ctxt k)

(new limit ctxt k opending-list)))))

(define new-scorer

; with no arguments, create a passive scorer with a high limit that

; (we assume) won't overflow; this allows us to keep a tally without

; ever bugging out. with two arguments n and k, create a scorer that

; will bug out to if bumped n times.

(case-lambda

[() (make-scorer (most-positive-fixnum) #f oops-k)]

[(n ctxt k) (make-scorer n ctxt k)]))

(define oops-k

(list (lambda (x)

($oops 'compiler-internal "bug out from passive scorer"))))

(define scorer-score

; assuming we'll ask for score only of passive scorers

(lambda (sc)

(- (most-positive-fixnum) (scorer-limit sc))))

(define passive-scorer?

(lambda (sc)

(eq? (scorer-k sc) oops-k)))

(define new-watchdog

(case-lambda

[() (make-scorer (most-positive-fixnum) #f oops-k)]

[(wd ctxt k)

; create a new watchdog only if the old one isn't alert

(if (passive-scorer? wd)

(make-scorer effort-limit ctxt k)

wd)]))

(define bump

(lambda (sc amount)

(let ((n (fx- (scorer-limit sc) amount)))

(scorer-limit-set! sc n)

(when (fx< n 0) (bug-out! sc)))))

(define bug-out!

(lambda (sc)

(reset-integrated! (scorer-ctxt sc))

(unwind-pending! (scorer-oplist sc))

((scorer-k sc) #f)))

(define reset-integrated!

(lambda (ctxt)

(app-used-set! ctxt #f)

(let ((ctxt (app-ctxt ctxt)))

(when (app? ctxt) (reset-integrated! ctxt)))))

;;; visiting operands

(define visit-operand!

(lambda (opnd ctxt)

; NB: commonize with np-recognize-let

(define extract-profile-forms

(lambda (e)

(define seqs-and-profiles?

(lambda (e)

(nanopass-case (Lsrc Expr) e

[(profile ,src) #t]

[(seq ,e1 ,e2) (and (seqs-and-profiles? e1) (seqs-and-profiles? e2))]

[else #f])))

(if (eq? ($compile-profile) 'source)

(let loop ([e e] [eprof #f])

(nanopass-case (Lsrc Expr) e

[(seq ,e1 ,e2)

(guard (seqs-and-profiles? e1))

(loop e2 (if eprof `(seq ,eprof ,e1) e1))]

[else (values e eprof)]))

(values e #f))))

; set up to assimilate nested let/letrec/letrec* bindings.

; lifting job is completed by cp0-call or letrec/letrec*

(define (split-value e)

(nanopass-case (Lsrc Expr) e

[(call ,preinfo0 (case-lambda ,preinfo1 (clause (,x* ...) ,interface ,body)) ,e* ...)

(guard (fx= interface (length e*)))

(cond

; when lifting all assimilated let bindings, require each RHS to be

; simple, since they are treated as letrec/letrec* bindings, which does

; not preserve let semantics wrt continuation grabs in RHS expressions.

; further, require each RHS to be pure unless the body is pure, since it's

; unsound to split apart two things that can observe a side effect or two

; allocation operations that can be separated by a continuation grab.

[(if (ivory? body) (andmap simple/profile? e*) (andmap ivory? e*))

; assocate each lhs with cooked operand for corresponding rhs. make-record-constructor-descriptor,

; at least, counts on this to allow protocols to be inlined.

(for-each (lambda (x e) (prelex-operand-set! x (build-cooked-opnd e)) (operand-name-set! opnd (prelex-name x))) x* e*)

(values (make-lifted #f x* e*) body)]

; okay, so we don't pass that test. if body and e* are simple, we can

; still lift by making a binding for body and requesting letrec* semantics.

; that way, we aren't splitting e* and body. we still can't lift anything

; that might capture a continuation, though it's tricky to come up with

; example that breaks.

; we don't presently have any justification (benchmark results or expand/optimize

; mats) that establish the benefit of this, but might want to revisit/refine at

; some point.

#;[(and (simple? body) (andmap simple? e*))

(let ([t (cp0-make-temp #f)]) ; mark was-referenced?

(let ([x* (append x* (list t))] [e* (append e* (list body))])

(for-each (lambda (x e) (prelex-operand-set! x (build-cooked-opnd e)) (operand-name-set! opnd (prelex-name x))) x* e*)

(values (make-lifted #t x* e*) (build-ref t))))]

; otherwise lift out only bindings with unasigned lhs and ivory rhs

; we don't presently have any justification (benchmark results or expand/optimize

; mats) that establish the benefit of this, but might want to revisit/refine at

; some point.

#;[(ormap (lambda (x e) (and (not (prelex-assigned x)) (ivory? e))) x* e*)

(let loop ([x* x*] [e* e*] [rx* '()] [re* '()] [rlx* '()] [rle* '()])

(if (null? x*)

(values (make-lifted #f (reverse rlx*) (reverse rle*))

(build-let (reverse rx*) (reverse re*) body))

(let ([x (car x*)] [e (car e*)])

(if (and (not (prelex-assigned x)) (ivory? e))

(begin

; assocate each lhs with cooked operand for corresponding rhs. see note above.

(prelex-operand-set! x (build-cooked-opnd e))

(operand-name-set! opnd (prelex-name x))

(loop (cdr x*) (cdr e*) rx* re* (cons x rlx*) (cons e rle*)))

(loop (cdr x*) (cdr e*) (cons x rx*) (cons e re*) rlx* rle*)))))]

[else (values #f e)])]

; for assimilated letrec/letrec* bindings, require each RHS to be

; pure OR body to be pure, since we can't separate non-pure

; RHS and body expressions

[(letrec ([,x* ,e*] ...) ,body)

(guard (or (ivory? body) (andmap ivory? e*)))

; assocate each lhs with cooked operand for corresponding rhs. see note above.

(for-each (lambda (x e) (prelex-operand-set! x (build-cooked-opnd e)) (operand-name-set! opnd (prelex-name x))) x* e*)

(values (make-lifted #f x* e*) body)]

; force the issue by creating an extra tmp for body

; we don't presently have any justification (benchmark results or expand/optimize

; mats) that establish the benefit of this, but might want to revisit/refine at

; some point.

#;[(letrec ([,x* ,e*] ...) ,body)

(let ([x (cp0-make-temp #f)])

(let ([x* (append x* (list x))] [e* (append e* (list body))])

(for-each (lambda (x e) (prelex-operand-set! x (build-cooked-opnd e)) (operand-name-set! opnd (prelex-name x))) x* e*)

(values (make-lifted #t x* e*) (build-ref x))))]

[(letrec* ([,x* ,e*] ...) ,body)

(guard (or (ivory? body) (andmap ivory? e*)))

; assocate each lhs with cooked operand for corresponding rhs. see note above.

(for-each (lambda (x e) (prelex-operand-set! x (build-cooked-opnd e)) (operand-name-set! opnd (prelex-name x))) x* e*)

(values (make-lifted #t x* e*) body)]

; force the issue by creating an extra tmp for body.

; we don't presently have any justification (benchmark results or expand/optimize

; mats) that establish the benefit of this, but might want to revisit/refine at

; some point.

#;[(letrec* ([,x* ,e*] ...) ,body)

(let ([x (cp0-make-temp #f)])

(let ([x* (append x* (list x))] [e* (append e* (list body))])

(for-each (lambda (x e) (prelex-operand-set! x (build-cooked-opnd e)) (operand-name-set! opnd (prelex-name x))) x* e*)

(values (make-lifted #t x* e*) (build-ref x))))]

; we can lift arbitrary subforms of record forms if we also lift

; a binding for the record form itself. there's no worry about

; continuation captures: if rtd-expr or e* capture a contination,

; invoking the continuation to return from a rhs is no worse than

; invoking the continuation to build the record and then return

; from a rhs.

[(record ,rtd ,rtd-expr ,e* ...)

(let-values ([(liftmt* liftme* e*)

(let ([fld* (rtd-flds rtd)])

(let f ([e* e*] [fld* fld*])

(if (null? e*)

(values '() '() '())

(let ([e (car e*)])

(let-values ([(liftmt* liftme* e*) (f (cdr e*) (cdr fld*))])

(if (nanopass-case (Lsrc Expr) e

[(ref ,maybe-src ,x) #f]

[(quote ,d) #f]

[,pr #f]

[else (not (fld-mutable? (car fld*)))])

(let ([t (cp0-make-temp #f)])

(values (cons t liftmt*) (cons e liftme*) (cons (build-ref t) e*)))

(values liftmt* liftme* (cons e e*))))))))])

(let ([e `(record ,rtd ,rtd-expr ,e* ...)])

(if (null? liftmt*)

(values #f e)

(let ([x (cp0-make-temp #f)])

(let ([x* (append liftmt* (list x))] [e* (append liftme* (list e))])

(for-each (lambda (x e) (prelex-operand-set! x (build-cooked-opnd e)) (operand-name-set! opnd (prelex-name x))) x* e*)

(values (make-lifted #t x* e*) (build-ref x)))))))]

[else (values #f e)]))

(or (operand-value opnd)

(let ([sc (new-scorer)])

(let ([e0 (pending-protect opnd

(cp0 (operand-exp opnd) ctxt (operand-env opnd) sc (operand-wd opnd) (operand-name opnd) (operand-moi opnd)))])

(let-values ([(e1 eprof) (extract-profile-forms e0)])

(with-values (split-value e1)

(lambda (lifted e)

(let ([e (if eprof (make-seq ctxt eprof e) e)])

(operand-lifted-set! opnd lifted)

(operand-value-set! opnd e)

(operand-score-set! opnd (scorer-score sc))

e)))))))))

(define value-visit-operand!

(lambda (opnd)

(visit-operand! opnd 'value)))

(define test-visit-operand!

(lambda (opnd)

(visit-operand! opnd 'test)))

(define value-visit-operands!

(lambda (opnds)

(map value-visit-operand! opnds)))

(define residualize-seq

; ctxt must be an app context. set used and unused lists in context

(lambda (used unused ctxt)

(safe-assert (fx= (fx+ (length used) (length unused)) (length (app-opnds ctxt))))

(app-used-set! ctxt used)

(app-unused-set! ctxt unused)))

(define residualize-call-opnds

(lambda (used unused e ctxt sc)

(let f ((used used) (n 0))

(if (null? used)

(let f ((unused unused) (n n) (todo '()))

(if (null? unused)

(begin

(bump sc n)

(let f ((todo todo) (e e))

(if (null? todo)

e

(f (cdr todo)

(make-seq ctxt

(let ((opnd (car todo)))

(cp0 (operand-exp opnd) 'effect (operand-env opnd)

sc (operand-wd opnd) (operand-name opnd) (operand-moi opnd)))

e)))))

(let ((opnd (car unused)))

(let ((e (operand-value opnd)))

(if e

(if (simple? e)

(if (operand-singly-referenced-score opnd)

; singly-referenced integration attempt in copy2 succeeded

(f (cdr unused) (fx+ (operand-singly-referenced-score opnd) n) todo)

(f (cdr unused) n todo))

; overscoring bug: make-seq may drop e2 if e is (seq e1 e2), but

; we add in the entire score here

; if singly-referenced integration attempt in copy2 succeeded, but

; value isn't simple, we also pay the whole price

(make-seq ctxt e (f (cdr unused) (fx+ n (operand-score opnd)) todo)))

(if (operand-singly-referenced-score opnd)

; singly-referenced integration attempt in ref-case of cp0 succeeded

(f (cdr unused) (fx+ (operand-singly-referenced-score opnd) n) todo)

(f (cdr unused) n (cons opnd todo))))))))

(f (cdr used) (fx+ (operand-score (car used)) n))))))

(define cp0-constant?

(case-lambda

[(x)

(nanopass-case (Lsrc Expr) x

[(quote ,d) #t]

[else #f])]

[(pred? x)

(nanopass-case (Lsrc Expr) x

[(quote ,d) (pred? d)]

[else #f])]))

(define-who cp0-datum

(lambda (x)

(nanopass-case (Lsrc Expr) x

[(quote ,d) d]

[else (sorry! who "~s is not a constant" x)])))

(define preinfo-call->preinfo-lambda

(lambda (preinfo)

(make-preinfo-lambda (preinfo-src preinfo) (preinfo-sexpr preinfo))))

(define build-quote

(lambda (d)

`(quote ,d)))

(define build-ref

(lambda (x)

`(ref #f ,x)))

(module (build-primcall)

(define $build-primcall

(case-lambda

[(primref args) ($build-primcall (make-preinfo) primref args)]

[(preinfo primref args) `(call ,preinfo ,primref ,args ...)]))

(define-syntax build-primcall

(syntax-rules ()

[(_ level name args) ($build-primcall (lookup-primref level name) args)]

[(_ preinfo level name args) ($build-primcall preinfo (lookup-primref level name) args)])))

(define build-lambda

(case-lambda

[(ids body) (build-lambda (make-preinfo-lambda) ids body)]

[(preinfo ids body) `(case-lambda ,preinfo (clause (,ids ...) ,(length ids) ,body))]))

(define build-case-lambda

(case-lambda

[(clause*) (build-case-lambda (make-preinfo-lambda) clause*)]

[(preinfo clause*)

`(case-lambda ,preinfo

,(map (lambda (clause)

(with-output-language (Lsrc CaseLambdaClause)

(let ([x* (car clause)])

`(clause (,x* ...) ,(length x*) ,(cadr clause)))))

clause*) ...)]))

; build-call is not very cp0-like, since it doesn't enable further

; optimization, but it does clean up some silly looking code.

(define build-call

(lambda (preinfo proc args)

(let ([n (length args)])

(nanopass-case (Lsrc Expr) proc

; eta reduce ((lambda (x ...) (prim x ...)) e ...) => (prim e ...)

[(case-lambda ,preinfo0

(clause (,x* ...) ,interface

(call ,preinfo1 ,pr ,e* ...)))

(guard (fx= interface n) (fx= (length e*) n)

(andmap (lambda (x e)

(nanopass-case (Lsrc Expr) e

[(ref ,maybe-src ,x1) (eq? x1 x)]

[else #f]))

x* e*))

`(call ,preinfo1 ,pr ,args ...)]

[else `(call ,preinfo ,proc ,args ...)]))))

(define build-let

(case-lambda

[(lambda-preinfo ids exps body)

(build-call (make-preinfo) (build-lambda lambda-preinfo ids body) exps)]

[(ids exps body) (build-call (make-preinfo) (build-lambda ids body) exps)]))

(define build-named-let

(lambda (name ids exps body)

`(call ,(make-preinfo)

(letrec ([,name ,(build-lambda ids body)])

(ref #f ,name))

,exps ...)))

(define make-seq

; ensures that the right subtree of the output seq is not a seq if the

; second argument is similarly constrained, to facilitate result-exp

(lambda (ctxt e1 e2)

(if (simple? e1)

e2

(if (and (eq? ctxt 'effect) (simple? e2))

e1

(let ([e1 (nanopass-case (Lsrc Expr) e1

[(seq ,e11 ,e12)

(guard (simple? e12))

e11]

[else e1])])

(nanopass-case (Lsrc Expr) e2

[(seq ,e21 ,e22) `(seq (seq ,e1 ,e21) ,e22)]

[else `(seq ,e1 ,e2)]))))))

(define make-seq* ; requires at least one operand

(lambda (ctxt e*)

(if (null? (cdr e*))

(car e*)

(make-seq ctxt (car e*) (make-seq* ctxt (cdr e*))))))

(define make-if

(lambda (ctxt sc e1 e2 e3)

(cond

[(record-equal? e2 e3 ctxt) (make-seq ctxt e1 e2)]

[(and (cp0-constant? (lambda (x) (eq? x #f)) e3)

(record-equal? e1 e2 (if (eq? ctxt 'test) 'test 'value))

(simple? e1))

e1]

[(nanopass-case (Lsrc Expr) (result-exp e1)

[(if ,e11 ,[result-exp : e12 -> re12] ,[result-exp : e13 -> re13])

(if (and (cp0-constant? re12) (cp0-constant? re13))

(let ([d12 (cp0-datum re12)] [d13 (cp0-datum re13)])

(non-result-exp e1

(cond

[(and d12 d13) (make-seq ctxt (make-if 'effect sc e11 e12 e13) e2)]

[(not (or d12 d13)) (make-seq ctxt (make-if 'effect sc e11 e12 e13) e3)]

[else (let ([e2 (non-result-exp e12 e2)] [e3 (non-result-exp e13 e3)])

(let-values ([(e2 e3) (if d12 (values e2 e3) (values e3 e2))])

(make-if ctxt sc e11 e2 e3)))])))

#f)]

[else #f])]

[else

(bump sc 1)

`(if ,e1 ,e2 ,e3)])))

(define result-exp

(lambda (e)

(nanopass-case (Lsrc Expr) e

[(seq ,e1 ,e2) e2]

[else e])))

(define result-exp/indirect-ref

; useful only when interested in non-propagatable result expressions, e.g., lambda expressions

; NB: to avoid code duplication, don't residualize the resulting value

(lambda (x)

(let ([x (result-exp x)])

(or (nanopass-case (Lsrc Expr) x

[(ref ,maybe-src ,x)

(and (not (prelex-was-assigned x))

(let ([opnd (prelex-operand x)])

(and opnd

(let ([x (operand-value opnd)])

(and x (result-exp x))))))]

[else #f])

x))))

(define non-result-exp

(lambda (e body)

(nanopass-case (Lsrc Expr) e

[(seq ,e1 ,e2) `(seq ,e1 ,body)]

[else body])))

(define (arity-okay? arity n)

(or (not arity) ; presumably system routine w/no recorded arity

(ormap

(lambda (a)

(or (fx= n a)

(and (fx< a 0) (fx>= n (fx- -1 a)))))

arity)))

(define okay-to-copy?

(lambda (obj)

; okay to copy obj if (eq? (faslin (faslout x)) x) => #t or (in the case of numbers and characters)

; the value of (eq? x x) is unspecified

(or (symbol? obj)

(number? obj)

(char? obj)

(boolean? obj)

(null? obj)

(eqv? obj "")

(eqv? obj '#())

(eqv? obj '#vu8())

(eqv? obj '#vfx())

(eq? obj (void))

(eof-object? obj)

(bwp-object? obj)

(eq? obj '#6=#6#)

($unbound-object? obj)

(record-type-descriptor? obj))))

(define externally-inlinable?

(lambda (clause)

(call/cc

(lambda (exit)

(define bump!

(let ([size 0])

(lambda ()

(set! size (fx+ size 1))

(when (fx> size score-limit) (exit #f)))))

(define (ids->do-clause ids)

(rec do-clause

(lambda (clause)

(define (ids->do-expr ids)

(rec do-expr

(lambda (e)

(nanopass-case (Lsrc Expr) e

[(quote ,d) (if (okay-to-copy? d) (bump!) (exit #f))]

[(moi) (bump!)]

[,pr (bump!)]

[(ref ,maybe-src ,x) (unless (memq x ids) (exit #f)) (bump!)]

[(seq ,[do-expr : e1] ,[do-expr : e2]) (void)]

[(if ,[do-expr : e1] ,[do-expr : e2] ,[do-expr : e3]) (void)]

[(set! ,maybe-src ,x ,e)

(unless (memq x ids) (exit #f))

(bump!)

(do-expr e)]

[(call ,preinfo ,e ,e* ...)

; reject calls to gensyms, since they might represent library exports,

; and we have no way to set up the required invoke dependencies

(when (and (nanopass-case (Lsrc Expr) e

[,pr (eq? (primref-name pr) '$top-level-value)]

[else #f])

(= (length e*) 1)

(cp0-constant? gensym? (car e*)))

(exit #f))

(bump!)

(do-expr e)

(for-each do-expr e*)]

[(case-lambda ,preinfo ,cl* ...)

(bump!)

(for-each (ids->do-clause ids) cl*)]

[(letrec ([,x* ,e*] ...) ,body)

(bump!)

(safe-assert (andmap (lambda (x) (not (prelex-operand x))) x*))

(let ([do-expr (ids->do-expr (append x* ids))])

(for-each do-expr e*)

(do-expr body))]

[(letrec* ([,x* ,e*] ...) ,body)

(bump!)

(safe-assert (andmap (lambda (x) (not (prelex-operand x))) x*))

(let ([do-expr (ids->do-expr (append x* ids))])

(for-each do-expr e*)

(do-expr body))]

[(record-type ,rtd ,[do-expr : e]) (void)]

[(record-cd ,rcd ,rtd-expr ,[do-expr : e]) (void)]

[(record-ref ,rtd ,type ,index ,[do-expr : e]) (bump!)]

[(record-set! ,rtd ,type ,index ,[do-expr : e1] ,[do-expr : e2]) (bump!)]

[(record ,rtd ,[do-expr : rtd-expr] ,[do-expr : e*] ...) (bump!)]

[(immutable-list (,[e*] ...) ,[e]) (void)]

[(pariah) (void)]

[(profile ,src) (void)]

[else (exit #f)]))))

(nanopass-case (Lsrc CaseLambdaClause) clause

[(clause (,x* ...) ,interface ,body)

(safe-assert (andmap (lambda (x) (not (prelex-operand x))) x*))

((ids->do-expr (append x* ids)) body)]))))

((ids->do-clause '()) clause)

#t))))

(module (pure? ivory? simple? simple/profile? boolean-valued?)

(define-syntax make-$memoize

(syntax-rules ()

[(_ flag-known flag)

(lambda (e pred?)

(let ([a (eq-hashtable-cell cp0-info-hashtable e 0)])

(let ([flags (cdr a)])

(if (all-set? (cp0-info-mask flag-known) flags)

(all-set? (cp0-info-mask flag) flags)

(let ([bool (pred?)])

(set-cdr! a (set-flags (if bool (cp0-info-mask flag-known flag) (cp0-info-mask flag-known)) flags))

bool)))))]))

(define-syntax with-memoize

(lambda (x)

(syntax-case x ()

[(k (flag-known flag) ?e e* ...)

(with-implicit (k memoize)

#'(let ([$memoize (make-$memoize flag-known flag)] [e ?e])

(define-syntax memoize

(syntax-rules ()

[(_ e1 e2 (... ...)) ($memoize e (lambda () e1 e2 (... ...)))]))

e* ...))])))

(define-who pure?

; does not cause or observe any effects, capture or invoke a continuation,

; or allocate mutable data structures. might contain profile forms, so

; pure forms cannot necessarily be discarded. mostly used to determine if

; we can move an expression. differs from ivory in that restricted primitives

; and record refs are not considered pur at optimize-level 3, which allows

; pure expressions to be moved in more circumstances.

(lambda (e)

(with-memoize (pure-known pure) e

; 2015/02/11 sorted by frequency

(nanopass-case (Lsrc Expr) e

[(ref ,maybe-src ,x) (not (prelex-was-assigned x))]

[(call ,preinfo ,e ,e* ...)

(let ()

(define pure-call?

(lambda (maybe-e e)

(nanopass-case (Lsrc Expr) e

[,pr

(and (let ([flags (primref-flags e)])

(all-set? (prim-mask (or pure unrestricted)) flags))

(arity-okay? (primref-arity e) (length e*))

(memoize (and (or (not maybe-e) (pure? maybe-e)) (andmap pure? e*))))]

[(case-lambda ,preinfo1 (clause (,x* ...) ,interface ,body))

(guard (fx= interface (length e*)))

(memoize (and (or (not maybe-e) (pure? maybe-e)) (pure? body) (andmap pure? e*)))]

[else #f])))

(nanopass-case (Lsrc Expr) e

[(seq ,e1 ,e2) (pure-call? e1 e2)]

[else (pure-call? #f e)]))]

[(quote ,d) #t]

[,pr #t]

[(case-lambda ,preinfo ,cl* ...) #t]

[(if ,e1 ,e2 ,e3) (memoize (and (pure? e1) (pure? e2) (pure? e3)))]

[(seq ,e1 ,e2) (memoize (and (pure? e1) (pure? e2)))]

[(record-ref ,rtd ,type ,index ,e) #f]

[(record-set! ,rtd ,type ,index ,e1 ,e2) #f]

[(record ,rtd ,rtd-expr ,e* ...)

(and (andmap (lambda (fld)

(and (not (fld-mutable? fld))

(eq? (filter-foreign-type (fld-type fld)) 'scheme-object)))

(rtd-flds rtd))

(memoize (and (pure? rtd-expr) (andmap pure? e*))))]

[(set! ,maybe-src ,x ,e) #f]

[(record-cd ,rcd ,rtd-expr ,e) (memoize (pure? e))]

[(letrec ([,x* ,e*] ...) ,body) (memoize (and (andmap pure? e*) (pure? body)))]

[(record-type ,rtd ,e) (memoize (pure? e))]

[(foreign ,conv ,name ,e (,arg-type* ...) ,result-type) (memoize (pure? e))]

[(letrec* ([,x* ,e*] ...) ,body) (memoize (and (andmap pure? e*) (pure? body)))]

[(immutable-list (,e* ...) ,e) (memoize (and (andmap pure? e*) (pure? e)))]

[(profile ,src) #t]

[(cte-optimization-loc ,box ,e) (memoize (pure? e))]

[(moi) #t]

[(fcallable ,conv ,e (,arg-type* ...) ,result-type) (memoize (pure? e))]

[(pariah) #t]

[else ($oops who "unrecognized record ~s" e)]))))

(define-who ivory? ; 99.44% pure

; does not cause or observe any effects, capture or invoke a continuation,

; or allocate mutable data structures. might contain profile forms, so

; ivory forms cannot necessarily be discarded. mostly used to determine if

; we can move an expression. differs from pure in that restricted primitives

; and record refs are considered ivory at optimize-level 3.

(lambda (e)

(with-memoize (ivory-known ivory) e

; 2015/02/11 sorted by frequency

(nanopass-case (Lsrc Expr) e

[(ref ,maybe-src ,x) (not (prelex-was-assigned x))]

[(call ,preinfo ,e ,e* ...)

(let ()

(define ivory-call?

(lambda (maybe-e e)

(nanopass-case (Lsrc Expr) e

[,pr

(and (let ([flags (primref-flags e)])

; here ivory? differs from pure?

(if (all-set? (prim-mask unsafe) flags)

(all-set? (prim-mask pure) flags)

(all-set? (prim-mask (or pure unrestricted)) flags)))

(arity-okay? (primref-arity e) (length e*))

(memoize (and (or (not maybe-e) (ivory? maybe-e)) (andmap ivory? e*))))]

[(case-lambda ,preinfo1 (clause (,x* ...) ,interface ,body))

(guard (fx= interface (length e*)))

(memoize (and (or (not maybe-e) (ivory? maybe-e)) (ivory? body) (andmap ivory? e*)))]

[else #f])))

(nanopass-case (Lsrc Expr) e

[(seq ,e1 ,e2) (ivory-call? e1 e2)]

[else (ivory-call? #f e)]))]

[(quote ,d) #t]

[,pr #t]

[(case-lambda ,preinfo ,cl* ...) #t]

[(if ,e1 ,e2 ,e3) (memoize (and (ivory? e1) (ivory? e2) (ivory? e3)))]

[(seq ,e1 ,e2) (memoize (and (ivory? e1) (ivory? e2)))]

[(record-ref ,rtd ,type ,index ,e)

; here ivory? differs from pure?