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:
parent
25f395c1d0
commit
0b00ab0380
|
@ -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)
|
||||||
|
|
|
@ -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))))
|
||||||
|
|
|
@ -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)
|
||||||
|
|
Loading…
Reference in New Issue