398 lines
11 KiB
Scheme
398 lines
11 KiB
Scheme
|
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
; Simple code analysis to determine whether it's a good idea to
|
||
|
|
; in-line calls to a given procedure.
|
||
|
|
|
||
|
|
; Hook into the byte code compiler.
|
||
|
|
|
||
|
|
(set-optimizer! 'auto-integrate
|
||
|
|
(lambda (stuff p)
|
||
|
|
(set-package-integrate?! p #t)
|
||
|
|
(newline)
|
||
|
|
(display "Analyzing... ") (force-output (current-output-port))
|
||
|
|
(let* ((names '())
|
||
|
|
(stuff
|
||
|
|
(map (lambda (filename+nodes)
|
||
|
|
(let ((filename (car filename+nodes))
|
||
|
|
(nodes (cdr filename+nodes)))
|
||
|
|
(set! names
|
||
|
|
(append (analyze-forms nodes p) names))
|
||
|
|
(cons filename nodes)))
|
||
|
|
stuff)))
|
||
|
|
(cond ((not (null? names))
|
||
|
|
(newline)
|
||
|
|
(display "Calls will be compiled in line: ")
|
||
|
|
(write (reverse names)))
|
||
|
|
(else
|
||
|
|
(display "no in-line procedures")))
|
||
|
|
(newline)
|
||
|
|
stuff)))
|
||
|
|
|
||
|
|
(define (analyze-forms scanned-nodes p)
|
||
|
|
(let ((inlines '()))
|
||
|
|
(for-each (lambda (node)
|
||
|
|
(let ((lhs (analyze-form node p)))
|
||
|
|
(if lhs
|
||
|
|
(set! inlines (cons lhs inlines)))))
|
||
|
|
scanned-nodes)
|
||
|
|
inlines))
|
||
|
|
|
||
|
|
(define (analyze-form node p) ;Return LHS iff calls will be inlined.
|
||
|
|
(if (define-node? node)
|
||
|
|
(let ((form (node-form node)))
|
||
|
|
(let ((lhs (cadr form))
|
||
|
|
(rhs (caddr form)))
|
||
|
|
(let ((type (package-lookup-type p lhs)))
|
||
|
|
(if (variable-type? type)
|
||
|
|
(require "not assigned" lhs #f)
|
||
|
|
(let ((method (inlinable-rhs? rhs type p lhs)))
|
||
|
|
(if method
|
||
|
|
(begin (package-define! p lhs method)
|
||
|
|
(if (transform? method)
|
||
|
|
lhs
|
||
|
|
#f))
|
||
|
|
#f))))))
|
||
|
|
#f))
|
||
|
|
|
||
|
|
(define lambda-node? (node-predicate 'lambda))
|
||
|
|
(define name-node? (node-predicate 'name))
|
||
|
|
(define loophole-node? (node-predicate 'loophole))
|
||
|
|
|
||
|
|
|
||
|
|
(define (inlinable-rhs? node type p lhs)
|
||
|
|
(cond ((lambda-node? node)
|
||
|
|
(if (simple-lambda? node lhs p)
|
||
|
|
(make-inline-transform node type p lhs)
|
||
|
|
#f))
|
||
|
|
((name-node? node)
|
||
|
|
(let ((name (node-form node)))
|
||
|
|
(if (and (require "symbol rhs" (list lhs name)
|
||
|
|
(symbol? name))
|
||
|
|
(require "rhs unassigned" (list lhs name)
|
||
|
|
(not (variable-type? (package-lookup-type p name))))
|
||
|
|
(require "definitely procedure" (list lhs name)
|
||
|
|
(procedure-type? (package-lookup-type p name))))
|
||
|
|
(make-inline-transform node type p lhs)
|
||
|
|
#f)))
|
||
|
|
((loophole-node? node)
|
||
|
|
(inlinable-rhs? (caddr (node-form node)) type p lhs))
|
||
|
|
((primitive-procedure-node? node)
|
||
|
|
(get-operator (cadr (node-form node))))
|
||
|
|
(else #f)))
|
||
|
|
|
||
|
|
(define primitive-procedure-node? (node-predicate 'primitive-procedure))
|
||
|
|
|
||
|
|
|
||
|
|
; We elect to integrate a procedure definition when
|
||
|
|
; 1. The procedure in not n-ary,
|
||
|
|
; 2. Every parameter is used exactly once and not assigned, and
|
||
|
|
; 3. The analysis phase says that the body is acceptable (see below).
|
||
|
|
|
||
|
|
(define (simple-lambda? node id p)
|
||
|
|
(let* ((exp (node-form node))
|
||
|
|
(formals (cadr exp))
|
||
|
|
(body (caddr exp))
|
||
|
|
(var-nodes (node-ref node 'var-nodes)))
|
||
|
|
(and (require "not n-ary" id
|
||
|
|
(not (n-ary? formals)))
|
||
|
|
(require "unique references" id
|
||
|
|
(every (lambda (var-node)
|
||
|
|
(let ((lexical (node-ref var-node 'lexical)))
|
||
|
|
(and (= (lexical-reference-count lexical) 1)
|
||
|
|
(= (lexical-assignment-count lexical) 0))))
|
||
|
|
var-nodes))
|
||
|
|
(require "good analysis" id
|
||
|
|
(simple? (caddr exp)
|
||
|
|
(bind formals
|
||
|
|
(map (lambda (name)
|
||
|
|
(make-node operator/name name))
|
||
|
|
formals)
|
||
|
|
(package->environment p))
|
||
|
|
ret)))))
|
||
|
|
|
||
|
|
(define operator/name (get-operator 'name 'leaf))
|
||
|
|
|
||
|
|
; --------------------
|
||
|
|
; SIMPLE? takes an alpha-converted expression and returns either
|
||
|
|
; - #f, meaning that the procedure in which the expression occurs
|
||
|
|
; has no chance of being fully inlinable, so we might as well give up,
|
||
|
|
; - #t, if there's no problem, or
|
||
|
|
; - 'empty, if there's no problem AND there are no lexical variable
|
||
|
|
; references at or below this node.
|
||
|
|
; Foul situations are:
|
||
|
|
; - complex quotations (we don't want to make multiple copies of them)
|
||
|
|
; - a LAMBDA occurs (too much overhead, presumably)
|
||
|
|
; - a call that is not to a primitive and not a tail call
|
||
|
|
|
||
|
|
|
||
|
|
; Main dispatch for analyzer
|
||
|
|
|
||
|
|
(define (simple? node env ret?)
|
||
|
|
((operator-table-ref analyzers (node-operator-id node))
|
||
|
|
(node-form node)
|
||
|
|
env ret?))
|
||
|
|
|
||
|
|
(define (simple-list? exp-list env)
|
||
|
|
(if (null? exp-list)
|
||
|
|
'empty
|
||
|
|
(let ((s1 (simple? (car exp-list) env no-ret)))
|
||
|
|
(if (eq? s1 'empty)
|
||
|
|
(simple-list? (cdr exp-list) env)
|
||
|
|
(if s1
|
||
|
|
(and (simple-list? (cdr exp-list) env)
|
||
|
|
#t)
|
||
|
|
#f)))))
|
||
|
|
|
||
|
|
|
||
|
|
; Particular operators
|
||
|
|
|
||
|
|
(define analyzers
|
||
|
|
(make-operator-table (lambda (exp env ret?)
|
||
|
|
(simple-list? (cdr exp) env))))
|
||
|
|
|
||
|
|
(define (define-analyzer name proc)
|
||
|
|
(operator-define! analyzers name #f proc))
|
||
|
|
|
||
|
|
(define-analyzer 'literal
|
||
|
|
(lambda (exp env ret?)
|
||
|
|
(if (require "repeatable literal" #f
|
||
|
|
(simple-literal? exp))
|
||
|
|
'empty
|
||
|
|
#f)))
|
||
|
|
|
||
|
|
(define-analyzer 'name
|
||
|
|
(lambda (exp env ret?)
|
||
|
|
;; (if (node-ref node 'lexical) #t 'empty)
|
||
|
|
;; ... (not (generated? exp)) ugh ...
|
||
|
|
#t))
|
||
|
|
|
||
|
|
(define-analyzer 'quote
|
||
|
|
(lambda (exp env ret?)
|
||
|
|
(if (require "repeatable quotation" #f
|
||
|
|
(simple-literal? (cadr exp)))
|
||
|
|
'empty
|
||
|
|
#f)))
|
||
|
|
|
||
|
|
(define-analyzer 'lambda
|
||
|
|
(lambda (exp env ret?) #f))
|
||
|
|
|
||
|
|
(define-analyzer 'letrec
|
||
|
|
(lambda (exp env ret?) #f))
|
||
|
|
|
||
|
|
(define-analyzer 'set!
|
||
|
|
(lambda (exp env ret?)
|
||
|
|
(simple? (caddr exp) env no-ret)))
|
||
|
|
|
||
|
|
(define-analyzer 'loophole
|
||
|
|
(lambda (exp env ret?)
|
||
|
|
(simple? (caddr exp) env ret?)))
|
||
|
|
|
||
|
|
; Can't always fully in-line things like (lambda (a b c) (if a b c))
|
||
|
|
|
||
|
|
(define-analyzer 'if
|
||
|
|
(lambda (exp env ret?)
|
||
|
|
(and (eq? (simple? (caddr exp) env ret?) 'empty)
|
||
|
|
(eq? (simple? (cadddr exp) env ret?) 'empty)
|
||
|
|
(simple? (cadr exp) env no-ret))))
|
||
|
|
|
||
|
|
(define-analyzer 'begin
|
||
|
|
(lambda (exp env ret?)
|
||
|
|
(let loop ((exps (cdr exp)))
|
||
|
|
(if (null? (cdr exps))
|
||
|
|
(if (simple? (car exps) env ret?) #t #f)
|
||
|
|
(and (simple? (car exps) env no-ret)
|
||
|
|
(loop (cdr exps)))))))
|
||
|
|
|
||
|
|
(define-analyzer 'call
|
||
|
|
(lambda (exp env ret?)
|
||
|
|
;; Retry transforming calls in hopes of finding procedures that
|
||
|
|
;; have become integrable as a result of the ongoing analysis of
|
||
|
|
;; this package.
|
||
|
|
(let ((proc (car exp)))
|
||
|
|
(if (name-node? proc)
|
||
|
|
(let* ((node (make-node (get-operator 'call) exp))
|
||
|
|
(new-node (maybe-transform-call proc node env)))
|
||
|
|
(if (eq? new-node node)
|
||
|
|
(really-simple-call? exp env ret?)
|
||
|
|
(simple? (expand new-node env) env ret?)))
|
||
|
|
(really-simple-call? exp env ret?)))))
|
||
|
|
|
||
|
|
(define (really-simple-call? exp env ret?)
|
||
|
|
(let ((proc (car exp)))
|
||
|
|
(and (require "non-local non-tail call" proc
|
||
|
|
(or (and ret? (simple? proc env no-ret)) ;tail calls are ok
|
||
|
|
(lexical-node? proc))) ;so are calls to arguments
|
||
|
|
(simple-list? exp env))))
|
||
|
|
|
||
|
|
(define (lexical-node? node)
|
||
|
|
(not (node-ref node 'binding)))
|
||
|
|
|
||
|
|
(define no-ret #f)
|
||
|
|
|
||
|
|
(define ret #t)
|
||
|
|
|
||
|
|
(define (simple-literal? x) ;Things that TRANSPORT won't copy.
|
||
|
|
(or (integer? x)
|
||
|
|
(boolean? x)
|
||
|
|
(null? x)
|
||
|
|
(char? x)
|
||
|
|
(symbol? x)))
|
||
|
|
|
||
|
|
|
||
|
|
; --------------------
|
||
|
|
; Once we know that we want something to be inlined, the following things
|
||
|
|
; actually makes use of the fact. For procedures for which all
|
||
|
|
; arguments can be substituted unconditionally, we make a transform
|
||
|
|
; (a macro, really) that performs the substitution.
|
||
|
|
|
||
|
|
(define (make-inline-transform node type p name)
|
||
|
|
(let* ((free (free-top-level-variables node))
|
||
|
|
(form (make-substitution-template node p free))
|
||
|
|
(aux-names (map (lambda (free)
|
||
|
|
(do ((free free (generated-parent-name free)))
|
||
|
|
((not (generated? free)) free)))
|
||
|
|
free)))
|
||
|
|
(make-transform (inline-transform form aux-names)
|
||
|
|
p ;env ?
|
||
|
|
type
|
||
|
|
`(inline-transform ',form ',aux-names)
|
||
|
|
name)))
|
||
|
|
|
||
|
|
; Create something that can be passed to SUBSTITUTE. Must be valid as
|
||
|
|
; a quotation.
|
||
|
|
|
||
|
|
(define (make-substitution-template node p free)
|
||
|
|
(let ((env (package->environment p)))
|
||
|
|
(clean-node node
|
||
|
|
(map (lambda (free)
|
||
|
|
(cons free (name->qualified free env)))
|
||
|
|
free))))
|
||
|
|
|
||
|
|
; This routine is obligated to return an S-expression.
|
||
|
|
; It's better not to rely on the constancy of node id's, so
|
||
|
|
; the output language is a sort of quasi-Scheme. Any form that's a list
|
||
|
|
; has an operator name in its car.
|
||
|
|
|
||
|
|
(define (clean-node node env)
|
||
|
|
(cond ((name-node? node)
|
||
|
|
(clean-lookup env (node-form node)))
|
||
|
|
((quote-node? node)
|
||
|
|
`(quote ,(cadr (node-form node))))
|
||
|
|
((lambda-node? node)
|
||
|
|
(clean-lambda node env))
|
||
|
|
((call-node? node)
|
||
|
|
(cons 'call
|
||
|
|
(map (lambda (node) (clean-node node env))
|
||
|
|
(node-form node))))
|
||
|
|
((loophole-node? node) ;Uck
|
||
|
|
(let ((args (cdr (node-form node))))
|
||
|
|
`(loophole ,(schemify (car args))
|
||
|
|
,(clean-node (cadr args) env))))
|
||
|
|
;; LETREC had better not occur, since we ain't prepared for it
|
||
|
|
((pair? (node-form node))
|
||
|
|
(cons (operator-name (node-operator node))
|
||
|
|
(map (lambda (subnode)
|
||
|
|
(clean-node subnode env))
|
||
|
|
(cdr (node-form node)))))
|
||
|
|
(else (node-form node)))) ;literal
|
||
|
|
|
||
|
|
(define quote-node? (node-predicate 'quote))
|
||
|
|
(define call-node? (node-predicate 'call))
|
||
|
|
|
||
|
|
|
||
|
|
(define (clean-lambda node env)
|
||
|
|
(let* ((exp (node-form node))
|
||
|
|
(formals (cadr exp))
|
||
|
|
(env (append (map (lambda (name)
|
||
|
|
(cons name
|
||
|
|
(unused-name env name)))
|
||
|
|
(normalize-formals formals))
|
||
|
|
env)))
|
||
|
|
`(lambda ,(let recur ((foo formals))
|
||
|
|
(cond ((name? foo) (clean-lookup env foo))
|
||
|
|
((pair? foo)
|
||
|
|
(cons (recur (car foo))
|
||
|
|
(recur (cdr foo))))
|
||
|
|
(else foo)))
|
||
|
|
,(clean-node (caddr exp) env))))
|
||
|
|
|
||
|
|
(define (clean-lookup env name)
|
||
|
|
(cdr (assq name env))) ;Must be there.
|
||
|
|
|
||
|
|
; I'm aware that this is pedantic.
|
||
|
|
|
||
|
|
(define (unused-name env name)
|
||
|
|
(let ((sym (if (generated? name)
|
||
|
|
(generated-symbol name)
|
||
|
|
name)))
|
||
|
|
(do ((i 0 (+ i 1))
|
||
|
|
(name sym
|
||
|
|
(string->symbol (string-append (symbol->string sym)
|
||
|
|
(number->string i)))))
|
||
|
|
((not (assq name env)) name))))
|
||
|
|
|
||
|
|
|
||
|
|
(define (free-top-level-variables node)
|
||
|
|
(let recur ((node node) (vars '()))
|
||
|
|
(cond ((quote-node? node) vars)
|
||
|
|
((name-node? node)
|
||
|
|
(if (node-ref node 'binding)
|
||
|
|
(let ((var (node-form node)))
|
||
|
|
(if (memq var vars) vars (cons var vars)))
|
||
|
|
vars))
|
||
|
|
;; lambda, letrec shouldn't occur
|
||
|
|
(else
|
||
|
|
(let ((form (node-form node)))
|
||
|
|
(if (pair? form)
|
||
|
|
(reduce (lambda (node vars)
|
||
|
|
(if (node? node)
|
||
|
|
(recur node vars)
|
||
|
|
vars))
|
||
|
|
vars
|
||
|
|
(if (call-node? node)
|
||
|
|
form
|
||
|
|
(cdr form)))
|
||
|
|
vars))))))
|
||
|
|
|
||
|
|
|
||
|
|
; --------------------
|
||
|
|
; debugging hack
|
||
|
|
|
||
|
|
(define (require reason id x)
|
||
|
|
(if (and *debug?* (not x))
|
||
|
|
(begin (write id)
|
||
|
|
(display " lost because ")
|
||
|
|
(display reason)
|
||
|
|
(display " failed")
|
||
|
|
(newline)))
|
||
|
|
x)
|
||
|
|
|
||
|
|
(define *debug?* #f)
|
||
|
|
|
||
|
|
; utility
|
||
|
|
|
||
|
|
(define (package-lookup-type p name)
|
||
|
|
(let ((probe (package-lookup p name)))
|
||
|
|
(if (binding? probe)
|
||
|
|
(binding-type probe)
|
||
|
|
#f)))
|
||
|
|
|
||
|
|
; --------------------
|
||
|
|
|
||
|
|
|
||
|
|
;(define (foo f p)
|
||
|
|
; (analyze-forms (alpha-forms (scan-file f p) p)))
|
||
|
|
;
|
||
|
|
;
|
||
|
|
;(define (tst e p)
|
||
|
|
; (inlinable-rhs? (alpha e p) #f))
|
||
|
|
;
|
||
|
|
;(define b (make-compiler-base))
|
||
|
|
;
|
||
|
|
;(define p (make-simple-package (list b) eval #f))
|
||
|
|
;
|
||
|
|
;; (define b-stuff (alpha-structure b))
|
||
|
|
;
|