1408 lines
51 KiB
Racket
1408 lines
51 KiB
Racket
;; lexical analysis phase of the compiler
|
|
;; (c) 1996-1997 Sebastian Good
|
|
;; (c) 1997-2011 PLT Scheme Inc
|
|
|
|
;; For closures, variable sets, such as the free variables,
|
|
;; are computed.
|
|
;; Constants are transformed into varrefs to top-level
|
|
;; constant definitions. A list of these is kept, and
|
|
;; code is generated to create the constants and prefixed
|
|
;; onto the output code. See also "const.rkt".
|
|
;; Global and primitive varrefs are collected into a list,
|
|
;; so they can all be looked up once.
|
|
;; Letrec expressions that don't just bind procedures are
|
|
;; changed to let+set!. Letrecs that remain after this
|
|
;; phase are well-behaved procedure binders.
|
|
;; Some simple arity checks are performed, and return-arity
|
|
;; information is kept for closures. Ultimately, the return-
|
|
;; arity information is used to compile away some return
|
|
;; value count checks.
|
|
;; Constants are propagated.
|
|
;; Constant let-bound variables are eliminated (unless they
|
|
;; are improperly used in the let body).
|
|
;; Procedure applications are inlined.
|
|
;; Syntax constants created, so quote-syntax turns into a
|
|
;; varref
|
|
|
|
;;; Annotatitons: ----------------------------------------------
|
|
;; binding - `binding' structure: UPDATED occasionally:
|
|
;; rec? field for letrec bindings
|
|
;; known-but-used? field for ill-used bindings
|
|
;; quote - zodiac:varref (global var containing a constructed
|
|
;; constant) or an immediate constant
|
|
;; app - `app' structure: UPDATED tail? flag
|
|
;; lambda - `procedure-code' structure
|
|
;; with-continuation-mark - might set annotation to #f, which
|
|
;; indicates that begin0-like handling is not needed
|
|
;; quote-syntax - zodiac:varref (global var containing a constructed
|
|
;; constant)
|
|
;;; ------------------------------------------------------------
|
|
|
|
(module analyze mzscheme
|
|
(require mzlib/unit
|
|
mzlib/list
|
|
mzlib/etc)
|
|
|
|
(require syntax/zodiac-sig)
|
|
|
|
(require "sig.rkt"
|
|
"../sig.rkt")
|
|
|
|
(provide analyze@)
|
|
(define-unit analyze@
|
|
(import (prefix compiler:option: compiler:option^)
|
|
compiler:library^
|
|
compiler:cstructs^
|
|
(prefix zodiac: zodiac^)
|
|
compiler:zlayer^
|
|
compiler:prephase^
|
|
compiler:anorm^
|
|
compiler:known^
|
|
compiler:const^
|
|
compiler:rep^
|
|
compiler:vm2c^
|
|
compiler:driver^)
|
|
(export compiler:analyze^)
|
|
|
|
(define-struct mod-glob (cname ;; a made-up name that encodes module + var
|
|
modname
|
|
varname
|
|
position
|
|
exp-time?
|
|
exp-def?
|
|
in-module?))
|
|
|
|
(define-struct modref-info (globals
|
|
et-globals
|
|
modidx-const)) ; #f => local to module body
|
|
|
|
(define compiler:global-symbols (make-hash-table))
|
|
(define compiler:add-global-varref!
|
|
(case-lambda
|
|
[(varref) (compiler:add-global-varref!
|
|
(zodiac:top-level-varref-module varref)
|
|
(zodiac:varref-var varref)
|
|
varref
|
|
(zodiac:top-level-varref-exptime? varref)
|
|
(zodiac:top-level-varref-expdef? varref)
|
|
(zodiac:top-level-varref-position varref))]
|
|
[(modname varname ast et? ed? position)
|
|
(let* ([et? (and et?
|
|
;; Just use run-time for #%kernel, since it's the same, and
|
|
;; the compiler generates references to #%kernel names
|
|
(not (kernel-modname? modname)))]
|
|
[info (hash-table-get compiler:global-symbols modname
|
|
(lambda ()
|
|
(let ([p (make-modref-info
|
|
#f #f
|
|
(if (kernel-modname? modname)
|
|
(begin
|
|
(compiler:get-symbol-const! #f '#%kernel)
|
|
'#%kernel)
|
|
(if (module-path-index? modname)
|
|
(let-values ([(name base) (module-path-index-split modname)])
|
|
(if name
|
|
(compiler:construct-const-code!
|
|
(zodiac:make-zread
|
|
(datum->syntax-object
|
|
#f
|
|
modname
|
|
(zodiac:zodiac-stx ast)))
|
|
#t)
|
|
#f))
|
|
modname)))])
|
|
(hash-table-put! compiler:global-symbols modname p)
|
|
p)))]
|
|
[t (or ((if et? modref-info-et-globals modref-info-globals) info)
|
|
(let ([t (make-hash-table)])
|
|
((if et? set-modref-info-et-globals! set-modref-info-globals!) info t)
|
|
t))])
|
|
(hash-table-get t varname
|
|
(lambda ()
|
|
;; vm->c function also generates a symbol constant:
|
|
(let ([n (make-mod-glob (vm->c:generate-modglob-name modname varname)
|
|
modname varname position et? ed?
|
|
(and ast (varref:has-attribute?
|
|
ast
|
|
varref:in-module)))])
|
|
(unless ast
|
|
(compiler:internal-error
|
|
#f
|
|
"unexpected global name generation for ~a (~a;~a)"
|
|
varname modname et?))
|
|
(hash-table-put! t varname n)
|
|
n))))]))
|
|
|
|
(define (ensure-top-level varref)
|
|
(if (zodiac:top-level-varref-module varref)
|
|
(begin
|
|
(compiler:warning
|
|
varref
|
|
(format "definition of name `~a' mapped by --prim or `require'; compiled uses of the name will ignore this definition"
|
|
(zodiac:varref-var varref)))
|
|
(let ([new (zodiac:make-top-level-varref
|
|
(datum->syntax-object
|
|
#f ; no context
|
|
(syntax-e (zodiac:zodiac-stx varref))
|
|
(zodiac:zodiac-stx varref))
|
|
(make-empty-box)
|
|
(zodiac:varref-var varref)
|
|
#f
|
|
(box #f) ; slot - fresh because the variable can't be referenced from anywhere
|
|
#f #f #f)])
|
|
(set-annotation! new (varref:empty-attributes))
|
|
new))
|
|
varref))
|
|
|
|
(define (compiler:get-module-path-constant modname)
|
|
(modref-info-modidx-const (hash-table-get compiler:global-symbols modname void)))
|
|
|
|
(define (compiler:get-global-symbols) compiler:global-symbols)
|
|
|
|
(define compiler:primitive-refs empty-set)
|
|
(define compiler:add-primitive-varref!
|
|
(lambda (varref)
|
|
(set! compiler:primitive-refs
|
|
(set-union-singleton compiler:primitive-refs
|
|
(zodiac:varref-var varref)))))
|
|
(define (compiler:get-primitive-refs) compiler:primitive-refs)
|
|
|
|
(define compiler:max-arity-allowed 11739) ; meant to be a sane limit
|
|
|
|
(define compiler:define-list null)
|
|
(define compiler:per-load-define-list null)
|
|
(define compiler:local-define-list null)
|
|
(define compiler:local-per-load-define-list null)
|
|
|
|
(define (compiler:get-define-list) compiler:define-list)
|
|
(define (compiler:get-per-load-define-list) compiler:per-load-define-list)
|
|
|
|
(define (compiler:init-define-lists!)
|
|
(set! compiler:define-list null)
|
|
(set! compiler:per-load-define-list null)
|
|
(set! compiler:global-symbols (make-hash-table))
|
|
(set! compiler:primitive-refs empty-set))
|
|
|
|
(define (compiler:add-local-define-list! def)
|
|
(set! compiler:local-define-list
|
|
(cons def compiler:local-define-list)))
|
|
(define (compiler:add-local-per-load-define-list! def)
|
|
(set! compiler:local-per-load-define-list
|
|
(cons def compiler:local-per-load-define-list)))
|
|
|
|
(define (prepare-local-lists)
|
|
(set! compiler:local-define-list null)
|
|
(set! compiler:local-per-load-define-list null))
|
|
|
|
(define (move-over-local-lists)
|
|
(set! compiler:define-list
|
|
(append compiler:define-list
|
|
(reverse compiler:local-define-list)))
|
|
(set! compiler:per-load-define-list
|
|
(append compiler:per-load-define-list
|
|
(reverse compiler:local-per-load-define-list)))
|
|
|
|
(set! compiler:local-define-list null)
|
|
(set! compiler:local-per-load-define-list null))
|
|
|
|
;; Temporary structure used in building up case-lambda info
|
|
(define-struct case-info
|
|
(body case-code global-vars used-vars captured-vars max-arity return-multi))
|
|
|
|
(define (list->zodiac:quote l ast)
|
|
(zodiac:make-quote-form
|
|
(zodiac:zodiac-stx ast)
|
|
(make-empty-box)
|
|
(zodiac:structurize-syntax l ast)))
|
|
|
|
;; Turns a virtual set-values! into an expression using normal
|
|
;; set!s. The result must be a-normalized, have the right
|
|
;; binding annotations, and the right known-value links.
|
|
(define letrec-multiple-set!->single-set!
|
|
(lambda (orig-zbindings vars val ast)
|
|
(cond
|
|
[(null? vars)
|
|
;; zero value set! -- weirdos
|
|
(zodiac:make-let-values-form
|
|
(zodiac:zodiac-stx ast)
|
|
(make-empty-box)
|
|
(list null)
|
|
(list val)
|
|
(zodiac:make-special-constant 'void))]
|
|
|
|
[else
|
|
;; single or multiple value set!
|
|
(let* ([names (map (lambda (_) (gensym)) vars)]
|
|
[zbindings (map (lambda (name orig-zbinding)
|
|
(let ([zb (zodiac:make-lexical-binding
|
|
(zodiac:zodiac-stx ast)
|
|
(make-empty-box)
|
|
name
|
|
name)])
|
|
(let ([old-binding (get-annotation orig-zbinding)]
|
|
[new-binding (make-unknown-letbound-binding #f)])
|
|
(set-annotation! zb new-binding)
|
|
;; Copy known info from the old binding to the new one.
|
|
(when (binding-known? old-binding)
|
|
(set-binding-known?! new-binding #t)
|
|
(set-binding-val! new-binding (binding-val old-binding))))
|
|
zb))
|
|
names orig-zbindings)])
|
|
;; The original bindings will be set!ed, so they must now be marked as
|
|
;; a special kind of "mutable" for boxing.
|
|
(map (lambda (zb) (set-binding-letrec-set?! (get-annotation zb) #t)) orig-zbindings)
|
|
;; If it's one binding, make sure known? is set:
|
|
(when (= 1 (length zbindings))
|
|
(let ([binding (get-annotation (car zbindings))])
|
|
(unless (binding-known? binding)
|
|
(set-binding-known?! binding #t)
|
|
(set-binding-val! binding val))))
|
|
;; Make the new expession
|
|
(zodiac:make-let-values-form
|
|
(zodiac:zodiac-stx ast)
|
|
(make-empty-box)
|
|
(list zbindings)
|
|
(list val)
|
|
(let ([set!s (let loop ([zbindings zbindings] [vars vars])
|
|
(if (null? zbindings)
|
|
null
|
|
(cons
|
|
(zodiac:make-set!-form
|
|
(zodiac:zodiac-stx ast)
|
|
(make-empty-box)
|
|
(car vars)
|
|
(zodiac:binding->lexical-varref
|
|
(car zbindings)))
|
|
(loop (cdr zbindings) (cdr vars)))))])
|
|
(if (= 1 (length set!s))
|
|
(car set!s)
|
|
(zodiac:make-begin-form
|
|
(zodiac:zodiac-stx ast)
|
|
(zodiac:parsed-back ast)
|
|
set!s)))))])))
|
|
|
|
;; turns a 'bad' letrec into let+set!, also returning a procedure
|
|
;; to set! the body to the correct form, to avoid re-analyzing it
|
|
;; the 'body' is set to (void)
|
|
(define letrec->let+set!
|
|
(lambda (ast)
|
|
(let* ([body
|
|
(zodiac:make-begin-form
|
|
(zodiac:zodiac-stx ast)
|
|
(make-empty-box)
|
|
(let linearize-set! ([varses (zodiac:letrec-values-form-vars ast)]
|
|
[vals (zodiac:letrec-values-form-vals ast)])
|
|
(if (null? varses)
|
|
(list (zodiac:letrec-values-form-body ast))
|
|
(let* ([vars (car varses)]
|
|
[val (car vals)])
|
|
(cons
|
|
;; must turn set!-values into set! form
|
|
(letrec-multiple-set!->single-set!
|
|
vars
|
|
(map zodiac:binding->lexical-varref vars)
|
|
val
|
|
ast)
|
|
(linearize-set! (cdr varses) (cdr vals)))))))]
|
|
[let-form
|
|
;; In this phase, we must only construct let-vales forms with one clause
|
|
(let loop ([varses (zodiac:letrec-values-form-vars ast)])
|
|
(if (null? varses)
|
|
body
|
|
(let ([vars (car varses)])
|
|
(zodiac:make-let-values-form
|
|
(zodiac:zodiac-stx ast)
|
|
(make-empty-box) ; (zodiac:parsed-back ast)
|
|
(list vars)
|
|
(list
|
|
(if (= 1 (length vars))
|
|
(zodiac:make-special-constant 'undefined)
|
|
(compiler:make-const-constructor
|
|
ast
|
|
'values
|
|
(map (lambda (_) (zodiac:make-special-constant
|
|
'undefined))
|
|
vars))))
|
|
(loop (cdr varses))))))])
|
|
let-form)))
|
|
|
|
;; Tells us which constants we can replace directly with their text
|
|
(define (can-propagate-constant? ast)
|
|
(or (zodiac:quote-form? ast)
|
|
;; (zodiac:lexical-varref? ast) to do this, we must put renamed vars in
|
|
;; environments as their old name...
|
|
(and (zodiac:top-level-varref? ast)
|
|
(or (varref:has-attribute? ast varref:primitive)
|
|
(varref:has-attribute? ast varref:static)))))
|
|
|
|
;; Which expressions can we drop entirely (e.g., RHS of a let when the value is known)?
|
|
(define (can-drop-expression? ast)
|
|
(or (zodiac:quote-form? ast)
|
|
(zodiac:bound-varref? ast)
|
|
(and (zodiac:top-level-varref? ast)
|
|
(varref:has-attribute? ast varref:static))))
|
|
|
|
(define (or-multi a-multi b-multi)
|
|
(case a-multi
|
|
[(#f) b-multi]
|
|
[(possible) (or b-multi 'possible)]
|
|
[(#t) #t]))
|
|
|
|
;;----------------------------------------------------------------------
|
|
;; INLINING
|
|
|
|
;; Only inline fairly simple things; also check for variables needed
|
|
;; that are not in the destination scope
|
|
(define (expression-inline-cost body env init-size)
|
|
(let loop ([body body][env env][size init-size][k (lambda (x) x)])
|
|
(if (>= size (compiler:option:max-inline-size))
|
|
size
|
|
(cond
|
|
[(zodiac:quote-form? body) (k size)]
|
|
[(zodiac:bound-varref? body)
|
|
(if (memq (zodiac:bound-varref-binding body) env)
|
|
(k size)
|
|
;; Out of scope - no inling
|
|
(* 2 (compiler:option:max-inline-size)))]
|
|
[(zodiac:varref? body) (k size)]
|
|
[(zodiac:app? body) (loop (zodiac:app-fun body)
|
|
env
|
|
(+ size (length (zodiac:app-args body)) 1)
|
|
(lambda (size)
|
|
(let kloop ([l (zodiac:app-args body)][size size])
|
|
(if (null? l)
|
|
(k size)
|
|
(loop (car l) env size
|
|
(lambda (size)
|
|
(kloop (cdr l) size)))))))]
|
|
[(zodiac:if-form? body) (loop (zodiac:if-form-test body) env (+ size 3)
|
|
(lambda (size)
|
|
(loop (zodiac:if-form-else body) env size
|
|
(lambda (size)
|
|
(loop (zodiac:if-form-then body) env size k)))))]
|
|
[(zodiac:set!-form? body) (loop (zodiac:set!-form-val body) env (+ size 3) k)]
|
|
[(zodiac:let-values-form? body) (loop (car (zodiac:let-values-form-vals body))
|
|
env
|
|
(+ size 3)
|
|
(lambda (size)
|
|
(loop (zodiac:let-values-form-body body)
|
|
(append (car (zodiac:let-values-form-vars body)) env)
|
|
size k)))]
|
|
[(zodiac:begin-form? body) (let bloop ([size size][exprs (zodiac:begin-form-bodies body)])
|
|
(if (null? exprs)
|
|
(k size)
|
|
(loop (car exprs)
|
|
env
|
|
(+ size 1)
|
|
(lambda (size)
|
|
(bloop size (cdr exprs))))))]
|
|
[(zodiac:global-lookup? body) (k size)]
|
|
[(zodiac:safe-vector-ref? body) (k size)]
|
|
[(zodiac:global-assign? body) (loop (zodiac:global-assign-expr body) env (+ size 1) k)]
|
|
[else (* 2 (compiler:option:max-inline-size))]))))
|
|
|
|
;; We copy inlined bodies to generate unique structure values
|
|
;; for every distinct program point. But we don't copy
|
|
;; quote forms, so the same run-time value will be used for
|
|
;; the quote form in all its instantiations. We also don't
|
|
;; know whether it's been analyzed in this phase, yet.
|
|
(define (copy-inlined-binding ast)
|
|
(let ([b (zodiac:make-lexical-binding
|
|
(zodiac:zodiac-stx ast)
|
|
(make-empty-box)
|
|
(gensym (string-append (symbol->string (zodiac:binding-var ast)) "i"))
|
|
(zodiac:binding-orig-name ast))]
|
|
[a (get-annotation ast)])
|
|
(set-annotation! b (copy-binding a))
|
|
b))
|
|
(define (copy-inlined-body ast binding-map)
|
|
(cond
|
|
[(or (and (zodiac:lexical-varref? ast)
|
|
zodiac:make-lexical-varref))
|
|
=>
|
|
(lambda (f)
|
|
(let* ([binding (let* ([binding (zodiac:bound-varref-binding ast)]
|
|
[remapped (assq binding binding-map)])
|
|
(if remapped
|
|
(cdr remapped)
|
|
binding))]
|
|
[new-ast (f (zodiac:zodiac-stx ast)
|
|
(make-empty-box)
|
|
(zodiac:binding-var binding)
|
|
binding)])
|
|
;; Copy attribute set:
|
|
(set-annotation! new-ast (get-annotation ast))
|
|
new-ast))]
|
|
[(zodiac:top-level-varref? ast)
|
|
(let ([new-ast (zodiac:make-top-level-varref
|
|
(zodiac:zodiac-stx ast)
|
|
(make-empty-box)
|
|
(zodiac:varref-var ast)
|
|
(zodiac:top-level-varref-module ast)
|
|
(zodiac:top-level-varref-slot ast)
|
|
(zodiac:top-level-varref-exptime? ast)
|
|
(zodiac:top-level-varref-expdef? ast)
|
|
(zodiac:top-level-varref-position ast))])
|
|
;; Copy attribute set:
|
|
(set-annotation! new-ast (get-annotation ast))
|
|
new-ast)]
|
|
[(zodiac:quote-form? ast) ast]
|
|
[(zodiac:app? ast)
|
|
(let ([new-ast (zodiac:make-app
|
|
(zodiac:zodiac-stx ast)
|
|
(make-empty-box)
|
|
(copy-inlined-body (zodiac:app-fun ast) binding-map)
|
|
(map (lambda (x) (copy-inlined-body x binding-map)) (zodiac:app-args ast)))]
|
|
[appinfo (get-annotation ast)])
|
|
(set-annotation! new-ast
|
|
(make-app #f
|
|
(app-prim? appinfo)
|
|
(app-prim-name appinfo)))
|
|
new-ast)]
|
|
[(zodiac:if-form? ast)
|
|
(zodiac:make-if-form
|
|
(zodiac:zodiac-stx ast)
|
|
(make-empty-box)
|
|
(copy-inlined-body (zodiac:if-form-test ast) binding-map)
|
|
(copy-inlined-body (zodiac:if-form-then ast) binding-map)
|
|
(copy-inlined-body (zodiac:if-form-else ast) binding-map))]
|
|
[(zodiac:set!-form? ast)
|
|
(zodiac:make-set!-form
|
|
(zodiac:zodiac-stx ast)
|
|
(make-empty-box)
|
|
(copy-inlined-body (zodiac:set!-form-var ast) binding-map)
|
|
(copy-inlined-body (zodiac:set!-form-val ast) binding-map))]
|
|
[(zodiac:let-values-form? ast)
|
|
(let* ([vars (car (zodiac:let-values-form-vars ast))]
|
|
[val (car (zodiac:let-values-form-vals ast))]
|
|
[new-val (copy-inlined-body val binding-map)]
|
|
[new-vars (map copy-inlined-binding vars)]
|
|
[new-binding-map (append (map cons vars new-vars) binding-map)]
|
|
[new-body (copy-inlined-body (zodiac:let-values-form-body ast) new-binding-map)])
|
|
|
|
;; Update known-value information; if it was known to be = to a varref or binding,
|
|
;; we may have replaced it with a new varref or binding.
|
|
(when (= 1 (length new-vars))
|
|
(let ([binding (get-annotation (car new-vars))])
|
|
(when (binding-known? binding)
|
|
(let ([known (binding-val binding)])
|
|
(when (or (zodiac:bound-varref? known)
|
|
(zodiac:binding? known))
|
|
(let* ([known-zbinding (if (zodiac:binding? known)
|
|
known
|
|
(zodiac:bound-varref-binding known))]
|
|
[found (assq known-zbinding binding-map)])
|
|
(when found
|
|
;; Yep - that varref/binding was replaced
|
|
(set-binding-val! binding (cdr found)))))))))
|
|
|
|
(zodiac:make-let-values-form
|
|
(zodiac:zodiac-stx ast)
|
|
(make-empty-box)
|
|
(list new-vars)
|
|
(list new-val)
|
|
new-body))]
|
|
[(zodiac:begin-form? ast)
|
|
(zodiac:make-begin-form
|
|
(zodiac:zodiac-stx ast)
|
|
(make-empty-box)
|
|
(map (lambda (x) (copy-inlined-body x binding-map))
|
|
(zodiac:begin-form-bodies ast)))]
|
|
[(zodiac:global-lookup? ast)
|
|
(zodiac:make-global-lookup
|
|
(zodiac:zodiac-stx ast)
|
|
(make-empty-box)
|
|
(copy-inlined-body (zodiac:global-lookup-vec ast) binding-map)
|
|
(zodiac:global-lookup-pos ast))]
|
|
[(zodiac:safe-vector-ref? ast)
|
|
(zodiac:make-safe-vector-ref
|
|
(zodiac:zodiac-stx ast)
|
|
(make-empty-box)
|
|
(copy-inlined-body (zodiac:safe-vector-ref-vec ast) binding-map)
|
|
(zodiac:safe-vector-ref-pos ast))]
|
|
[(zodiac:global-assign? ast)
|
|
(zodiac:make-global-assign
|
|
(zodiac:zodiac-stx ast)
|
|
(make-empty-box)
|
|
(copy-inlined-body (zodiac:global-assign-vec ast) binding-map)
|
|
(zodiac:global-assign-pos ast)
|
|
(copy-inlined-body (zodiac:global-assign-expr ast) binding-map))]
|
|
[else (compiler:internal-error
|
|
ast
|
|
(format "copy-inlined-body: can't copy ~a"
|
|
ast))]))
|
|
|
|
(define (check-for-inlining ast env inlined tail? inline dont-inline)
|
|
(if (>= inlined (compiler:option:max-inline-size))
|
|
(dont-inline "depth")
|
|
(let ([c (zodiac:app-fun ast)])
|
|
(if (not (zodiac:bound-varref? c))
|
|
(dont-inline `(format "not a varref: ~a" ,c))
|
|
(let* ([val (extract-varref-known-val c)])
|
|
(if (not (zodiac:case-lambda-form? val))
|
|
(dont-inline `(format "not a lambda: ~a" ,val))
|
|
;; We're going to inline the body if the arg count matches
|
|
(let loop ([argses (zodiac:case-lambda-form-args val)]
|
|
[bodies (zodiac:case-lambda-form-bodies val)])
|
|
(cond
|
|
[(null? argses) (dont-inline "no arg match")]
|
|
[(and (zodiac:list-arglist? (car argses))
|
|
(= (length (zodiac:app-args ast))
|
|
(length (zodiac:arglist-vars (car argses)))))
|
|
;; Inline if lexical scope of destination includes the lexical
|
|
;; scope of the source, and simple enough
|
|
(let* ([body (car bodies)]
|
|
[orig-vars (zodiac:arglist-vars (car argses))]
|
|
[new-size (expression-inline-cost
|
|
body (append orig-vars env)
|
|
(if tail?
|
|
(max 5 inlined)
|
|
inlined))])
|
|
(if (< new-size (compiler:option:max-inline-size))
|
|
(let* ([vars (map copy-inlined-binding orig-vars)]
|
|
[vals (zodiac:app-args ast)]
|
|
[new-body (copy-inlined-body body (map cons orig-vars vars))]
|
|
[v (let loop ([vars vars][vals vals])
|
|
(if (null? vars)
|
|
new-body
|
|
(zodiac:make-let-values-form
|
|
(zodiac:zodiac-stx ast)
|
|
(make-empty-box)
|
|
(list (list (car vars)))
|
|
(list (car vals))
|
|
(loop (cdr vars) (cdr vals)))))])
|
|
;; Unless mutable, the new bindings have known
|
|
;; value expressions
|
|
(for-each
|
|
(lambda (var val)
|
|
(let ([binding (get-annotation var)])
|
|
(unless (binding-mutable? binding)
|
|
(set-binding-known?! binding #t)
|
|
(set-binding-val! binding val))))
|
|
vars (extract-ast-known-value vals))
|
|
(inline v new-size))
|
|
(dont-inline "too complex")))]
|
|
[else (loop (cdr argses) (cdr bodies))]))))))))
|
|
|
|
|
|
;;----------------------------------------------------------------------
|
|
;; analyze-expression takes 4 arguments
|
|
;; 1) an AST to transform
|
|
;; 2) a set of bound variables (the lexical environment)
|
|
;; 3) tail?
|
|
;;
|
|
;; it returns 6 values
|
|
;; 1) a destructively altered AST
|
|
;; 2) a set of variables occurring free in that expression [free-vars]
|
|
;; 3) a set of variables which are bound by lets in that expression [local-vars]
|
|
;; 4) global variables and mutable `constants' used in the expression [global-vars]
|
|
;; 5) local variables (including given bound set) that are used directly or captured by nested closures [used-vars]
|
|
;; 6) free and local variables that are captured by nested closures [captured-vars]
|
|
;; 7) a list of `code' structures
|
|
;; 8) maximum arity to a call made in this expression
|
|
;; 9) returns multiple values?: #t, 'possible, or #f
|
|
;;
|
|
(define analyze-expression!
|
|
(lambda (ast just-bound-vars env tail?)
|
|
(let ([local-vars just-bound-vars]
|
|
[locals-used empty-set]
|
|
[captured-vars empty-set]
|
|
[free-vars empty-set]
|
|
[global-vars empty-set]
|
|
[codes null]
|
|
[max-arity 1])
|
|
(letrec
|
|
([add-local-var! (lambda (var)
|
|
(set! local-vars
|
|
(set-union-singleton local-vars var)))]
|
|
[remove-local-var! (lambda (var)
|
|
(set! local-vars
|
|
(set-minus local-vars (make-singleton-set var))))]
|
|
[add-free-var! (lambda (var)
|
|
(set! free-vars
|
|
(set-union-singleton free-vars var)))]
|
|
[add-used-var! (lambda (var)
|
|
(set! locals-used
|
|
(set-union-singleton locals-used var)))]
|
|
[add-global-var! (lambda (var)
|
|
(set! global-vars
|
|
(set-union-singleton global-vars var)))]
|
|
[add-child-code! (lambda (c)
|
|
(set! codes (cons c codes)))]
|
|
[register-arity! (lambda (n) (set! max-arity (max n max-arity)))]
|
|
[register-code-vars!
|
|
(lambda (code can-lift?)
|
|
;; all variables which are free in nested closures are
|
|
;; free in this closure (since we need them in the
|
|
;; environment) except those that are already in the
|
|
;; environment: just-bound-vars (typically the arguments)
|
|
;; and local-vars. New captured variables are also
|
|
;; added: free variables and captured variables in
|
|
;; nested closures. (Captured variables are always
|
|
;; a subset of free + used.)
|
|
(set! free-vars
|
|
(set-union (set-minus (code-free-vars code)
|
|
local-vars)
|
|
free-vars))
|
|
(set! locals-used
|
|
(set-union (set-intersect local-vars
|
|
(code-free-vars code))
|
|
locals-used))
|
|
(set! captured-vars
|
|
(set-union (set-minus (code-free-vars code)
|
|
local-vars)
|
|
captured-vars))
|
|
(set! global-vars
|
|
(set-union (code-global-vars code) global-vars)))]
|
|
[analyze-code-body!
|
|
(lambda (ast locals env tail? code)
|
|
(add-child-code! code)
|
|
(let-values ([(body free-vars
|
|
local-vars
|
|
global-vars
|
|
used-vars
|
|
captured-vars
|
|
children
|
|
L-max-arity
|
|
multi)
|
|
(analyze-expression! ast
|
|
locals
|
|
(append (set->list locals) env)
|
|
tail?)])
|
|
|
|
(set-code-free-vars! code (set-union free-vars
|
|
(code-free-vars code)))
|
|
(set-code-local-vars! code (set-union local-vars
|
|
(code-local-vars code)))
|
|
(set-code-global-vars! code (set-union global-vars
|
|
(code-global-vars code)))
|
|
(set-code-used-vars! code (set-union used-vars
|
|
(code-used-vars code)))
|
|
(set-code-captured-vars! code (set-union captured-vars
|
|
(code-captured-vars code)))
|
|
(set-code-children! code children)
|
|
(for-each (lambda (c) (set-code-parent! c code)) children)
|
|
(set-closure-code-max-arity! code (max L-max-arity
|
|
(closure-code-max-arity code)))
|
|
(set-closure-code-return-multi! code multi)
|
|
|
|
body))]
|
|
[analyze-varref!
|
|
(lambda (ast env tail? need-varref?)
|
|
(cond
|
|
|
|
;;-----------------------------------------------------------------
|
|
;; VARIABLE REFERENCES (A-VALUES)
|
|
;;
|
|
;; We need to catalogue which variables are used in this
|
|
;; expression. if a lexical varref is not in the
|
|
;; environment, it is free
|
|
;;
|
|
;; if the bound structure indicates this variable is known at
|
|
;; compile time, replace the varref with the const-ref
|
|
;; since we can propagate varrefs, we need to make sure we
|
|
;; capture the right name in closures.
|
|
;;
|
|
[(zodiac:bound-varref? ast)
|
|
|
|
;; check to see if it's known. If so, just return the known value.
|
|
|
|
(let* ([zbinding (zodiac:bound-varref-binding ast)]
|
|
[binding (compiler:bound-varref->binding ast)]
|
|
[known-value (extract-varref-known-val ast)])
|
|
|
|
;; Extra checking for debugging:
|
|
;; (unless (memq zbinding env) (compiler:internal-error ast "unbound variable"))
|
|
|
|
(cond
|
|
[(and (compiler:option:propagate-constants)
|
|
known-value
|
|
(can-propagate-constant? known-value)
|
|
(not need-varref?))
|
|
|
|
;; Propogate a mzc-determined constant!
|
|
;; This could be a quote-form that was installed
|
|
;; as a known value before it was
|
|
;; analyzed. If so, extract the constructed
|
|
;; constant from the backbox.
|
|
;; In any case, check for adding PLS to the closure.
|
|
(let ([c (if (zodiac:quote-form? known-value)
|
|
|
|
(let ([a (get-annotation known-value)])
|
|
(if (zodiac:varref? a)
|
|
a
|
|
(analyze-quote! known-value #f)))
|
|
|
|
known-value)])
|
|
|
|
(when (and (zodiac:varref? c)
|
|
(varref:has-attribute? c varref:per-load-static))
|
|
(add-global-var! const:the-per-load-statics-table))
|
|
|
|
c)]
|
|
|
|
[else
|
|
;; otherwise we don't know the value -- therefore just
|
|
;; do the normal free-variable analysis
|
|
|
|
(if (not (set-memq? (zodiac:bound-varref-binding ast)
|
|
local-vars))
|
|
|
|
(begin
|
|
(add-free-var! (zodiac:bound-varref-binding ast))
|
|
(varref:add-attribute! ast varref:env)
|
|
|
|
;; If this variable has an anchor, include it in the list of free vars
|
|
(let ([a (binding-anchor (get-annotation (zodiac:bound-varref-binding ast)))])
|
|
(when a
|
|
(add-free-var! a)))
|
|
|
|
ast)
|
|
|
|
(begin
|
|
(add-used-var! (zodiac:bound-varref-binding ast))
|
|
|
|
;; If this variable has an anchor, include it in the list of used vars
|
|
(let ([a (binding-anchor (get-annotation (zodiac:bound-varref-binding ast)))])
|
|
(when a
|
|
(add-used-var! a)))
|
|
|
|
ast))]))]
|
|
|
|
[(zodiac:top-level-varref? ast)
|
|
|
|
;; A varref may need to generate module-index values.
|
|
(prepare-local-lists)
|
|
|
|
(cond
|
|
[(varref:has-attribute? ast varref:primitive)
|
|
(compiler:add-primitive-varref! ast)]
|
|
[(varref:has-attribute? ast varref:per-load-static)
|
|
(add-global-var! const:the-per-load-statics-table)]
|
|
[(varref:has-attribute? ast varref:static)
|
|
(void)]
|
|
[else
|
|
(add-global-var! (compiler:add-global-varref! ast))])
|
|
(compiler:add-global-varref! ast)
|
|
|
|
;; Was a module-index value generated?
|
|
(move-over-local-lists)
|
|
|
|
ast]
|
|
|
|
[else (compiler:internal-error
|
|
ast
|
|
"analyze: expected a variable; got ~a" ast)]))]
|
|
|
|
;;-----------------------------------------------------------------
|
|
;; CONSTANTS (A-VALUES)
|
|
;; literal constants -- send them off to the constant
|
|
;; constructors!! This produces code in b-normal form
|
|
;; and adds defines to the local-define-list. This list
|
|
;; must be reversed since the dependencies are backwards
|
|
;; ahh, the excitement of multiple values...
|
|
[analyze-quote!
|
|
(lambda (ast known-immutable?)
|
|
(prepare-local-lists)
|
|
(let ([ret (compiler:construct-const-code!
|
|
(zodiac:quote-form-expr ast)
|
|
(or known-immutable?
|
|
(eq? 'immutable (get-annotation ast))))])
|
|
;; Put a pointer to the constructed constant in the quote-form's backbox
|
|
(set-annotation! ast ret)
|
|
|
|
(move-over-local-lists)
|
|
|
|
;; If this `constant' is mutable, register the per-load
|
|
;; statics pointer as a `global'
|
|
(when (and (zodiac:top-level-varref? ret)
|
|
(varref:has-attribute? ret varref:per-load-static))
|
|
(add-global-var! const:the-per-load-statics-table))
|
|
|
|
ret))]
|
|
|
|
[analyze!-ast
|
|
;; Like analyze, but drop the multi-return info in the result
|
|
(lambda (ast env inlined)
|
|
(let-values ([(ast multi) (analyze! ast env inlined #f #f)])
|
|
ast))]
|
|
|
|
[analyze!-sv
|
|
;; Like analyze, but make sure the expression is not definitely
|
|
;; multi-valued
|
|
(lambda (ast env inlined)
|
|
(let-values ([(ast multi) (analyze! ast env inlined #f #f)])
|
|
(when (eq? multi #t)
|
|
((if (compiler:option:stupid) compiler:warning compiler:error)
|
|
ast
|
|
"returning zero or multiple values to a context expecting 1 value"))
|
|
ast))]
|
|
|
|
[analyze!
|
|
;; Returns (values ast multi)
|
|
;; where multi = #f, #t, 'possible
|
|
(lambda (ast env inlined tail? wcm-tail?)
|
|
(when (compiler:option:debug)
|
|
(zodiac:print-start! (debug:get-port) ast)
|
|
(newline (debug:get-port)))
|
|
|
|
(cond
|
|
|
|
;;-----------------------------------------------------------------
|
|
;; CONSTANTS (A-VALUES)
|
|
[(zodiac:quote-form? ast)
|
|
(values (analyze-quote! ast #f) #f)]
|
|
|
|
;;-----------------------------------------------------------------
|
|
;; VARIABLE REFERENCES (A-VALUES)
|
|
;;
|
|
;; We need to catalogue which variables are used in this
|
|
;; expression. if a lexical varref is not in the
|
|
;; environment, it is free
|
|
;;
|
|
;; if the bound structure indicates this variable is known at
|
|
;; compile time, replace the varref with the const-ref
|
|
;; since we can propagate varrefs, we need to make sure we
|
|
;; capture the right name in closures.
|
|
;;
|
|
[(zodiac:bound-varref? ast)
|
|
(values (analyze-varref! ast env tail? #f) #f)]
|
|
|
|
[(zodiac:top-level-varref? ast)
|
|
(values (analyze-varref! ast env tail? #f) #f)]
|
|
|
|
;;--------------------------------------------------------------------
|
|
;; LAMBDA EXPRESSIONS
|
|
;; with lambda, we need to make a recursive call. We
|
|
;; extend the lexical environment with everything that's
|
|
;; been declared locally so far. From the analyze-expression
|
|
;; we have information about what free variables they use
|
|
;;
|
|
[(zodiac:case-lambda-form? ast)
|
|
(let* ([code
|
|
(make-procedure-code empty-set empty-set empty-set empty-set empty-set
|
|
'unknown-proc-parent #f null
|
|
#f #f #f #f 0 #f (get-annotation ast) ; ann. = name
|
|
'unknown-case-infos #f
|
|
'unknown-liftable
|
|
(and (syntax-property (zodiac:zodiac-stx ast) 'method-arity-error)
|
|
;; Make sure that no case accepts 0 arguments:
|
|
(andmap
|
|
(lambda (a) (not (null? (zodiac:arglist-vars a))))
|
|
(zodiac:case-lambda-form-args ast))))]
|
|
[case-infos
|
|
(map
|
|
(lambda (args body)
|
|
(let ([args (zodiac:arglist-vars args)])
|
|
|
|
(let-values
|
|
([(lambda-body free-lambda-vars
|
|
local-lambda-vars
|
|
global-lambda-vars
|
|
used-lambda-vars
|
|
captured-lambda-vars
|
|
children-codes
|
|
L-max-arity
|
|
multi)
|
|
|
|
(let ([just-bound (improper-list->set args)])
|
|
(analyze-expression! body
|
|
just-bound
|
|
(append (set->list just-bound) env)
|
|
#t))])
|
|
|
|
(let ([case-code (make-case-code
|
|
free-lambda-vars
|
|
local-lambda-vars
|
|
global-lambda-vars
|
|
used-lambda-vars
|
|
captured-lambda-vars
|
|
code #f children-codes
|
|
#f)])
|
|
(for-each (lambda (c) (set-code-case-parent! c case-code))
|
|
children-codes)
|
|
(make-case-info lambda-body case-code
|
|
global-lambda-vars
|
|
used-lambda-vars
|
|
captured-lambda-vars
|
|
L-max-arity
|
|
multi)))))
|
|
(zodiac:case-lambda-form-args ast)
|
|
(zodiac:case-lambda-form-bodies ast))]
|
|
[case-codes (map case-info-case-code case-infos)]
|
|
[all-children (apply append (map code-children case-codes))])
|
|
(set-procedure-code-case-codes! code case-codes)
|
|
(set-code-children! code all-children)
|
|
(for-each (lambda (c) (set-code-parent! c code)) all-children)
|
|
(add-child-code! code)
|
|
(let loop ([l case-infos])
|
|
(if (null? l)
|
|
(begin
|
|
;; set the body
|
|
(zodiac:set-case-lambda-form-bodies! ast (map case-info-body case-infos))
|
|
|
|
;; now annotate this lambda form with the code
|
|
(set-annotation! ast code)
|
|
|
|
;; Propogate free, used, and captured vars:
|
|
(register-code-vars! code #t)
|
|
|
|
;; finally return it
|
|
(values ast #f))
|
|
|
|
(begin
|
|
(set-code-free-vars!
|
|
code
|
|
(set-union (code-free-vars
|
|
(case-info-case-code (car l)))
|
|
(code-free-vars code)))
|
|
(set-code-local-vars!
|
|
code
|
|
(set-union (code-local-vars
|
|
(case-info-case-code (car l)))
|
|
(code-local-vars code)))
|
|
(set-code-global-vars!
|
|
code
|
|
(set-union (case-info-global-vars (car l))
|
|
(code-global-vars code)))
|
|
(set-code-used-vars!
|
|
code
|
|
(set-union (case-info-used-vars (car l))
|
|
(code-used-vars code)))
|
|
(set-code-captured-vars!
|
|
code
|
|
(set-union (case-info-captured-vars (car l))
|
|
(code-captured-vars code)))
|
|
(set-closure-code-max-arity!
|
|
code
|
|
(max (closure-code-max-arity code)
|
|
(case-info-max-arity (car l))))
|
|
(set-closure-code-return-multi!
|
|
code
|
|
(or-multi (closure-code-return-multi code)
|
|
(case-info-return-multi (car l))))
|
|
(loop (cdr l))))))]
|
|
|
|
;;--------------------------------------------------------------
|
|
;; LET EXPRESSIONS
|
|
;; keep track of the bindings introduced so that each
|
|
;; expression can keep track of all the bindings it needs
|
|
;; this flattens environments
|
|
;; Several values may be bound at once.
|
|
;;
|
|
;; in let, variables are assumed to be
|
|
;; immutable and known; we store this information
|
|
;; in the binding structure in the compiler:bound structure..
|
|
;;
|
|
;; (let ([x (set! y A)]) M) ->
|
|
;; (begin (set! y A) (let ([x (void)]) M))
|
|
;;
|
|
;; if the variable bound is constant, the let is discarded,
|
|
;; and the value is naturally propagated.
|
|
;;
|
|
[(zodiac:let-values-form? ast)
|
|
(let*-values ([(val val-multi)
|
|
(analyze! (car (zodiac:let-values-form-vals ast)) env inlined #f #f)]
|
|
[(vars) (car (zodiac:let-values-form-vars ast))]
|
|
[(convert-set!-val)
|
|
(lambda ()
|
|
(zodiac:set-let-values-form-vals!
|
|
ast
|
|
(cons (zodiac:make-special-constant
|
|
'void)
|
|
(cdr (zodiac:let-values-form-vals ast))))
|
|
(zodiac:make-begin-form
|
|
(zodiac:zodiac-stx ast)
|
|
(make-empty-box)
|
|
(list val ast)))])
|
|
|
|
(if (= 1 (length (car (zodiac:let-values-form-vars ast))))
|
|
|
|
;; this is a one-value binding let
|
|
(let* ([var (car vars)]
|
|
[binding (get-annotation var)])
|
|
|
|
(when (eq? val-multi #t)
|
|
((if (compiler:option:stupid) compiler:warning compiler:error)
|
|
ast
|
|
"returning zero or multiple values to a context expecting 1 value"))
|
|
|
|
(add-local-var! var)
|
|
|
|
(let-values ([(body body-multi)
|
|
(analyze! (zodiac:let-values-form-body ast)
|
|
(cons var env)
|
|
inlined tail? wcm-tail?)]
|
|
[(known-val) (extract-varref-known-val var)])
|
|
|
|
(if (and (compiler:option:propagate-constants)
|
|
(not (binding-mutable? binding))
|
|
known-val
|
|
(can-propagate-constant? known-val)
|
|
(can-drop-expression? val)
|
|
;; can't eliminiate if a letrec->let variable
|
|
(not (binding-letrec-set? binding))
|
|
;; can't eliminate if it is used by a bad application
|
|
(not (binding-known-but-used? binding)))
|
|
|
|
;; discard the let:
|
|
(begin
|
|
(remove-local-var! var)
|
|
(values body body-multi))
|
|
|
|
;; otherwise, process normally
|
|
(begin
|
|
(zodiac:set-let-values-form-vars!
|
|
ast
|
|
(cons (cons var
|
|
(cdr (car (zodiac:let-values-form-vars ast))))
|
|
(cdr (zodiac:let-values-form-vars ast)) ))
|
|
|
|
(zodiac:set-let-values-form-body! ast body)
|
|
|
|
(if (zodiac:set!-form? val)
|
|
|
|
;; if we're binding the result of a set!-form,
|
|
;; turn it into
|
|
;; a void.
|
|
(values (convert-set!-val) #f)
|
|
|
|
;; if it's any other expression, we're done.
|
|
(begin
|
|
(zodiac:set-let-values-form-vals!
|
|
ast
|
|
(cons val
|
|
(cdr (zodiac:let-values-form-vals ast))))
|
|
(values ast body-multi)))))))
|
|
|
|
;; this is a multiple (or zero) value binding let
|
|
;; the values are unknown to simple analysis so skip
|
|
;; that stuff
|
|
(begin
|
|
(zodiac:set-let-values-form-vars!
|
|
ast
|
|
(cons vars
|
|
(cdr (zodiac:let-values-form-vars ast))))
|
|
|
|
;; these are all new bindings
|
|
(for-each add-local-var! vars)
|
|
;; analyze the body
|
|
(let-values ([(body body-multi)
|
|
(analyze! (zodiac:let-values-form-body ast)
|
|
(append vars env)
|
|
inlined
|
|
tail? wcm-tail?)])
|
|
(zodiac:set-let-values-form-body! ast body)
|
|
|
|
(if (zodiac:set!-form? val)
|
|
(begin
|
|
((if (compiler:option:stupid) compiler:warning compiler:error)
|
|
val
|
|
(format
|
|
"returning 1 value (void) to a context expecting ~a values"
|
|
(length vars)))
|
|
(when (compiler:option:stupid)
|
|
(values (convert-set!-val) #f)))
|
|
; if it's any other option, we're done
|
|
(begin
|
|
(zodiac:set-let-values-form-vals!
|
|
ast
|
|
(cons val
|
|
(cdr (zodiac:let-values-form-vals ast))))
|
|
(values ast body-multi)))))
|
|
|
|
))]
|
|
|
|
;;-----------------------------------------------------------------
|
|
;; LETREC EXPRESSIONS
|
|
;;
|
|
;; if the letrec form binds only lambda values and those bindings
|
|
;; are not mutable, we keep this as a letrec, otherwise we
|
|
;; transform it to a let+set! combination as R4RS.
|
|
;;
|
|
[(zodiac:letrec-values-form? ast)
|
|
|
|
(if (and
|
|
;; Well-behaved if everything's a closure
|
|
(andmap zodiac:case-lambda-form?
|
|
(zodiac:letrec-values-form-vals ast))
|
|
;; and all are one-variable bindings
|
|
(andmap (lambda (l) (= 1 (length l)))
|
|
(zodiac:letrec-values-form-vars ast))
|
|
;; and all are immutable
|
|
(andmap (lambda (l)
|
|
(not (binding-mutable? (get-annotation (car l)))))
|
|
(zodiac:letrec-values-form-vars ast)))
|
|
|
|
;;-----------------------------------------------------------
|
|
;; WELL-BEHAVED LETREC (incomplete bindings never exposed)
|
|
;; mark appropriate variables as letrec bound
|
|
;;
|
|
(let* ([vars (map car (zodiac:letrec-values-form-vars ast))])
|
|
(set! local-vars (set-union (list->set vars) local-vars))
|
|
(let ([new-env (append vars env)])
|
|
(let-values ([(vals) (map (lambda (val)
|
|
(analyze!-sv val new-env inlined))
|
|
(zodiac:letrec-values-form-vals ast))]
|
|
[(body body-multi) (analyze!
|
|
(zodiac:letrec-values-form-body ast)
|
|
new-env
|
|
inlined
|
|
tail? wcm-tail?)]
|
|
[(vars) (map car (zodiac:letrec-values-form-vars ast))])
|
|
|
|
(for-each (lambda (var) (set-binding-rec?! (get-annotation var) #t))
|
|
vars)
|
|
(zodiac:set-letrec-values-form-vals! ast vals)
|
|
(zodiac:set-letrec-values-form-body! ast body)
|
|
|
|
(values ast body-multi))))
|
|
|
|
;;-----------------------------------------------------------
|
|
;; POSSIBLY POORLY BEHAVED LETREC
|
|
;; rewrite as let+set!
|
|
;;
|
|
(begin
|
|
(when (compiler:option:verbose)
|
|
(compiler:warning ast "letrec will be rewritten with set!"))
|
|
(debug "rewriting letrec\n")
|
|
(let ([new-ast (letrec->let+set! ast)])
|
|
(debug "reanalyzing...\n")
|
|
(analyze! new-ast env inlined tail? wcm-tail?))))]
|
|
|
|
;;-----------------------------------------------------
|
|
;; IF EXPRESSIONS
|
|
;;
|
|
;; just analyze the 3 branches. Very easy
|
|
[(zodiac:if-form? ast)
|
|
(zodiac:set-if-form-test! ast (analyze!-sv (zodiac:if-form-test ast) env inlined))
|
|
(let-values ([(then then-multi) (analyze! (zodiac:if-form-then ast) env inlined tail? wcm-tail?)]
|
|
[(else else-multi) (analyze! (zodiac:if-form-else ast) env inlined tail? wcm-tail?)])
|
|
(zodiac:set-if-form-then! ast then)
|
|
(zodiac:set-if-form-else! ast else)
|
|
|
|
(values ast (or-multi then-multi else-multi)))]
|
|
|
|
;;--------------------------------------------------------
|
|
;; BEGIN EXPRESSIONS
|
|
;;
|
|
;; analyze the branches
|
|
[(zodiac:begin-form? ast)
|
|
|
|
(let-values ([(bodies last-multi)
|
|
(let loop ([bodies (zodiac:begin-form-bodies ast)])
|
|
(if (null? (cdr bodies))
|
|
(let-values ([(e last-multi) (analyze! (car bodies) env inlined tail? wcm-tail?)])
|
|
(values (list e)
|
|
last-multi))
|
|
(let-values ([(e) (analyze!-ast (car bodies) env inlined)]
|
|
[(bodies last-multi) (loop (cdr bodies))])
|
|
(values (cons e bodies) last-multi))))])
|
|
|
|
(zodiac:set-begin-form-bodies! ast bodies)
|
|
(values ast last-multi))]
|
|
|
|
|
|
;;--------------------------------------------------------
|
|
;; BEGIN0 EXPRESSIONS
|
|
;;
|
|
;; analyze the branches
|
|
[(zodiac:begin0-form? ast)
|
|
(let-values ([(0expr 0expr-multi) (analyze! (zodiac:begin0-form-first ast) env inlined #f #f)])
|
|
(zodiac:set-begin0-form-first! ast 0expr)
|
|
(zodiac:set-begin0-form-rest! ast (analyze!-ast (zodiac:begin0-form-rest ast) env inlined))
|
|
(let ([var (get-annotation ast)])
|
|
(add-local-var! var))
|
|
(values ast 0expr-multi))]
|
|
|
|
;;--------------------------------------------------------
|
|
;; SET! EXPRESSIONS
|
|
;;
|
|
;; we analyze the target, which will register it as being
|
|
;; mutable or used, as necessary. Then we analyze the value.
|
|
;;
|
|
[(zodiac:set!-form? ast)
|
|
|
|
(let ([target (analyze-varref! (zodiac:set!-form-var ast) env #f #t)])
|
|
(zodiac:set-set!-form-var! ast target)
|
|
(zodiac:set-set!-form-val!
|
|
ast
|
|
(analyze!-sv (zodiac:set!-form-val ast) env inlined)))
|
|
|
|
(values ast #f)]
|
|
|
|
;;---------------------------------------------------------
|
|
;; DEFINE EXPRESSIONS
|
|
;;
|
|
;; defines are very tricky, eh what?
|
|
;;
|
|
[(zodiac:define-values-form? ast)
|
|
|
|
(prepare-local-lists)
|
|
|
|
(zodiac:set-define-values-form-vars!
|
|
ast
|
|
(map (lambda (v)
|
|
(let ([v
|
|
;; Make sure v is not mapped to an import:
|
|
(ensure-top-level v)])
|
|
(analyze-varref! v env #f #t)))
|
|
(zodiac:define-values-form-vars ast)))
|
|
|
|
(move-over-local-lists)
|
|
|
|
(zodiac:set-define-values-form-val!
|
|
ast
|
|
(analyze!-ast (zodiac:define-values-form-val ast) env inlined))
|
|
(values ast #f)]
|
|
|
|
;;----------------------------------------------------------
|
|
;; DEFINE-SYNTAX
|
|
;;
|
|
[(zodiac:define-syntaxes-form? ast)
|
|
(for-each (lambda (name)
|
|
(compiler:get-symbol-const! #f (zodiac:varref-var name)))
|
|
(zodiac:define-syntaxes-form-names ast))
|
|
(zodiac:set-define-syntaxes-form-expr!
|
|
ast
|
|
(analyze!-ast (zodiac:define-syntaxes-form-expr ast) env inlined))
|
|
(values ast #f)]
|
|
|
|
;;-------------------------------------------------------------------
|
|
;; APPLICATIONS
|
|
;; analyze all the parts. replace with a compiler:app
|
|
;; annotated with tail?
|
|
;; If this is a call to a primitive, check the arity.
|
|
;;
|
|
[(zodiac:app? ast)
|
|
(check-for-inlining
|
|
ast
|
|
env
|
|
inlined
|
|
tail?
|
|
(lambda (new-ast new-inlined)
|
|
(when (compiler:option:verbose)
|
|
(compiler:warning ast "inlining procedure call"))
|
|
; We inlined - analyze the new form
|
|
(analyze! new-ast env new-inlined tail? wcm-tail?))
|
|
(lambda (why)
|
|
'(begin
|
|
(zodiac:print-start! (current-output-port) ast)
|
|
(printf "no inlining: ~a\n" (eval why)))
|
|
(let* ([fun (let ([v (analyze!-sv (zodiac:app-fun ast) env inlined)])
|
|
(if (zodiac:varref? v)
|
|
v
|
|
;; known non-procedure!
|
|
(let ([var (zodiac:app-fun ast)])
|
|
((if (compiler:option:stupid)
|
|
compiler:warning
|
|
compiler:error)
|
|
ast
|
|
"application of a non-procedure")
|
|
(if (zodiac:varref? var)
|
|
(begin
|
|
(set-binding-known-but-used?!
|
|
(get-annotation (zodiac:bound-varref-binding var))
|
|
#t)
|
|
(analyze-varref! var env #f #t))
|
|
(analyze!-sv var env inlined)))))]
|
|
[primfun (app-prim-name (get-annotation ast))]
|
|
[multi (if primfun
|
|
(let ([a (primitive-result-arity
|
|
(dynamic-require ''#%kernel primfun))])
|
|
(cond
|
|
[(and (number? a) (= a 1)) #f]
|
|
[(number? a) #t]
|
|
[else 'possible]))
|
|
'possible)]
|
|
[args (map (lambda (arg)
|
|
(analyze!-sv arg env inlined))
|
|
(zodiac:app-args ast))])
|
|
|
|
; for all functions, do this stuff
|
|
(zodiac:set-app-fun! ast fun)
|
|
(zodiac:set-app-args! ast args)
|
|
(set-app-tail?! (get-annotation ast) tail?)
|
|
|
|
(register-arity! (length args))
|
|
|
|
(values ast multi))))]
|
|
|
|
;;-------------------------------------------------------------------
|
|
;; WITH-CONTINUATION-MARK
|
|
;;
|
|
;; analyze the key, val, and body
|
|
;;
|
|
[(zodiac:with-continuation-mark-form? ast)
|
|
|
|
(zodiac:set-with-continuation-mark-form-key!
|
|
ast
|
|
(analyze!-sv (zodiac:with-continuation-mark-form-key ast) env inlined))
|
|
|
|
(zodiac:set-with-continuation-mark-form-val!
|
|
ast
|
|
(analyze!-sv (zodiac:with-continuation-mark-form-val ast) env inlined))
|
|
|
|
(let-values ([(body body-multi)
|
|
(analyze! (zodiac:with-continuation-mark-form-body ast) env inlined tail? #t)])
|
|
|
|
(if (or tail? wcm-tail?)
|
|
; No frame push, so no need for begin0-like handling
|
|
(set-annotation! ast #f)
|
|
|
|
(let ([var (get-annotation ast)])
|
|
(add-local-var! var)))
|
|
|
|
(zodiac:set-with-continuation-mark-form-body!
|
|
ast
|
|
body)
|
|
|
|
(values ast body-multi))]
|
|
|
|
;;-----------------------------------------------------------
|
|
;; GLOBALS
|
|
;;
|
|
[(zodiac:global-prepare? ast)
|
|
(zodiac:set-global-prepare-vec!
|
|
ast
|
|
(analyze!-ast (zodiac:global-prepare-vec ast) env inlined))
|
|
(values ast #f)]
|
|
[(zodiac:global-lookup? ast)
|
|
(zodiac:set-global-lookup-vec!
|
|
ast
|
|
(analyze!-ast (zodiac:global-lookup-vec ast) env inlined))
|
|
(values ast #f)]
|
|
[(zodiac:global-assign? ast)
|
|
(zodiac:set-global-assign-vec!
|
|
ast
|
|
(analyze!-ast (zodiac:global-assign-vec ast) env inlined))
|
|
(zodiac:set-global-assign-expr!
|
|
ast
|
|
(analyze!-ast (zodiac:global-assign-expr ast) env inlined))
|
|
(values ast #f)]
|
|
[(zodiac:safe-vector-ref? ast)
|
|
(zodiac:set-safe-vector-ref-vec!
|
|
ast
|
|
(analyze!-ast (zodiac:safe-vector-ref-vec ast) env inlined))
|
|
(values ast #f)]
|
|
|
|
[else (compiler:internal-error
|
|
ast
|
|
(format "unsupported syntactic form (~a)"
|
|
(if (struct? ast)
|
|
(vector-ref (struct->vector ast) 0)
|
|
ast)))]))])
|
|
|
|
;; analyze the expression and return it with the local variables
|
|
;; it creates.
|
|
(let-values ([(ast multi) (analyze! ast env 0 tail? #f)])
|
|
(values ast
|
|
free-vars
|
|
local-vars
|
|
global-vars
|
|
locals-used
|
|
captured-vars
|
|
codes
|
|
max-arity
|
|
multi))))))))
|