1808 lines
62 KiB
Racket
1808 lines
62 KiB
Racket
|
|
;; Implements a source-to-source optimizer
|
|
|
|
;; The src-to-src transformation currently drops
|
|
;; properties, which is bad. The 'mzc-cffi,
|
|
;; 'method-arity-error, and 'inferred-name properties are
|
|
;; specially preserved for `lambda' expressions.
|
|
|
|
(module src2src scheme/base
|
|
(require mzlib/class
|
|
syntax/kerncase
|
|
syntax/primitives
|
|
mzlib/etc
|
|
mzlib/list
|
|
(for-syntax scheme/base))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Optimizer
|
|
;; classes representing syntax with methods for optimization steps
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; Maximum number of times to inline while processing a call site
|
|
(define max-fuel 0)
|
|
(define fuel (make-parameter max-fuel))
|
|
|
|
(define foldable-prims '(void
|
|
+ - * / arithmetic-shift
|
|
< <= = > >=
|
|
number? positive? negative? zero?
|
|
real? complex?
|
|
string-ref))
|
|
|
|
(define effectless-prims '(list list* cons vector))
|
|
|
|
;; The following primitives either invoke functions, or
|
|
;; install functions that can be used later.
|
|
(define (non-valueable-prims) (procedure-calling-prims))
|
|
|
|
(define code-insp (current-code-inspector))
|
|
|
|
(define (keep-mzc-property stx-out stx)
|
|
(let ([v (syntax-property stx 'mzc-cffi)]
|
|
[v2 (syntax-property stx 'method-arity-error)]
|
|
[v3 (syntax-property stx 'inferred-name)])
|
|
(let ([stx-out2 (if v
|
|
(syntax-property stx-out 'mzc-cffi v)
|
|
stx-out)])
|
|
(let ([stx-out3 (if v2
|
|
(syntax-property stx-out2 'method-arity-error v2)
|
|
stx-out2)])
|
|
(if v3
|
|
(syntax-property stx-out3 'inferred-name v3)
|
|
stx-out3)))))
|
|
|
|
(define-struct context (need indef))
|
|
;; need = #f => don't need the value
|
|
;; need = 'bool => need bool only
|
|
;; need = 'all => need exact result
|
|
|
|
;; indef = list of binding%s
|
|
|
|
(define (need-all ctx)
|
|
(if (eq? 'all (context-need ctx))
|
|
ctx
|
|
(make-context 'all (context-indef ctx))))
|
|
(define (need-none ctx)
|
|
(if (eq? 'none (context-need ctx))
|
|
ctx
|
|
(make-context 'none (context-indef ctx))))
|
|
(define (need-bool ctx)
|
|
(make-context 'bool (context-indef ctx)))
|
|
|
|
(define-struct accessor (make-struct-type-expr position))
|
|
(define-struct mutator (make-struct-type-expr position))
|
|
(define-struct ctor (make-struct-type-expr))
|
|
|
|
(define exp%
|
|
(class object%
|
|
|
|
(init-field src-stx)
|
|
(when (not (syntax? src-stx))
|
|
(printf "~a\n" src-stx)
|
|
(error 'stx))
|
|
(init-field [cert-stxes (list src-stx)])
|
|
(field (known-value #f))
|
|
|
|
;; resets known-value computation, use counts, etc.
|
|
(define/public (reset-varflags)
|
|
(set! known-value #f)
|
|
(for-each (lambda (e) (send e reset-varflags)) (sub-exprs)))
|
|
|
|
;; accumulates known-value mappings, use counts on bindings, etc.;
|
|
;; assumes varflags are reset
|
|
(define/public (set-known-values)
|
|
(for-each (lambda (e) (send e set-known-values)) (nonbind-sub-exprs)))
|
|
|
|
;; sets `mutable?' flags; set-known-values does that, too,
|
|
;; but this one only sets mutable flags
|
|
(define/public (set-mutability)
|
|
(for-each (lambda (e) (send e set-mutability)) (nonbind-sub-exprs)))
|
|
|
|
;; for each reference of a binding in the exp, drop one use
|
|
(define/public (drop-uses)
|
|
(for-each (lambda (e) (send e drop-uses)) (nonbind-sub-exprs)))
|
|
|
|
;; any side-effects might be in this expression?
|
|
;; (return #t if unsure)
|
|
(define/public (no-side-effect?)
|
|
(andmap (lambda (e) (send e no-side-effect?))
|
|
(nonbind-sub-exprs)))
|
|
|
|
;; arity is a number or 'unknown
|
|
(define/public (get-result-arity) 'unknown)
|
|
|
|
;; gets all subexpressions, including binding%s for lambda, etc.
|
|
(define/public (sub-exprs) (append (bind-sub-exprs) (nonbind-sub-exprs)))
|
|
;; just the binding%s
|
|
(define/public (bind-sub-exprs) null)
|
|
;; all subexpressions that aren't binding%s
|
|
(define/public (nonbind-sub-exprs) null)
|
|
|
|
;; some default implementations map over nonbind-sub-exprs,
|
|
;; the install the results with this method
|
|
(define/public (set-nonbind-sub-exprs x) (void))
|
|
|
|
;; valueable means that evaluating the expression can't access
|
|
;; a variable before it is initialized or mutate a
|
|
;; variable. It's used, for example, on the RHSs of a letrec
|
|
;; to determine known bindings.
|
|
(define/public (valueable?)
|
|
(andmap (lambda (x) (send x valueable?)) (nonbind-sub-exprs)))
|
|
|
|
;; ok to duplicate or move the expression?
|
|
;; (return #f if unsure)
|
|
(define/public (can-dup/move?) #f)
|
|
|
|
;; known value is an exp%; usually only binding% objects
|
|
;; get known-value settings
|
|
(define/public (set-known-value x) (set! known-value x))
|
|
|
|
;; finds the most-specific exp% whose value is the
|
|
;; same this this expression's value
|
|
(define/public (get-value) (or known-value this))
|
|
|
|
;; helper:
|
|
(define/private (subexp-map! f)
|
|
(set-nonbind-sub-exprs (map f (nonbind-sub-exprs)))
|
|
this)
|
|
|
|
;; main optimization method:
|
|
(define/public (simplify ctx)
|
|
(subexp-map! (lambda (x)
|
|
(send x simplify (need-all ctx)))))
|
|
|
|
(define/public (escape)
|
|
(subexp-map! (lambda (x) (send x escape))))
|
|
|
|
(define/public (stack-allocate)
|
|
(subexp-map! (lambda (x) (send x stack-allocate))))
|
|
|
|
;; not an optimizations, but exposes info (epsecially to mzc)
|
|
(define/public (reorganize)
|
|
(subexp-map! (lambda (x) (send x reorganize))))
|
|
;; reverses reorganize
|
|
(define/public (deorganize)
|
|
(subexp-map! (lambda (x)
|
|
(send x deorganize))))
|
|
|
|
;; substitution of lexical refs for global variables
|
|
(define/public (global->local env)
|
|
(subexp-map! (lambda (x)
|
|
(send x global->local env))))
|
|
|
|
;; substitution of lexical refs for either lex or global vars
|
|
(define/public (substitute env)
|
|
(subexp-map! (lambda (x)
|
|
(send x substitute env))))
|
|
|
|
;; creates a copy, used for inling; don't try to preserve
|
|
;; analysis, because we'll just re-compute it
|
|
(define/public (clone env)
|
|
(error 'clone "unimplemented: ~a" this))
|
|
|
|
;; gets stx object, usually for src info
|
|
(define/public (get-stx) src-stx)
|
|
|
|
;; convert back to a syntax object
|
|
(define/public (sexpr) src-stx)
|
|
|
|
;; returns cert stxes
|
|
(define/public (get-cert-stxes)
|
|
cert-stxes)
|
|
|
|
;; merges cert info from another expression
|
|
(define/public (merge-certs exp)
|
|
(set! cert-stxes
|
|
(append (filter (lambda (i) (not (memq i cert-stxes)))
|
|
(send exp get-cert-stxes))
|
|
cert-stxes)))
|
|
|
|
;; list of body exprs (avoids redundant `begin', just for
|
|
;; readability)
|
|
(define/public (body-sexpr) (list (sexpr)))
|
|
|
|
(super-instantiate ())))
|
|
|
|
(define (get-sexpr o) (send o sexpr))
|
|
(define (get-body-sexpr o) (send o body-sexpr))
|
|
|
|
(define-struct bucket (mutated? inited-before-use?) #:mutable)
|
|
|
|
(define (global-bucket table stx)
|
|
(let ([l (hash-ref table (syntax-e stx) (lambda () null))])
|
|
(let ([s (ormap (lambda (b)
|
|
(and (free-identifier=? stx (car b))
|
|
(cdr b)))
|
|
l)])
|
|
(if s
|
|
s
|
|
(let ([s (make-bucket #f #f)])
|
|
(hash-set! table (syntax-e stx) (cons (cons stx s) l))
|
|
s)))))
|
|
|
|
(define-struct tables (global-ht et-global-ht))
|
|
|
|
(define global%
|
|
(class exp%
|
|
(init-field trans? tables needs-top?)
|
|
(super-instantiate ())
|
|
(inherit-field src-stx) ;; The identifier
|
|
(inherit-field cert-stxes) ;; The identifier
|
|
|
|
(define mbind #f)
|
|
(define bucket (global-bucket ((if trans? tables-et-global-ht tables-global-ht) tables) src-stx))
|
|
(define/private (get-mbind!)
|
|
(unless mbind
|
|
(set! mbind ((if trans?
|
|
identifier-transformer-binding
|
|
identifier-binding)
|
|
src-stx))))
|
|
(define/public (orig-name)
|
|
(get-mbind!)
|
|
(if (pair? mbind)
|
|
(cadr mbind)
|
|
(syntax-e src-stx)))
|
|
|
|
(define/public (is-kernel?)
|
|
(get-mbind!)
|
|
(and (pair? mbind)
|
|
(eq? (car mbind) '#%kernel)))
|
|
|
|
(define/public (is-trans?) trans?)
|
|
|
|
(define/public (is-mutated?) (bucket-mutated? bucket))
|
|
|
|
(define/override (no-side-effect?)
|
|
;; If not built in, could raise exn
|
|
(is-kernel?))
|
|
|
|
(define/override (get-result-arity) 1)
|
|
|
|
(define/override (valueable?) (or (bucket-inited-before-use? bucket)
|
|
(is-kernel?)))
|
|
|
|
(define/override (can-dup/move?) (valueable?))
|
|
|
|
(define/override (clone env) (make-object global% trans? tables needs-top? src-stx cert-stxes))
|
|
|
|
(define/override (global->local env)
|
|
(or (ormap (lambda (e)
|
|
(and (free-identifier=? (car e) src-stx)
|
|
(make-object ref% (cdr e) src-stx cert-stxes)))
|
|
env)
|
|
this))
|
|
|
|
(define/override (sexpr)
|
|
(if needs-top?
|
|
(with-syntax ([stx src-stx])
|
|
(syntax (#%top . stx)))
|
|
src-stx))
|
|
|
|
(define/public (set-mutated) (set-bucket-mutated?! bucket #t))
|
|
(define/public (set-inited) (set-bucket-inited-before-use?! bucket #t))))
|
|
|
|
(define binding%
|
|
(class exp%
|
|
(init-field always-inited?)
|
|
(super-instantiate ())
|
|
(inherit-field src-stx cert-stxes)
|
|
(define value #f)
|
|
(define used 0)
|
|
(define mutated? #f)
|
|
(define inited? always-inited?)
|
|
(define escape #f)
|
|
|
|
(define/public (is-used?) (positive? used))
|
|
(define/public (is-mutated?) mutated?)
|
|
(define/public (is-inited?) inited?)
|
|
(define/public (get-use-count) used)
|
|
|
|
(define/public (set-mutated) (set! mutated? #t))
|
|
(define/public (set-inited) (set! inited? #t))
|
|
(define/public (set-value v) (set! value v))
|
|
|
|
(define/public (escapes?) escape)
|
|
(define/public (set-escapes x) (set! escape #t))
|
|
|
|
(define/public (clone-binder env)
|
|
(make-object binding%
|
|
always-inited?
|
|
(datum->syntax
|
|
#f
|
|
(gensym (syntax-e src-stx))
|
|
src-stx
|
|
cert-stxes)))
|
|
|
|
|
|
(define/override (reset-varflags)
|
|
(set! used 0)
|
|
(set! mutated? #f)
|
|
(set! inited? always-inited?))
|
|
(define/override (set-known-values)
|
|
(set! used (add1 used))
|
|
(unless inited?
|
|
(set! mutated? #t)))
|
|
|
|
(define/override (valueable?) (and inited? (not mutated?)))
|
|
|
|
(define/override (drop-uses) (set! used (sub1 used)))
|
|
|
|
(define/override (get-value)
|
|
(and (not mutated?)
|
|
value
|
|
(send value get-value)))
|
|
|
|
(define/override (sexpr)
|
|
;; `(==lexical== ,name ,used ,mutated? ,inited? ,(get-value))
|
|
src-stx)
|
|
|
|
(define/public (orig-name)
|
|
(syntax-e src-stx))))
|
|
|
|
(define ref%
|
|
(class exp%
|
|
(init-field binding)
|
|
(super-instantiate ())
|
|
(inherit-field src-stx) ;; The identifier
|
|
|
|
|
|
(define/public (is-used?) (send binding is-used?))
|
|
(define/public (is-mutated?) (send binding is-mutated?))
|
|
(define/public (is-inited?) (send binding is-inited?))
|
|
|
|
(define/public (get-use-count) (send binding get-use-count))
|
|
|
|
(define/public (set-mutated) (send binding set-mutated))
|
|
(define/public (set-inited) (send binding set-inited))
|
|
(define/public (set-value v) (send binding set-value v))
|
|
|
|
(define/override (set-known-values) (send binding set-known-values))
|
|
|
|
(define/override (valueable?) (send binding valueable?))
|
|
(define/override (can-dup/move?) (valueable?))
|
|
|
|
(define/override (drop-uses) (send binding drop-uses))
|
|
|
|
(define/override (get-result-arity) 1)
|
|
|
|
(define/override (get-value) (send binding get-value))
|
|
|
|
(define/override (escape)
|
|
(send binding set-escape))
|
|
|
|
(define/override (simplify ctx)
|
|
(if (context-need ctx)
|
|
(let ([v (get-value)])
|
|
(if (and v (send v can-dup/move?))
|
|
(begin
|
|
(drop-uses)
|
|
(send v simplify ctx))
|
|
this))
|
|
(begin
|
|
(drop-uses)
|
|
(make-object void% src-stx))))
|
|
|
|
(define/override (clone env) (lookup-clone binding this env))
|
|
(define/override (substitute env) (lookup-clone binding this env))
|
|
|
|
(define/override (sexpr)
|
|
(let ([x (send binding sexpr)])
|
|
(datum->syntax
|
|
x
|
|
(syntax-e x)
|
|
src-stx)))
|
|
|
|
(define/public (get-binding) binding)
|
|
(define/public (orig-name) (send binding orig-name))))
|
|
|
|
|
|
(define begin%
|
|
(class exp%
|
|
(init-field subs)
|
|
(super-instantiate ())
|
|
(inherit-field src-stx cert-stxes)
|
|
(inherit merge-certs)
|
|
|
|
(define/override (nonbind-sub-exprs) subs)
|
|
(define/override (set-nonbind-sub-exprs s) (set! subs s))
|
|
|
|
(define/override (get-result-arity)
|
|
(if (null? subs)
|
|
'unknown
|
|
(let loop ([subs subs])
|
|
(if (null? (cdr subs))
|
|
(send (car subs) get-result-arity)
|
|
(loop (cdr subs))))))
|
|
|
|
(define/override (simplify ctx)
|
|
(set! subs
|
|
(let loop ([subs subs])
|
|
(cond
|
|
[(null? subs) null]
|
|
[(null? (cdr subs))
|
|
(list (send (car subs) simplify ctx))]
|
|
[else
|
|
(let ([r (send (car subs) simplify (need-none ctx))]
|
|
[rest (loop (cdr subs))])
|
|
(cond
|
|
[(send r no-side-effect?)
|
|
(send r drop-uses)
|
|
rest]
|
|
[(is-a? r begin%)
|
|
(merge-certs r)
|
|
(append (send r nonbind-sub-exprs)
|
|
rest)]
|
|
[else (cons r rest)]))])))
|
|
(if (and (pair? subs)
|
|
(null? (cdr subs)))
|
|
(let ([v (car subs)])
|
|
(send v merge-certs this)
|
|
v)
|
|
this))
|
|
|
|
(define/override (clone env)
|
|
(make-object begin%
|
|
(map (lambda (x) (send x clone env))
|
|
subs)
|
|
src-stx
|
|
cert-stxes))
|
|
|
|
(define/override (sexpr)
|
|
(with-syntax ([(body ...) (body-sexpr)])
|
|
(syntax/loc src-stx (begin body ...))))
|
|
|
|
(define/override (body-sexpr)
|
|
(map (lambda (e) (get-sexpr e)) subs))))
|
|
|
|
(define top-def%
|
|
(class exp%
|
|
(init-field formname varnames expr tables)
|
|
(super-instantiate ())
|
|
(inherit-field src-stx cert-stxes)
|
|
(define globals #f)
|
|
|
|
(define/override (nonbind-sub-exprs) (list expr))
|
|
(define/override (set-nonbind-sub-exprs s) (set! expr (car s)))
|
|
|
|
(define/override (get-result-arity) 1)
|
|
|
|
(define/override (no-side-effect?) #f)
|
|
(define/override (valueable?) #f)
|
|
|
|
(define/override (clone env) (make-object top-def%
|
|
formname
|
|
varnames
|
|
(send expr clone env)
|
|
tables
|
|
src-stx
|
|
cert-stxes))
|
|
|
|
(define/override (sexpr)
|
|
(with-syntax ([formname formname]
|
|
[(varname ...) varnames]
|
|
[rhs (get-sexpr expr)])
|
|
(syntax/loc src-stx (formname (varname ...) rhs))))
|
|
|
|
(define/public (get-vars) varnames)
|
|
(define/public (get-rhs) expr)
|
|
|
|
;; Like get-vars, but return global% objects, instead.
|
|
;; Useful because the global% object has the global variable bucket info.
|
|
(define/public (get-globals)
|
|
(unless globals
|
|
(set! globals
|
|
(map (lambda (v)
|
|
(make-object global% #f tables #f v))
|
|
varnames)))
|
|
globals)))
|
|
|
|
(define variable-def%
|
|
(class top-def%
|
|
(init varnames expr tables stx)
|
|
|
|
(super-instantiate ((quote-syntax define-values) varnames expr tables stx))))
|
|
|
|
(define syntax-def%
|
|
(class top-def%
|
|
(init varnames expr tables stx)
|
|
(super-instantiate ((quote-syntax define-syntaxes) varnames expr tables stx))))
|
|
|
|
(define for-syntax-def%
|
|
(class top-def%
|
|
(init varnames expr tables stx)
|
|
(super-instantiate ((quote-syntax define-values-for-syntax) varnames expr tables stx))))
|
|
|
|
(define (install-values vars expr)
|
|
(when (= 1 (length vars))
|
|
(send (car vars) set-value expr)))
|
|
|
|
(define constant%
|
|
(class exp%
|
|
(init-field val)
|
|
(super-instantiate ())
|
|
(inherit-field src-stx cert-stxes)
|
|
|
|
(define/public (get-const-val) val)
|
|
|
|
(define/override (get-value) this)
|
|
|
|
(define/override (valueable?) #t)
|
|
|
|
(define/override (can-dup/move?)
|
|
(or (number? val)
|
|
(boolean? val)
|
|
(char? val)
|
|
(symbol? val)
|
|
(void? val)))
|
|
|
|
(define/override (get-result-arity) 1)
|
|
|
|
(define/override (simplify ctx)
|
|
(cond
|
|
[(eq? 'bool (context-need ctx))
|
|
(if (boolean? val)
|
|
this
|
|
(make-object constant% #t src-stx))]
|
|
[(context-need ctx)
|
|
(cond
|
|
[(eq? val (void))
|
|
(make-object void% src-stx)]
|
|
[else this])]
|
|
[else (make-object void% src-stx)]))
|
|
|
|
(define/override (clone env) (make-object constant% val src-stx cert-stxes))
|
|
|
|
(define/override (sexpr)
|
|
(let ([vstx (datum->syntax (quote-syntax here) val src-stx)])
|
|
(cond
|
|
[(or (number? val)
|
|
(string? val)
|
|
(boolean? val)
|
|
(char? val))
|
|
vstx]
|
|
[(syntax? val)
|
|
(with-syntax ([vstx vstx])
|
|
(syntax (quote-syntax vstx)))]
|
|
[else
|
|
(with-syntax ([vstx vstx])
|
|
(syntax (quote vstx)))])))))
|
|
|
|
(define void%
|
|
(class constant%
|
|
(init stx)
|
|
(super-instantiate ((void) stx))
|
|
(inherit-field src-stx cert-stxes)
|
|
|
|
(define/override (sexpr) (quote-syntax (#%plain-app void)))
|
|
|
|
(define/override (simplify ctx)
|
|
(if (eq? 'bool (context-need ctx))
|
|
(make-object constant% #t src-stx)
|
|
this))
|
|
|
|
(define/override (clone env) (make-object void% src-stx cert-stxes))))
|
|
|
|
|
|
(define app%
|
|
(class exp%
|
|
(init-field rator rands tables)
|
|
(super-instantiate ())
|
|
(inherit-field src-stx
|
|
cert-stxes)
|
|
(inherit merge-certs)
|
|
|
|
(define known-single-result? #f)
|
|
|
|
(inherit set-known-value)
|
|
|
|
(define/private (known-single-result v)
|
|
(set! known-single-result? #t)
|
|
(set-known-value v)
|
|
v)
|
|
|
|
|
|
(define/override (nonbind-sub-exprs) (cons rator rands))
|
|
(define/override (set-nonbind-sub-exprs s)
|
|
(set! rator (car s))
|
|
(set! rands (cdr s)))
|
|
|
|
(define/override (no-side-effect?)
|
|
;; Note: get-result-arity assumes #t result => single value
|
|
;;
|
|
;; Some prims are known to be side-effect-free (including no errors)
|
|
;; get-result-arity assumes 1 when this returns #t
|
|
(or known-single-result?
|
|
(and (rator . is-a? . global%)
|
|
(send rator is-kernel?)
|
|
(memq (send rator orig-name) effectless-prims)
|
|
(andmap (lambda (rand) (send rand no-side-effect?))
|
|
rands))))
|
|
|
|
(define/override (valueable?)
|
|
(and (rator . is-a? . global%)
|
|
(send rator is-kernel?)
|
|
(not (memq (send rator orig-name)
|
|
(non-valueable-prims)))
|
|
(super valueable?)))
|
|
|
|
(define/override (get-result-arity)
|
|
(if (or known-single-result? (no-side-effect?))
|
|
1
|
|
'unknown))
|
|
|
|
(define/override (escape)
|
|
(send rator escape)
|
|
(cond
|
|
((bound-identifier=? #'vector-ref (send rator get-stx)) (void))
|
|
((and (bound-identifier=? #'vector-set! (send rator get-stx))
|
|
(not (null? rands)))
|
|
(map (lambda (x) (send x escape)) (cdr rands)))
|
|
(else
|
|
(map (lambda (x) (send x escape)) rands))))
|
|
|
|
(define/override (simplify ctx)
|
|
(super simplify ctx)
|
|
(cond
|
|
;; ((lambda (a ...) ...) v ...) => (let ([a v] ...) ...)
|
|
[(and (is-a? rator lambda%)
|
|
(send rator can-inline?))
|
|
(if (send rator arg-body-exists? (length rands))
|
|
(begin
|
|
(send rator drop-other-uses (length rands))
|
|
(let-values ([(vars body) (send rator arg-vars-and-body (length rands))])
|
|
(for-each (lambda (var rand)
|
|
(install-values (list var) rand))
|
|
vars rands)
|
|
(let ([let-form (make-object let%
|
|
(map list vars)
|
|
rands
|
|
body
|
|
src-stx
|
|
cert-stxes)])
|
|
(send let-form merge-certs this)
|
|
(send let-form merge-certs rator)
|
|
(send let-form simplify ctx))))
|
|
(begin
|
|
(unless (send rator arg-count-ok? (length rands))
|
|
(warning "immediate procedure called with wrong number of arguments"
|
|
this))
|
|
this))]
|
|
|
|
;; constant folding
|
|
[(and (is-a? rator global%)
|
|
(memq (send rator orig-name) foldable-prims)
|
|
(send rator is-kernel?)
|
|
(andmap (lambda (x) (is-a? x constant%)) rands))
|
|
(if (eq? (send rator orig-name) 'void)
|
|
(make-object void% src-stx)
|
|
(let ([vals (map (lambda (x) (send x get-const-val)) rands)]
|
|
[f (dynamic-require 'mzscheme (send rator orig-name))])
|
|
(with-handlers ([exn:fail? (lambda (x)
|
|
(fprintf (current-error-port)
|
|
"constant calculation error: ~a\n"
|
|
(exn-message x))
|
|
this)])
|
|
(known-single-result
|
|
(send (make-object constant% (apply f vals) src-stx)
|
|
simplify ctx)))))]
|
|
|
|
;; (+ x 1) => (add1 x)
|
|
[(and (is-a? rator global%)
|
|
(send rator is-kernel?)
|
|
(eq? (send rator orig-name) '+)
|
|
(= 2 (length rands))
|
|
(or (and (is-a? (car rands) constant%)
|
|
(eq? 1 (send (car rands) get-const-val)))
|
|
(and (is-a? (cadr rands) constant%)
|
|
(eq? 1 (send (cadr rands) get-const-val)))))
|
|
(make-object app%
|
|
(make-object global% (send rator is-trans?) tables #f (quote-syntax add1))
|
|
(list
|
|
(if (and (is-a? (car rands) constant%)
|
|
(eq? 1 (send (car rands) get-const-val)))
|
|
(cadr rands)
|
|
(car rands)))
|
|
tables
|
|
src-stx
|
|
cert-stxes)]
|
|
;; (- x 1) => (sub1 x)
|
|
[(and (is-a? rator global%)
|
|
(send rator is-kernel?)
|
|
(eq? (send rator orig-name) '-)
|
|
(= 2 (length rands))
|
|
(and (is-a? (cadr rands) constant%)
|
|
(eq? 1 (send (cadr rands) get-const-val))))
|
|
(make-object app%
|
|
(make-object global% (send rator is-trans?) tables #f (quote-syntax sub1))
|
|
(list (car rands))
|
|
tables
|
|
src-stx
|
|
cert-stxes)]
|
|
|
|
;; (car x) where x is known to be a list construction
|
|
[(and (is-a? rator global%)
|
|
(send rator is-kernel?)
|
|
(let-values ([(pos len) (case (send rator orig-name)
|
|
[(car) (values 0 1)]
|
|
[(cadr) (values 1 1)]
|
|
[(caddr) (values 2 1)]
|
|
[(cadddr) (values 3 1)]
|
|
[(list-ref) (values (and (= 2 (length rands))
|
|
(let ([v (send (cadr rands) get-value)])
|
|
(and (v . is-a? . constant%)
|
|
(send v get-const-val))))
|
|
2)]
|
|
[else (values #f #f)])])
|
|
(and (number? pos)
|
|
(= len (length rands))
|
|
(and ((car rands) . is-a? . ref%)
|
|
(let ([val (send (car rands) get-value)])
|
|
(and (val . is-a? . app%)
|
|
(send val get-list-ref pos)))))))
|
|
=>
|
|
(lambda (val)
|
|
(send (car rands) drop-uses)
|
|
(known-single-result val))]
|
|
|
|
;; (memv x '(c ...)) in a boolean context => (if (eq[v]? x 'c) ...)
|
|
;; relevant to the output of `case'
|
|
[(and (eq? (context-need ctx) 'bool)
|
|
(is-a? rator global%)
|
|
(send rator is-kernel?)
|
|
(eq? (send rator orig-name) 'memv)
|
|
(= 2 (length rands))
|
|
(is-a? (car rands) ref%)
|
|
(is-a? (cadr rands) constant%)
|
|
(list? (send (cadr rands) get-const-val)))
|
|
(let ([xformed
|
|
(let ([l (send (cadr rands) get-const-val)]
|
|
[l-stx (send (cadr rands) get-stx)]
|
|
[false (make-object constant% #f (datum->syntax #f #f))]
|
|
[true (make-object constant% #t (datum->syntax #f #t))])
|
|
(if (null? l)
|
|
false
|
|
(let loop ([l l])
|
|
(let ([test
|
|
(make-object app%
|
|
(make-object global%
|
|
(send rator is-trans?)
|
|
tables
|
|
#f
|
|
(let ([a (car l)])
|
|
(if (or (symbol? a)
|
|
(and (number? a)
|
|
(exact? a)
|
|
(integer? a)
|
|
;; fixnums:
|
|
(<= (- (expt 2 29))
|
|
a
|
|
(expt 2 29))))
|
|
(quote-syntax eq?)
|
|
(quote-syntax eqv?))))
|
|
(list
|
|
(car rands)
|
|
(make-object constant%
|
|
(car l)
|
|
l-stx))
|
|
tables
|
|
src-stx
|
|
cert-stxes)])
|
|
(cond
|
|
[(null? (cdr l)) test]
|
|
[else (let ([rest (loop (cdr l))])
|
|
;; increment use count:
|
|
(send (car rands) set-known-values)
|
|
(make-object if%
|
|
test
|
|
true
|
|
rest
|
|
src-stx
|
|
cert-stxes))])))))])
|
|
(send xformed merge-certs this)
|
|
(send xformed simplify ctx))]
|
|
|
|
;; (values e) where e has result arity 1
|
|
[(and (is-a? rator global%)
|
|
(send rator is-kernel?)
|
|
(eq? 'values (send rator orig-name))
|
|
(= 1 (length rands))
|
|
(equal? 1 (send (car rands) get-result-arity)))
|
|
(send (car rands) merge-certs this)
|
|
(known-single-result (car rands))]
|
|
|
|
;; Check arity of other calls to primitives
|
|
[(and (is-a? rator global%)
|
|
(send rator is-kernel?))
|
|
(let ([f (dynamic-require 'mzscheme (send rator orig-name))])
|
|
(cond
|
|
[(not (procedure? f))
|
|
(warning "call of non-procedure" this)]
|
|
[(not (procedure-arity-includes? f (length rands)))
|
|
(warning "primitive called with wrong number of arguments" this)]))
|
|
this]
|
|
|
|
;; inlining
|
|
[(and #f ;; disabled!
|
|
(> (fuel) 0)
|
|
(or (is-a? rator ref%) (is-a? rator global%))
|
|
(is-a? (send rator get-value) lambda%)
|
|
(not (send (send rator get-value) get-simplifying-body)))
|
|
(let ([f (send (send rator get-value) clone null)])
|
|
(send rator drop-uses)
|
|
(set! rator f)
|
|
(send f set-known-values)
|
|
;; Now we have ((lambda ...) ...). Go again.
|
|
(fuel (sub1 (fuel)))
|
|
(if (= (fuel) (sub1 max-fuel))
|
|
(begin0
|
|
(simplify ctx)
|
|
(fuel max-fuel))
|
|
(simplify ctx)))]
|
|
|
|
;; Check arity of a call to a known (non-primitive) function
|
|
[(and (or (is-a? rator ref%) (is-a? rator global%))
|
|
(is-a? (send rator get-value) lambda%))
|
|
(let ([f (send rator get-value)])
|
|
(unless (send f arg-count-ok? (length rands))
|
|
(warning "procedure called with wrong number of arguments"
|
|
this))
|
|
this)]
|
|
|
|
[else this]))
|
|
|
|
(define/override (clone env) (make-object app%
|
|
(send rator clone env)
|
|
(map (lambda (rand)
|
|
(send rand clone env))
|
|
rands)
|
|
tables
|
|
src-stx
|
|
cert-stxes))
|
|
|
|
(define/override (sexpr)
|
|
(keep-mzc-property
|
|
(with-syntax ([rator (get-sexpr rator)]
|
|
[(rand ...) (map get-sexpr rands)])
|
|
(syntax/loc src-stx (#%plain-app rator rand ...)))
|
|
src-stx))
|
|
|
|
;; Checks whether the expression is an app of `values'
|
|
;; to a particular set of bindings.
|
|
(define/public (is-values-of? args)
|
|
(and (rator . is-a? . global%)
|
|
(send rator is-kernel?)
|
|
(eq? (send rator orig-name) 'values)
|
|
(= (length rands) (length args))
|
|
(andmap
|
|
(lambda (rand arg)
|
|
(and (rand . is-a? . ref%)
|
|
(eq? arg (send rand get-binding))))
|
|
rands args)))
|
|
|
|
;; If app constructs a list and the nth element can be
|
|
;; safely extracted, then extract it.
|
|
(define/public (get-list-ref n)
|
|
(and (rator . is-a? . global%)
|
|
(send rator is-kernel?)
|
|
(eq? 'list (send rator orig-name))
|
|
((length rands) . > . n)
|
|
(let ([i (list-ref rands n)])
|
|
(if (send i can-dup/move?)
|
|
i
|
|
#f))))))
|
|
|
|
(define lambda%
|
|
(class exp%
|
|
(init-field varss normal?s bodys)
|
|
(super-instantiate ())
|
|
(inherit-field src-stx cert-stxes)
|
|
(define simplifying-body #f)
|
|
|
|
|
|
(inherit drop-uses)
|
|
|
|
|
|
(define/private (multarity-ize l)
|
|
(if (null? (cdr l))
|
|
(car l)
|
|
(cons (car l)
|
|
(multarity-ize (cdr l)))))
|
|
|
|
(define/public (get-simplifying-body) simplifying-body)
|
|
|
|
(define/public (multi?) (or (null? bodys)
|
|
(pair? (cdr bodys))))
|
|
|
|
(define/public (arg-body-exists? n)
|
|
(ormap (lambda (vs n?) (and n? (= n (length vs))))
|
|
varss normal?s))
|
|
(define/public (arg-count-ok? n)
|
|
(ormap (lambda (vs n?) (or (and n? (= n (length vs)))
|
|
(and (not n?) (n . >= . (sub1 (length vs))))))
|
|
varss normal?s))
|
|
(define/public (arg-vars-and-body n)
|
|
(let loop ([varss varss][normal?s normal?s][bodys bodys])
|
|
(if (and (car normal?s)
|
|
(= (length (car varss)) n))
|
|
(values (car varss) (car bodys))
|
|
(loop (cdr varss) (cdr normal?s) (cdr bodys)))))
|
|
|
|
(define/public (drop-other-uses n)
|
|
(let loop ([n n][varss varss][normal?s normal?s][bodys bodys])
|
|
(unless (null? varss)
|
|
(let ([n (if (and (car normal?s)
|
|
(= (length (car varss)) n))
|
|
-1
|
|
(begin
|
|
(send (car bodys) drop-uses)
|
|
n))])
|
|
(loop n (cdr varss) (cdr normal?s) (cdr bodys))))))
|
|
|
|
(define/public (can-inline?)
|
|
(not (syntax-property src-stx 'mzc-cffi)))
|
|
|
|
(define/override (bind-sub-exprs) (apply append varss))
|
|
(define/override (nonbind-sub-exprs) bodys)
|
|
(define/override (set-nonbind-sub-exprs s) (set! bodys s))
|
|
|
|
(define/override (no-side-effect?) #t)
|
|
(define/override (get-result-arity) 1)
|
|
|
|
(define/override (valueable?) #t)
|
|
|
|
(define/override (simplify ctx)
|
|
(if (eq? 'bool (context-need ctx))
|
|
(begin
|
|
(drop-uses)
|
|
(make-object constant% #t src-stx))
|
|
(begin
|
|
(set! simplifying-body #t)
|
|
(begin0
|
|
(super simplify ctx)
|
|
(set! simplifying-body #f)))))
|
|
|
|
(define/override (clone env)
|
|
(let ([varss+bodys
|
|
(let loop ([varss varss][bodys bodys])
|
|
(if (null? varss)
|
|
null
|
|
(let* ([vars (car varss)]
|
|
[new-vars (map (lambda (v) (send v clone-binder env))
|
|
vars)])
|
|
(cons
|
|
(cons new-vars
|
|
(send (car bodys)
|
|
clone (append (map cons vars new-vars)
|
|
env)))
|
|
(loop (cdr varss) (cdr bodys))))))])
|
|
(make-object lambda%
|
|
(map car varss+bodys)
|
|
normal?s
|
|
(map cdr varss+bodys)
|
|
src-stx
|
|
cert-stxes)))
|
|
|
|
(define/override (sexpr)
|
|
(with-syntax ([(vars ...)
|
|
(map (lambda (vars normal?)
|
|
(let ([vs (map get-sexpr vars)])
|
|
(if normal?
|
|
vs
|
|
(multarity-ize vs))))
|
|
varss normal?s)]
|
|
[(body ...)
|
|
(map (lambda (body)
|
|
(get-body-sexpr body))
|
|
bodys)])
|
|
(keep-mzc-property
|
|
(if (multi?)
|
|
(syntax/loc src-stx
|
|
(case-lambda
|
|
[vars . body] ...))
|
|
(with-syntax ([body (car (syntax->list (syntax (body ...))))])
|
|
(syntax/loc src-stx
|
|
(#%plain-lambda vars ... . body))))
|
|
src-stx)))))
|
|
|
|
(define local%
|
|
(class exp%
|
|
(init-field form varss rhss body)
|
|
(super-instantiate ())
|
|
(inherit-field src-stx cert-stxes)
|
|
(inherit merge-certs)
|
|
|
|
(define/public (get-rhss) rhss)
|
|
(define/public (get-varss) varss)
|
|
(define/public (get-body) body)
|
|
|
|
(define/override (bind-sub-exprs) (apply append varss))
|
|
(define/override (nonbind-sub-exprs) (cons body rhss))
|
|
(define/override (set-nonbind-sub-exprs s)
|
|
(set! body (car s))
|
|
(set! rhss (cdr s)))
|
|
|
|
(define/override (get-result-arity) (send body get-result-arity))
|
|
|
|
(define/override (simplify ctx)
|
|
(set! rhss (map (lambda (rhs vars)
|
|
(send rhs simplify
|
|
(make-context 'all
|
|
(append vars (context-indef ctx)))))
|
|
rhss varss))
|
|
(set! body (send body simplify ctx))
|
|
|
|
;; Drop unused constant bindings
|
|
(set!-values (varss rhss)
|
|
(let loop ([varss varss][rhss rhss])
|
|
(cond
|
|
[(null? varss) (values null null)]
|
|
[else (let-values ([(rest-vss rest-rhss)
|
|
(loop (cdr varss) (cdr rhss))])
|
|
(if (and (andmap (lambda (var) (not (send var is-used?)))
|
|
(car varss))
|
|
(equal? (send (car rhss) get-result-arity)
|
|
(length (car varss)))
|
|
(send (car rhss) no-side-effect?))
|
|
(begin
|
|
(send (car rhss) drop-uses)
|
|
(values rest-vss rest-rhss))
|
|
(values (cons (car varss) rest-vss)
|
|
(cons (car rhss) rest-rhss))))])))
|
|
|
|
(cond
|
|
;; (let-values ([(x) e]) (if e ... ...))
|
|
;; is a pattern created by `or'
|
|
[(and (is-a? body if%)
|
|
(let ([t (send body get-if-test)])
|
|
(and (is-a? t binding%)
|
|
(= 1 (length varss))
|
|
(= 1 (length (car varss)))
|
|
(eq? (caar varss) t)
|
|
(= 1 (send t get-use-count)))))
|
|
(make-object if%
|
|
(car rhss)
|
|
(send body get-if-then)
|
|
(send body get-if-else)
|
|
src-stx
|
|
cert-stxes)]
|
|
[(null? varss)
|
|
(send body merge-certs this)
|
|
(send body simplify ctx)]
|
|
;; (let-values [(x) y] ...) whether y is inited, and
|
|
;; neither x nor y is mutated => replace x by y
|
|
[(and (andmap (lambda (vars) (= 1 (length vars))) varss)
|
|
(send (caar varss) valueable?)
|
|
(andmap (lambda (rhs) (and (or (rhs . is-a? . ref%)
|
|
(rhs . is-a? . global%))
|
|
(send rhs valueable?)))
|
|
rhss))
|
|
(send body merge-certs this)
|
|
(send body substitute
|
|
(map (lambda (vars rhs) (cons (car vars)
|
|
(if (rhs . is-a? . ref%)
|
|
(send rhs get-binding)
|
|
rhs)))
|
|
varss rhss))]
|
|
|
|
[else
|
|
this]))
|
|
|
|
(define/override (clone env)
|
|
(let* ([new-varss
|
|
(map (lambda (vs)
|
|
(map (lambda (v) (send v clone-binder env))
|
|
vs))
|
|
varss)]
|
|
[body-env (append
|
|
(map cons
|
|
(apply append varss)
|
|
(apply append new-varss))
|
|
env)]
|
|
[letrec? (eq? form 'letrec-values)])
|
|
(make-object (if letrec? letrec% let%)
|
|
new-varss
|
|
(map (lambda (rhs)
|
|
(send rhs clone (if letrec? body-env env)))
|
|
rhss)
|
|
(send body clone body-env)
|
|
src-stx
|
|
cert-stxes)))
|
|
|
|
(define/override (get-value) (send body get-value))
|
|
|
|
(define/override (sexpr)
|
|
(with-syntax ([form form]
|
|
[(vars ...)
|
|
(map (lambda (vars)
|
|
(map get-sexpr vars))
|
|
varss)]
|
|
[(rhs ...)
|
|
(map get-sexpr rhss)]
|
|
[(body ...) (get-body-sexpr body)])
|
|
(syntax/loc src-stx
|
|
(form ([vars rhs] ...)
|
|
body ...))))))
|
|
|
|
(define let%
|
|
(class local%
|
|
(init -varss -rhss -body -stx -cert-stxes)
|
|
(inherit get-varss get-rhss get-body)
|
|
|
|
(define/override (set-known-values)
|
|
(for-each (lambda (vars rhs) (install-values vars rhs))
|
|
(get-varss) (get-rhss))
|
|
(super set-known-values))
|
|
|
|
(super-instantiate ((quote-syntax let-values) -varss -rhss -body -stx -cert-stxes))))
|
|
|
|
(define letrec%
|
|
(class local%
|
|
(init -varss -rhss -body -stx -cert-stxes)
|
|
(inherit get-varss get-rhss)
|
|
|
|
(define/override (set-known-values)
|
|
(let loop ([varss (get-varss)][rhss (get-rhss)])
|
|
(unless (null? varss)
|
|
(when (send (car rhss) valueable?)
|
|
(for-each (lambda (var) (send var set-inited))
|
|
(car varss))
|
|
(loop (cdr varss) (cdr rhss)))))
|
|
(for-each install-values (get-varss) (get-rhss))
|
|
(super set-known-values))
|
|
|
|
(super-instantiate ((quote-syntax letrec-values) -varss -rhss -body -stx -cert-stxes))))
|
|
|
|
(define set!%
|
|
(class exp%
|
|
(init-field var val)
|
|
(super-instantiate ())
|
|
(inherit-field src-stx cert-stxes)
|
|
|
|
(define/override (nonbind-sub-exprs) (list var val))
|
|
(define/override (set-nonbind-sub-exprs s)
|
|
(set! var (car s))
|
|
(set! val (cadr s)))
|
|
|
|
(define/override (no-side-effect?) #f)
|
|
(define/override (valueable?) #f)
|
|
(define/override (get-result-arity) 1)
|
|
|
|
(define/override (set-known-values)
|
|
(send var set-mutated)
|
|
(send var set-known-values) ; increments use
|
|
(send val set-known-values))
|
|
|
|
(define/override (set-mutability)
|
|
(send var set-mutated)
|
|
(super set-mutability))
|
|
|
|
(define/override (clone env)
|
|
(make-object set!%
|
|
(send var clone env)
|
|
(send val clone env)
|
|
src-stx
|
|
cert-stxes))
|
|
|
|
(define/override (sexpr)
|
|
(with-syntax ([var (get-sexpr var)]
|
|
[val (get-sexpr val)])
|
|
(syntax/loc src-stx
|
|
(set! var val))))))
|
|
|
|
(define if%
|
|
(class exp%
|
|
(init-field test then else)
|
|
(super-instantiate ())
|
|
(inherit-field src-stx cert-stxes)
|
|
|
|
(define/public (get-if-test) test)
|
|
(define/public (get-if-then) then)
|
|
(define/public (get-if-else) else)
|
|
|
|
(define/override (nonbind-sub-exprs) (list test then else))
|
|
(define/override (set-nonbind-sub-exprs s)
|
|
(set! test (car s))
|
|
(set! then (cadr s))
|
|
(set! else (caddr s)))
|
|
|
|
(define/override (get-result-arity)
|
|
(let ([t (send then get-result-arity)]
|
|
[e (send else get-result-arity)])
|
|
(if (equal? t e)
|
|
t
|
|
'unknown)))
|
|
|
|
(define/override (simplify ctx)
|
|
(set! test (send test simplify (need-bool ctx)))
|
|
(set! then (send then simplify ctx))
|
|
(set! else (send else simplify ctx))
|
|
|
|
;; (if xvar xvar y) when need bool
|
|
;; => (if xvar #t y)
|
|
(when (and (eq? 'bool (context-need ctx))
|
|
(is-a? test binding%)
|
|
(eq? test then))
|
|
(send then drop-uses)
|
|
(set! then (make-object constant% #t src-stx)))
|
|
(when (and (eq? 'bool (context-need ctx))
|
|
(eq? test else)
|
|
(is-a? test binding%))
|
|
(send else drop-uses)
|
|
(set! else (make-object constant% #f src-stx)))
|
|
|
|
|
|
(cond
|
|
;; Constant switch
|
|
[(is-a? test constant%)
|
|
(if (eq? (send test get-const-val) #f)
|
|
(begin
|
|
(send test drop-uses)
|
|
(send then drop-uses)
|
|
else)
|
|
(begin
|
|
(send test drop-uses)
|
|
(send else drop-uses)
|
|
then))]
|
|
|
|
;; (if (if x y #f) a (void))
|
|
;; => (if x (if y a (void)) (void))
|
|
[(and (is-a? test if%)
|
|
(is-a? else void%)
|
|
(let ([c (send test get-if-else)])
|
|
(and (is-a? c constant%)
|
|
(eq? #f (send c get-const-val)))))
|
|
(send
|
|
(make-object if%
|
|
(send test get-if-test)
|
|
(make-object if%
|
|
(send test get-if-then)
|
|
then
|
|
(make-object void% src-stx)
|
|
src-stx
|
|
cert-stxes)
|
|
(make-object void% src-stx)
|
|
src-stx
|
|
cert-stxes)
|
|
simplify ctx)]
|
|
|
|
[else this]))
|
|
|
|
(define/override (clone env)
|
|
(make-object if%
|
|
(send test clone env)
|
|
(send then clone env)
|
|
(send else clone env)
|
|
src-stx
|
|
cert-stxes))
|
|
|
|
(define/override (sexpr)
|
|
(with-syntax ([test (get-sexpr test)]
|
|
[then (get-sexpr then)])
|
|
(if (else . is-a? . void%)
|
|
(syntax/loc src-stx
|
|
(if test then))
|
|
(with-syntax ([else (get-sexpr else)])
|
|
(syntax/loc src-stx
|
|
(if test then else))))))))
|
|
|
|
(define begin0%
|
|
(class exp%
|
|
(init-field first rest)
|
|
(super-instantiate ())
|
|
(inherit-field src-stx cert-stxes)
|
|
|
|
(define/override (nonbind-sub-exprs) (list first rest))
|
|
(define/override (set-nonbind-sub-exprs s)
|
|
(set! first (car s))
|
|
(set! rest (cadr s)))
|
|
|
|
(define/override (get-result-arity) (send first get-result-arity))
|
|
|
|
(define/override (simplify ctx)
|
|
(set! first (send first simplify ctx))
|
|
(set! rest (send rest simplify (need-none ctx)))
|
|
(if (send rest no-side-effect?)
|
|
(begin
|
|
(send rest drop-uses)
|
|
(send first merge-certs this)
|
|
first)
|
|
this))
|
|
|
|
(define/override (clone env)
|
|
(make-object begin0%
|
|
(send first clone env)
|
|
(send rest clone env)
|
|
src-stx
|
|
cert-stxes))
|
|
|
|
(define/override (sexpr)
|
|
(with-syntax ([first (get-sexpr first)]
|
|
[(rest ...) (get-body-sexpr rest)])
|
|
(syntax/loc src-stx
|
|
(begin0 first rest ...))))))
|
|
|
|
(define wcm%
|
|
(class exp%
|
|
(init-field key val body)
|
|
(super-instantiate ())
|
|
(inherit-field src-stx cert-stxes)
|
|
|
|
(define/override (nonbind-sub-exprs) (list key val body))
|
|
(define/override (set-nonbind-sub-exprs s)
|
|
(set! key (car s))
|
|
(set! val (cadr s))
|
|
(set! body (caddr s)))
|
|
|
|
(define/override (get-result-arity) (send body get-result-arity))
|
|
|
|
(define/override (clone env)
|
|
(make-object wcm%
|
|
(send key clone env)
|
|
(send val clone env)
|
|
(send body clone env)
|
|
src-stx
|
|
cert-stxes))
|
|
|
|
(define/override (sexpr)
|
|
(with-syntax ([key (get-sexpr key)]
|
|
[val (get-sexpr val)]
|
|
[body (get-sexpr body)])
|
|
(syntax/loc src-stx
|
|
(with-continuation-mark key val body))))))
|
|
|
|
(define module%
|
|
(class exp%
|
|
(init-field body et-body name init-req req-prov tables src-module-begin-stx)
|
|
(super-instantiate ())
|
|
(inherit-field src-stx)
|
|
|
|
(define/override (reset-varflags)
|
|
(for-each (lambda (e) (send e reset-varflags)) body)
|
|
(for-each (lambda (e) (send e reset-varflags)) et-body))
|
|
(define/override (set-known-values)
|
|
;; Assumes varflags are reset
|
|
(for-each (lambda (e) (send e set-known-values)) (nonbind-sub-exprs)))
|
|
|
|
(define/override (drop-uses)
|
|
;; Assumes varflags are reset
|
|
(for-each (lambda (e) (send e drop-uses)) (nonbind-sub-exprs)))
|
|
|
|
(define/override (no-side-effect?) #f)
|
|
(define/override (valueable?) #f)
|
|
|
|
(define/override (get-result-arity) 'unknown)
|
|
|
|
(define/override (sub-exprs) (append (append et-body body)))
|
|
(define/override (bind-sub-exprs) null)
|
|
(define/override (nonbind-sub-exprs) (sub-exprs))
|
|
(define/override (set-nonbind-sub-exprs l)
|
|
(let-values ([(etb b)
|
|
(let loop ([l l][etb et-body][accum null])
|
|
(cond
|
|
[(null? etb)
|
|
(values (reverse accum) l)]
|
|
[else (loop (cdr l) (cdr etb) (cons (car l)
|
|
accum))]))])
|
|
(set! body body)
|
|
(set! et-body etb)))
|
|
|
|
;; expose known bindings by converting a sequence of top-level
|
|
;; expressions into a letrec:
|
|
;; (define-values (a ...) body) ...
|
|
;; => (define-values (a ... ...)
|
|
;; (letrec-values ([(a ...) body] ...) (values a ... ...)))
|
|
(define/override (reorganize)
|
|
(let ([-body (map (lambda (x) (send x reorganize)) body)]
|
|
[-et-body (map (lambda (x) (send x reorganize)) et-body)])
|
|
(let loop ([l -body][defs null])
|
|
(cond
|
|
[(and (pair? l)
|
|
((car l) . is-a? . variable-def%)
|
|
(not (ormap (lambda (v) (send v is-mutated?))
|
|
(send (car l) get-globals)))
|
|
(send (send (car l) get-rhs) valueable?))
|
|
(for-each (lambda (g) (send g set-inited))
|
|
(send (car l) get-globals))
|
|
(loop (cdr l)
|
|
(cons (car l) defs))]
|
|
[else
|
|
(if (null? defs)
|
|
(void) ; no reorganization
|
|
(let* ([defs (reverse defs)]
|
|
[varss
|
|
(map (lambda (def) (send def get-vars)) defs)]
|
|
[rhss
|
|
(map (lambda (def) (send def get-rhs)) defs)]
|
|
[lex-varss (map (lambda (vars)
|
|
(map (lambda (var)
|
|
(make-object binding%
|
|
#t
|
|
(datum->syntax
|
|
#f
|
|
(syntax-e var)
|
|
var)))
|
|
vars))
|
|
varss)]
|
|
[vars (apply append varss)]
|
|
[lex-vars (apply append lex-varss)]
|
|
[env (map cons vars lex-vars)])
|
|
(set! -body
|
|
(cons
|
|
(make-object variable-def%
|
|
vars
|
|
(make-object letrec%
|
|
lex-varss
|
|
(map (lambda (rhs)
|
|
(send rhs global->local env))
|
|
rhss)
|
|
(make-object app%
|
|
(make-object global%
|
|
#f
|
|
tables
|
|
#f
|
|
(quote-syntax values))
|
|
(map (lambda (var lex-var)
|
|
(make-object ref% lex-var var))
|
|
vars
|
|
lex-vars)
|
|
tables
|
|
(send (car defs) get-stx))
|
|
(send (car defs) get-stx)
|
|
(send (car defs) get-cert-stxes))
|
|
tables
|
|
(send (car defs) get-stx))
|
|
l))))])
|
|
(set! body -body)
|
|
(set! et-body -et-body)))
|
|
this)
|
|
|
|
(define/override (deorganize)
|
|
;; Check for
|
|
;; (define-values (a ... ...)
|
|
;; (letrec-values ([(a ...) body] ...) (values a ... ...)))
|
|
;; => (define-values (a ...) body) ...
|
|
(when (and (pair? body)
|
|
(let ([first (car body)])
|
|
(and (first . is-a? . variable-def%)
|
|
(let ([rhs (send first get-rhs)])
|
|
(and (rhs . is-a? . letrec%)
|
|
(let ([lbody (send rhs get-body)]
|
|
[lvarss (send rhs get-varss)])
|
|
(and (lbody . is-a? . app%)
|
|
(send lbody is-values-of?
|
|
(apply append lvarss)))))))))
|
|
(let ([vars (send (car body) get-vars)]
|
|
[bindingss (send (send (car body) get-rhs) get-varss)]
|
|
[bodys (send (send (car body) get-rhs) get-rhss)])
|
|
;; split vars into varss:
|
|
(let ([varss (let loop ([bindingss bindingss][vars vars])
|
|
(if (null? bindingss)
|
|
null
|
|
(let loop2 ([bindings (car bindingss)][vars vars][accum null])
|
|
(if (null? bindings)
|
|
(cons (reverse accum)
|
|
(loop (cdr bindingss) vars))
|
|
(loop2 (cdr bindings) (cdr vars) (cons (car vars) accum))))))]
|
|
[bindings (apply append bindingss)])
|
|
(let ([env (map cons bindings
|
|
(map (lambda (var)
|
|
(make-object global% #f tables #f var))
|
|
vars))])
|
|
(set! body
|
|
(append
|
|
(map (lambda (vars body)
|
|
(make-object variable-def%
|
|
vars
|
|
(send body substitute env)
|
|
tables
|
|
src-stx))
|
|
varss bodys)
|
|
(cdr body)))))))
|
|
(super deorganize))
|
|
|
|
(define/override (sexpr)
|
|
(with-syntax ([name name]
|
|
[init-req init-req]
|
|
[(body ...) (map get-sexpr body)]
|
|
[(et-body ...) (map get-sexpr et-body)]
|
|
[(req-prov ...) (map get-sexpr req-prov)])
|
|
(with-syntax ([body #'(#%plain-module-begin
|
|
req-prov ...
|
|
body ...
|
|
et-body ...)])
|
|
(syntax/loc src-stx
|
|
(module name init-req body)))))
|
|
(define/override (body-sexpr)
|
|
(list (sexpr)))))
|
|
|
|
;; requires and provides should really be ignored:
|
|
(define require/provide%
|
|
(class exp%
|
|
|
|
(define/override (valueable?) #f)
|
|
(define/override (no-side-effect?) #f)
|
|
(super-instantiate ())))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Warning reporting
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (print-warning msg exp)
|
|
(let ([stx (send exp get-stx)])
|
|
(when (syntax-source stx)
|
|
(fprintf (current-output-port) "~a:" (syntax-source stx))
|
|
(cond
|
|
[(syntax-column stx)
|
|
(fprintf (current-output-port) "~a:~a:"
|
|
(syntax-line stx)
|
|
(syntax-column stx))]
|
|
[(syntax-position stx)
|
|
(fprintf (current-output-port) ":~a:"
|
|
(syntax-position stx))])
|
|
(fprintf (current-output-port) " "))
|
|
(fprintf (current-output-port)
|
|
"~a: ~.s\n"
|
|
msg
|
|
(syntax->datum (send exp sexpr)))))
|
|
|
|
(define (warning msg exp)
|
|
; (print-warning msg exp)
|
|
(void))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Parser
|
|
;; converts a syntax object to an exp%
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (parse-args env args)
|
|
(let-values ([(norm? ids)
|
|
(syntax-case args ()
|
|
[id
|
|
(identifier? (syntax id))
|
|
(values #f (list (syntax id)))]
|
|
[(id ...)
|
|
(values #t (syntax->list args))]
|
|
[_else (values #f
|
|
(let loop ([args args])
|
|
(syntax-case args ()
|
|
[id (identifier? args) (list args)]
|
|
[(id . rest)
|
|
(cons (syntax id) (loop (syntax rest)))])))])])
|
|
(let ([bindings (map (lambda (id) (make-object binding% #t id)) ids)])
|
|
(values
|
|
(append (map cons ids bindings) env)
|
|
bindings
|
|
norm?))))
|
|
|
|
(define (parse-let % rec? stx env loop)
|
|
(syntax-case stx ()
|
|
[(_ ([vars rhs] ...) . body)
|
|
(let* ([varses (syntax->list (syntax (vars ...)))]
|
|
[rhses (syntax->list (syntax (rhs ...)))]
|
|
[var-objses (map (lambda (vars)
|
|
(map (lambda (var)
|
|
(make-object binding% (not rec?) var))
|
|
(syntax->list vars)))
|
|
varses)]
|
|
[body-env (append
|
|
(apply
|
|
append
|
|
(map (lambda (var-objs vars)
|
|
(map cons
|
|
(syntax->list vars)
|
|
var-objs))
|
|
var-objses
|
|
varses))
|
|
env)])
|
|
(make-object %
|
|
var-objses
|
|
(map (lambda (rhs)
|
|
(loop rhs (if rec? body-env env)))
|
|
rhses)
|
|
(loop (syntax (begin . body)) body-env)
|
|
stx
|
|
(list stx)))]))
|
|
|
|
(define (stx-bound-assq ssym l)
|
|
(ormap (lambda (p)
|
|
(and (bound-identifier=? ssym (car p))
|
|
p))
|
|
l))
|
|
|
|
(define (lookup-clone binding var env)
|
|
(let ([s (assq binding env)])
|
|
(if s
|
|
(let ([b (cdr s)])
|
|
(if (b . is-a? . binding%)
|
|
(make-object ref% b (send var get-stx) (send var get-cert-stxes))
|
|
;; it's a global%:
|
|
b))
|
|
var)))
|
|
|
|
(define dummy 'dummy) ; for #%variable-reference
|
|
|
|
(define (make-parse top?)
|
|
(lambda (stx env trans? in-module? tables)
|
|
(kernel-syntax-case (syntax-disarm stx code-insp) trans?
|
|
[id
|
|
(identifier? stx)
|
|
(let ([a (stx-bound-assq stx env)])
|
|
(if a
|
|
(make-object ref% (cdr a) stx)
|
|
(make-object global% trans? tables #f stx)))]
|
|
|
|
[(#%top . id)
|
|
(make-object global% trans? tables #t (syntax id))]
|
|
|
|
[(#%variable-reference . val)
|
|
(make-object constant% (#%variable-reference dummy) stx)]
|
|
|
|
[(define-values names rhs)
|
|
(make-object variable-def%
|
|
(syntax->list (syntax names))
|
|
(parse (syntax rhs) env #f in-module? tables)
|
|
tables
|
|
stx)]
|
|
|
|
[(define-syntaxes names rhs)
|
|
(make-object syntax-def%
|
|
(syntax->list (syntax names))
|
|
(parse (syntax rhs) env #t in-module? tables)
|
|
tables
|
|
stx)]
|
|
|
|
[(define-values-for-syntax names rhs)
|
|
(make-object for-syntax-def%
|
|
(syntax->list (syntax names))
|
|
(parse (syntax rhs) env #t in-module? tables)
|
|
tables
|
|
stx)]
|
|
|
|
[(begin . exprs)
|
|
(make-object begin%
|
|
(map (lambda (e) ((if top? parse-top parse) e env trans? in-module? tables))
|
|
(syntax->list (syntax exprs)))
|
|
stx)]
|
|
|
|
[(begin0 expr . exprs)
|
|
(make-object begin0%
|
|
(parse (syntax expr) env trans? in-module? tables)
|
|
(parse (syntax (begin . exprs)) env trans? in-module? tables)
|
|
stx)]
|
|
|
|
[(quote expr)
|
|
(make-object constant% (syntax->datum (syntax expr)) stx)]
|
|
|
|
[(quote-syntax expr)
|
|
(make-object constant% (syntax expr) stx)]
|
|
|
|
[(#%plain-lambda args . body)
|
|
(let-values ([(env args norm?) (parse-args env (syntax args))])
|
|
(make-object lambda%
|
|
(list args)
|
|
(list norm?)
|
|
(list (parse (syntax (begin . body)) env trans? in-module? tables))
|
|
stx))]
|
|
|
|
[(case-lambda [args . body] ...)
|
|
(let-values ([(envs argses norm?s)
|
|
(let ([es+as+n?s
|
|
(map
|
|
(lambda (args)
|
|
(let-values ([(env args norm?) (parse-args env args)])
|
|
(cons env (cons args norm?))))
|
|
(syntax->list (syntax (args ...))))])
|
|
(values
|
|
(map car es+as+n?s)
|
|
(map cadr es+as+n?s)
|
|
(map cddr es+as+n?s)))])
|
|
(make-object lambda%
|
|
argses
|
|
norm?s
|
|
(map (lambda (env body)
|
|
(with-syntax ([body body])
|
|
(parse (syntax (begin . body)) env trans? in-module? tables)))
|
|
envs
|
|
(syntax->list (syntax (body ...))))
|
|
stx))]
|
|
|
|
[(let-values . _)
|
|
(parse-let let% #f stx env
|
|
(lambda (b env) (parse b env trans? in-module? tables)))]
|
|
[(letrec-values . _)
|
|
(parse-let letrec% #t stx env
|
|
(lambda (b env) (parse b env trans? in-module? tables)))]
|
|
|
|
[(set! var rhs)
|
|
(make-object set!%
|
|
(parse (syntax var) env trans? in-module? tables)
|
|
(parse (syntax rhs) env trans? in-module? tables)
|
|
stx)]
|
|
|
|
[(if test then else)
|
|
(make-object if%
|
|
(parse (syntax test) env trans? in-module? tables)
|
|
(parse (syntax then) env trans? in-module? tables)
|
|
(parse (syntax else) env trans? in-module? tables)
|
|
stx)]
|
|
|
|
[(with-continuation-mark k v body)
|
|
(make-object wcm%
|
|
(parse (syntax k) env trans? in-module? tables)
|
|
(parse (syntax v) env trans? in-module? tables)
|
|
(parse (syntax body) env trans? in-module? tables)
|
|
stx)]
|
|
|
|
[(#%plain-app)
|
|
(make-object constant% null stx)]
|
|
|
|
[(#%plain-app func . args)
|
|
(make-object app%
|
|
(parse (syntax func) env trans? in-module? tables)
|
|
(map (lambda (v) (parse v env trans? in-module? tables)) (syntax->list (syntax args)))
|
|
tables
|
|
stx)]
|
|
|
|
[(module name init-require (#%plain-module-begin . body))
|
|
(let* ([body (map (lambda (x)
|
|
(parse x env #f #t tables))
|
|
(syntax->list (syntax body)))]
|
|
[et-body
|
|
(filter (lambda (x) (or (x . is-a? . syntax-def%)
|
|
(x . is-a? . for-syntax-def%)))
|
|
body)]
|
|
[rt-body
|
|
(filter (lambda (x) (not (or (x . is-a? . syntax-def%)
|
|
(x . is-a? . for-syntax-def%)
|
|
(x . is-a? . require/provide%))))
|
|
body)]
|
|
[req-prov
|
|
(filter (lambda (x) (x . is-a? . require/provide%))
|
|
body)])
|
|
(make-object module%
|
|
rt-body
|
|
et-body
|
|
(syntax name)
|
|
(syntax init-require)
|
|
req-prov
|
|
tables
|
|
(syntax-case stx ()
|
|
[(m n ir mb) #'mb])
|
|
stx))]
|
|
|
|
[(#%require . i) (make-object require/provide% stx)]
|
|
[(#%provide i ...) (make-object require/provide% stx)]
|
|
|
|
[(#%expression e)
|
|
(parse (syntax e) env trans? in-module? tables)]
|
|
|
|
[else
|
|
(error 'parse "unknown expression: ~a" (syntax->datum stx))])))
|
|
|
|
(define parse (make-parse #f))
|
|
(define parse-top (make-parse #t))
|
|
|
|
(define (create-tables)
|
|
(make-tables (make-hasheq) (make-hasheq)))
|
|
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Optimizer
|
|
;; the driver function
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define optimize
|
|
(opt-lambda (e [for-mzc? #f])
|
|
(let ([p (parse-top e null #f #f (create-tables))])
|
|
(send p set-mutability)
|
|
(send p reorganize)
|
|
(send p set-known-values)
|
|
(let ([p (send p simplify (make-context 'all null))])
|
|
(let ([v (get-sexpr (if for-mzc?
|
|
p
|
|
(send p deorganize)))])
|
|
v)))))
|
|
|
|
(provide optimize))
|