Upgraded inliner from 0.54. There is still a bug as a call to error must not be the last expression of a procedure. No fix for now, use (if #t (error ...)) as a workaround

This commit is contained in:
mainzelm 2001-03-25 11:21:58 +00:00
parent 25f395c1d0
commit 0b00ab0380
3 changed files with 58 additions and 23 deletions

View File

@ -237,11 +237,20 @@
(let ((proc (car exp))) (let ((proc (car exp)))
(and (require "non-local non-tail call" proc (and (require "non-local non-tail call" proc
(or (and ret? (simple? proc no-ret)) ;tail calls are ok (or (and ret? (simple? proc no-ret)) ;tail calls are ok
(lexical-node? proc))) ;so are calls to arguments (primitive-proc? proc))) ;as are calls to primitives
(simple-list? exp)))) (simple-list? exp))))
(define (lexical-node? node) ; Calls to primitives and lexically bound variables are okay.
(not (node-ref node 'binding)))
(define (primitive-proc? proc)
(cond ((literal-node? proc)
(primop? (node-form proc)))
((name-node? proc)
(let ((binding (node-ref proc 'binding)))
(and (binding? binding)
(primop? (binding-static binding)))))
(else
#f)))
(define no-ret #f) (define no-ret #f)
@ -282,6 +291,7 @@
(define name-node? (node-predicate 'name)) (define name-node? (node-predicate 'name))
(define loophole-node? (node-predicate 'loophole)) (define loophole-node? (node-predicate 'loophole))
(define define-node? (node-predicate 'define syntax-type)) (define define-node? (node-predicate 'define syntax-type))
(define literal-node? (node-predicate 'literal 'leaf))
;---------------- ;----------------
;(define (foo f p) ;(define (foo f p)

View File

@ -9,18 +9,21 @@
(let* ((free (find-node-usages node)) (let* ((free (find-node-usages node))
(env (package->environment package)) (env (package->environment package))
(qualified-free (map (lambda (name) (qualified-free (map (lambda (name)
(name->qualified name env)) (cons name
(name->qualified name env)))
free))) free)))
(let ((form (clean-node node (map cons free qualified-free))) (let ((form (clean-node node '()))
(aux-names (map (lambda (name) (aux-names (map (lambda (pair)
(do ((name name (qualified-parent-name name))) (do ((name (cdr pair) (qualified-parent-name name)))
((not (qualified? name)) ((not (qualified? name))
name))) name)))
qualified-free))) qualified-free)))
(make-transform (inline-transform form aux-names) (make-transform (inline-transform form aux-names)
package ;env ? package ;env ?
type type
`(inline-transform ',form ',aux-names) `(inline-transform ',(remove-bindings form
qualified-free)
',aux-names)
name)))) name))))
; This routine is obligated to return an S-expression. ; This routine is obligated to return an S-expression.
@ -76,10 +79,10 @@
; node itself. ; node itself.
(define (clean-lookup env node) (define (clean-lookup env node)
(cdr (assq (if (binding? (node-ref node 'binding)) (let ((binding (node-ref node 'binding)))
(node-form node) (if (binding? binding)
node) `(package-name ,(node-form node) ,binding)
env))) (cdr (assq node env)))))
; I'm aware that this is pedantic. ; I'm aware that this is pedantic.
@ -96,6 +99,23 @@
env) env)
name)))) name))))
; We need to remove the binding records from the form that will be used for
; reification.
(define (remove-bindings form free)
(let label ((form form))
(if (pair? form)
(case (car form)
((package-name)
(cdr (assq (cadr form) free))) ; just the name
((quote) form)
((lambda)
`(lambda ,(cadr form)
,(label (caddr form))))
(else
(map label form)))
form)))
;---------------- ;----------------
; ST stands for substitution template (cf. MAKE-SUBSTITUTION-TEMPLATE) ; ST stands for substitution template (cf. MAKE-SUBSTITUTION-TEMPLATE)
@ -150,6 +170,10 @@
(case (car st) (case (car st)
((quote) ((quote)
(make-node (get-operator 'quote) st)) (make-node (get-operator 'quote) st))
((package-name)
(let ((node (make-node operator/name (cadr st))))
(node-set! node 'binding (caddr st))
node))
((call) ((call)
(make-node (get-operator 'call) (make-node (get-operator 'call)
(map label (cdr st)))) (map label (cdr st))))

View File

@ -142,9 +142,10 @@
(define-usage-analyzer 'letrec syntax-type (define-usage-analyzer 'letrec syntax-type
(lambda (node free usages) (lambda (node free usages)
(let* ((exp (node-form node)) (let ((exp (node-form node)))
(specs (cadr exp)) (analyze-letrec (cadr exp) (caddr exp) free usages))))
(body (caddr exp)))
(define (analyze-letrec specs body free usages)
(for-each (lambda (spec) (for-each (lambda (spec)
(node-set! (car spec) 'usage (make-usage))) (node-set! (car spec) 'usage (make-usage)))
specs) specs)
@ -152,7 +153,7 @@
(analyze-nodes (map cadr specs) (analyze-nodes (map cadr specs)
free free
usages) usages)
usages)))) usages))
(define-usage-analyzer 'begin syntax-type (define-usage-analyzer 'begin syntax-type
(lambda (node free usages) (lambda (node free usages)