0197902309
Macros and other tools that need syntax privilege used `(current-code-inspector)' at the module top-level to try to capture the right code inspector at load time. It's more consistent to instead use the enclosing module's declaration-time inspector, and `var-ref->mod-decl-insp' provides that. The new function works only on references to anonymous variables, which limits access to the inspector. The real function name is longer, of course.
1809 lines
62 KiB
Racket
1809 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 (variable-reference->module-declaration-inspector
|
|
(#%variable-reference)))
|
|
|
|
(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 (syntax-disarm stx code-insp) ()
|
|
[(_ ([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))
|