diff --git a/scheme/opt/analyze.scm b/scheme/opt/analyze.scm index dae8706..8ad4832 100644 --- a/scheme/opt/analyze.scm +++ b/scheme/opt/analyze.scm @@ -237,11 +237,20 @@ (let ((proc (car exp))) (and (require "non-local non-tail call" proc (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)))) -(define (lexical-node? node) - (not (node-ref node 'binding))) +; Calls to primitives and lexically bound variables are okay. + +(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) @@ -282,6 +291,7 @@ (define name-node? (node-predicate 'name)) (define loophole-node? (node-predicate 'loophole)) (define define-node? (node-predicate 'define syntax-type)) +(define literal-node? (node-predicate 'literal 'leaf)) ;---------------- ;(define (foo f p) diff --git a/scheme/opt/inline.scm b/scheme/opt/inline.scm index 3d3edea..cb98973 100644 --- a/scheme/opt/inline.scm +++ b/scheme/opt/inline.scm @@ -9,18 +9,21 @@ (let* ((free (find-node-usages node)) (env (package->environment package)) (qualified-free (map (lambda (name) - (name->qualified name env)) + (cons name + (name->qualified name env))) free))) - (let ((form (clean-node node (map cons free qualified-free))) - (aux-names (map (lambda (name) - (do ((name name (qualified-parent-name name))) + (let ((form (clean-node node '())) + (aux-names (map (lambda (pair) + (do ((name (cdr pair) (qualified-parent-name name))) ((not (qualified? name)) name))) qualified-free))) (make-transform (inline-transform form aux-names) package ;env ? type - `(inline-transform ',form ',aux-names) + `(inline-transform ',(remove-bindings form + qualified-free) + ',aux-names) name)))) ; This routine is obligated to return an S-expression. @@ -76,10 +79,10 @@ ; node itself. (define (clean-lookup env node) - (cdr (assq (if (binding? (node-ref node 'binding)) - (node-form node) - node) - env))) + (let ((binding (node-ref node 'binding))) + (if (binding? binding) + `(package-name ,(node-form node) ,binding) + (cdr (assq node env))))) ; I'm aware that this is pedantic. @@ -96,6 +99,23 @@ env) 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) @@ -150,6 +170,10 @@ (case (car st) ((quote) (make-node (get-operator 'quote) st)) + ((package-name) + (let ((node (make-node operator/name (cadr st)))) + (node-set! node 'binding (caddr st)) + node)) ((call) (make-node (get-operator 'call) (map label (cdr st)))) diff --git a/scheme/opt/usage.scm b/scheme/opt/usage.scm index cd151f2..397777f 100644 --- a/scheme/opt/usage.scm +++ b/scheme/opt/usage.scm @@ -142,17 +142,18 @@ (define-usage-analyzer 'letrec syntax-type (lambda (node free usages) - (let* ((exp (node-form node)) - (specs (cadr exp)) - (body (caddr exp))) - (for-each (lambda (spec) - (node-set! (car spec) 'usage (make-usage))) - specs) - (analyze body - (analyze-nodes (map cadr specs) - free - usages) - usages)))) + (let ((exp (node-form node))) + (analyze-letrec (cadr exp) (caddr exp) free usages)))) + +(define (analyze-letrec specs body free usages) + (for-each (lambda (spec) + (node-set! (car spec) 'usage (make-usage))) + specs) + (analyze body + (analyze-nodes (map cadr specs) + free + usages) + usages)) (define-usage-analyzer 'begin syntax-type (lambda (node free usages)