#! /bin/sh
# This is a shell archive. Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file". To overwrite existing
# files, type "sh file -c". You can also feed this as standard input via
# unshar, or by typing "sh 'pass2.aux.sch' <<'END_OF_FILE'
X; Procedures for fetching and clobbering parts of expressions.
X
X(define (constant? exp) (eq? (car exp) 'quote))
X(define (variable? exp)
X (and (eq? (car exp) 'begin)
X (null? (cddr exp))))
X(define (lambda? exp) (eq? (car exp) 'lambda))
X(define (call? exp) (pair? (car exp)))
X(define (assignment? exp) (eq? (car exp) 'set!))
X(define (conditional? exp) (eq? (car exp) 'if))
X(define (begin? exp)
X (and (eq? (car exp) 'begin)
X (not (null? (cddr exp)))))
X
X(define (make-constant value) (list 'quote value))
X(define (make-variable name) (list 'begin name))
X(define (make-lambda formals defs R F body)
X (list 'lambda
X formals
X (cons 'begin defs)
X (list 'quote (list R F))
X body))
X(define (make-call proc args) (cons proc (append args '())))
X(define (make-begin exprs) (cons 'begin (append exprs '())))
X(define (make-definition lhs rhs) (list 'define lhs rhs))
X
X(define (constant.value exp) (cadr exp))
X(define (variable.name exp) (cadr exp))
X(define (lambda.args exp) (cadr exp))
X(define (lambda.defs exp) (cdr (caddr exp)))
X(define (lambda.R exp) (car (cadr (cadddr exp))))
X(define (lambda.F exp) (cadr (cadr (cadddr exp))))
X(define (lambda.body exp) (car (cddddr exp)))
X(define (call.proc exp) (car exp))
X(define (call.args exp) (cdr exp))
X(define (assignment.lhs exp) (cadr exp))
X(define (assignment.rhs exp) (caddr exp))
X(define (if.test exp) (cadr exp))
X(define (if.then exp) (caddr exp))
X(define (if.else exp) (cadddr exp))
X(define (begin.exprs exp) (cdr exp))
X(define (def.lhs exp) (cadr exp))
X(define (def.rhs exp) (caddr exp))
X
X(define (lambda.args-set! exp args) (set-car! (cdr exp) args))
X(define (lambda.defs-set! exp defs) (set-cdr! (caddr exp) defs))
X(define (lambda.R-set! exp R) (set-car! (cadr (cadddr exp)) R))
X(define (lambda.F-set! exp F) (set-car! (cdr (cadr (cadddr exp))) F))
X(define (lambda.body-set! exp exp0) (set-car! (cddddr exp) exp0))
X(define (call.proc-set! exp exp0) (set-car! exp exp0))
X(define (call.args-set! exp exprs) (set-cdr! exp exprs))
X(define (assignment.rhs-set! exp exp0) (set-car! (cddr exp) exp0))
X(define (if.test-set! exp exp0) (set-car! (cdr exp) exp0))
X(define (if.then-set! exp exp0) (set-car! (cddr exp) exp0))
X(define (if.else-set! exp exp0) (set-car! (cdddr exp) exp0))
X(define (begin.exprs-set! exp exprs) (set-cdr! exp exprs))
X
X(define name:IGNORED (string->symbol "IGNORED"))
X(define name:CONS (string->symbol "CONS"))
X(define name:MAKE-CELL (string->symbol "MAKE-CELL"))
X(define name:CELL-REF (string->symbol "CELL-REF"))
X(define name:CELL-SET! (string->symbol "CELL-SET!"))
X
X(define (ignored? name) (eq? name name:IGNORED))
X
X; Fairly harmless bug: rest arguments aren't getting flagged.
X
X(define (flag-as-ignored name L)
X (define (loop name formals)
X (cond ((null? formals)
X ;(pass2-error p2error:violation-of-invariant name formals)
X #!unspecified)
X ((symbol? formals) #!unspecified)
X ((eq? name (car formals))
X (set-car! formals name:IGNORED)
X (if (not (local? (lambda.R L) name:IGNORED))
X (lambda.R-set! L
X (cons (make-R-entry name:IGNORED '() '() '())
X (lambda.R L)))))
X (else (loop name (cdr formals)))))
X (loop name (lambda.args L)))
X
X(define (make-null-terminated formals)
X (cond ((null? formals) '())
X ((symbol? formals) (list formals))
X (else (cons (car formals)
X (make-null-terminated (cdr formals))))))
X(define (remq x y)
X (cond ((null? y) '())
X ((eq? x (car y)) (remq x (cdr y)))
X (else (cons (car y) (remq x (cdr y))))))
X
X(define (make-call-to-LIST args)
X (cond ((null? args) (make-constant '()))
X (else (make-call (make-variable name:CONS)
X (list (car args)
X (make-call-to-list (cdr args)))))))
X
X(define (pass2-error i . etc)
X (apply cerror (cons (vector-ref pass2-error-messages i) etc)))
X
X(define pass2-error-messages
X '#("System error: violation of an invariant in pass 2"
X "Wrong number of arguments to known procedure"))
X
X(define p2error:violation-of-invariant 0)
X(define p2error:wna 1)
X
X; Procedures for fetching referencing information from R-tables.
X
X(define (make-R-entry name refs assigns calls)
X (list name refs assigns calls))
X
X(define (R-entry.name x) (car x))
X(define (R-entry.references x) (cadr x))
X(define (R-entry.assignments x) (caddr x))
X(define (R-entry.calls x) (cadddr x))
X
X(define (R-entry.references-set! x refs) (set-car! (cdr x) refs))
X(define (R-entry.assignments-set! x assignments) (set-car! (cddr x) assignments))
X(define (R-entry.calls-set! x calls) (set-car! (cdddr x) calls))
X
X(define (local? R I)
X (assq I R))
X
X(define (R-entry R I)
X (assq I R))
X
X(define (R-lookup R I)
X (or (assq I R)
X (pass2-error p2error:violation-of-invariant R I)))
X
X(define (references R I)
X (cadr (R-lookup R I)))
X
X(define (assignments R I)
X (caddr (R-lookup R I)))
X
X(define (calls R I)
X (cadddr (R-lookup R I)))
X
X(define (references-set! R I X)
X (set-car! (cdr (R-lookup R I)) X))
X
X(define (assignments-set! R I X)
X (set-car! (cddr (R-lookup R I)) X))
X
X(define (calls-set! R I X)
X (set-car! (cdddr (R-lookup R I)) X))
X
X; A notepad is a list of the form (L0 (L1 ...) (I ...)),
X; where the first component is a parent lambda expression
X; (or #f if there is no enclosing parent, or we want to
X; pretend that there isn't),
X; the second component is a list of lambda expressions that
X; the parent lambda expression encloses immediately,
X; and the third component is a list of free variables.
X
X(define (make-notepad L)
X (list L '() '()))
X
X(define (notepad.parent np) (car np))
X(define (notepad.lambdas np) (cadr np))
X(define (notepad.vars np) (caddr np))
X
X(define (notepad.lambdas-set! np x) (set-car! (cdr np) x))
X(define (notepad.vars-set! np x) (set-car! (cddr np) x))
X
X(define (notepad-lambda-add! np L)
X (notepad.lambdas-set! np (cons L (notepad.lambdas np))))
X
X(define (notepad-var-add! np I)
X (let ((vars (notepad.vars np)))
X (if (not (memq I vars))
X (notepad.vars-set! np (cons I vars)))))
X
X; Given a notepad, returns a list of free variables computed
X; as the union of the immediate free variables with the free
X; variables of nested lambda expressions.
X
X(define (notepad-free-variables np)
X (do ((lambdas (notepad.lambdas np) (cdr lambdas))
X (fv (notepad.vars np)
X (let ((L (car lambdas)))
X (union (difference (lambda.F L)
X (make-null-terminated (lambda.args L)))
X fv))))
X ((null? lambdas) fv)))
END_OF_FILE
if test 6570 -ne `wc -c <'pass2.aux.sch'`; then
echo shar: \"'pass2.aux.sch'\" unpacked with wrong size!
fi
# end of 'pass2.aux.sch'
fi
if test -f 'pass2.sch' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'pass2.sch'\"
else
echo shar: Extracting \"'pass2.sch'\" \(20907 characters\)
sed "s/^X//" >'pass2.sch' <<'END_OF_FILE'
X; Second pass of the Scheme 313 compiler:
X; single assignment analysis, assignment elimination,
X; lambda lifting, and various local source transformations.
X;
X; This pass operates as a source-to-source transformation on
X; expressions written in the subset of Scheme described by the
X; following grammar, where the input and output expressions
X; satisfy certain additional invariants described below.
X;
X; "X ..." means zero or more occurrences of X.
X;
X; L --> (lambda (I_1 ...)
X; (begin D ...)
X; (quote )
X; E)
X; | (lambda (I_1 ... . I_rest)
X; (begin D ...)
X; (quote (R F))
X; E)
X; D --> (define I L)
X; E --> (quote K) ; constants
X; | (begin I) ; variable references
X; | L ; lambda expressions
X; | (E0 E1 ...) ; calls
X; | (set! I E) ; assignments
X; | (if E0 E1 E2) ; conditionals
X; | (begin E0 E1 E2 ...) ; sequential expressions
X; I -->
X;
X; --> (R F)
X; R --> ((I ) ...)
X; F --> (I ...)
X;
X; Invariants that hold for the input only:
X; * There are no internal definitions.
X; * No identifier containing an upper case letter is bound anywhere.
X; (Change the "name:..." variables if upper case is preferred.)
X; * No identifier is bound in more than one place.
X; * Each R contains one entry for every identifier bound in the
X; formal argument list and the internal definition list that
X; precede it. Each entry contains a list of pointers to all
X; references to the identifier, a list of pointers to all
X; assignments to the identifier, and a list of pointers to all
X; calls to the identifier.
X; * Except for constants, the expression does not share structure
X; with the original input or itself, except that the references
X; and assignments in R are guaranteed to share structure with
X; the expression. Thus the expression may be side effected, and
X; side effects to references or assignments obtained through R
X; are guaranteed to change the references or assignments pointed
X; to by R.
X;
X; Invariants that hold for the output only:
X; * There are no assignments except to global variables.
X; * If I is declared by an internal definition, then the right hand
X; side of the internal definition is a lambda expression and I
X; is referenced only in the procedure position of a call.
X; * For each lambda expression, the associated F is a list of all
X; the identifiers that occur free in the body of that lambda
X; expression, and possibly a few extra identifiers that were
X; once free but have been removed by optimization.
X; * Variables named IGNORED are neither referenced nor assigned.
X
X(define (pass2 exp)
X (simplify exp (make-notepad #f)))
X
X; Given an expression and a "notepad" data structure that conveys
X; inherited attributes, performs the appropriate optimizations and
X; destructively modifies the notepad to record various attributes
X; that it synthesizes while traversing the expression. In particular,
X; any nested lambda expressions and any variable references will be
X; noted in the notepad.
X
X(define (simplify exp notepad)
X (case (car exp)
X ((quote) exp)
X ((lambda) (simplify-lambda exp notepad))
X ((set!) (simplify-assignment exp notepad))
X ((if) (simplify-conditional exp notepad))
X ((begin) (if (variable? exp)
X (begin (notepad-var-add! notepad (variable.name exp))
X exp)
X (simplify-sequential exp notepad)))
X (else (simplify-call exp notepad))))
X
X; Most optimization occurs here.
X; Single assignment analysis creates internal definitions
X; and renames arguments whose value is ignored.
X; Assignment elimination follows single assignment analysis.
X; The right hand sides of internal definitions are then
X; simplified, as is the expression in the body.
X; Internal definitions may then be lifted to the enclosing
X; lambda expression.
X
X(define (simplify-lambda exp notepad)
X (notepad-lambda-add! notepad exp)
X (single-assignment-analysis exp)
X (assignment-elimination exp)
X (let ((defs (lambda.defs exp))
X (body (lambda.body exp))
X (newnotepad (make-notepad exp)))
X (for-each (lambda (def)
X (simplify-lambda (def.rhs def) newnotepad))
X defs)
X (lambda.body-set! exp (simplify body newnotepad))
X (lambda.F-set! exp (notepad-free-variables newnotepad))
X (lambda-lifting exp (notepad.parent notepad))
X exp))
X
X(define (simplify-assignment exp notepad)
X (assignment.rhs-set! exp (simplify (assignment.rhs exp) notepad))
X exp)
X
X; Some source transformations on IF expressions:
X;
X; (if '#f E1 E2) E2
X; (if 'K E1 E2) E1 K != #f
X; (if (if B0 '#f '#f) E1 E2) (begin B0 E2)
X; (if (if B0 '#f 'K ) E1 E2) (if B0 E2 E1) K != #f
X; (if (if B0 'K '#f) E1 E2) (if B0 E1 E2) K != #f
X; (if (if B0 'K1 'K2) E1 E2) (begin B0 E1) K1, K2 != #f
X; (if (begin ... B0) E1 E2) (begin ... (if B0 E1 E2))
X; (if (not E0) E1 E2) (if E0 E2 E1) not is integrable
X
X(define (simplify-conditional exp notepad)
X (let loop ((test (simplify (if.test exp) notepad)))
X (if.test-set! exp test)
X (cond ((constant? test)
X (simplify (if (constant.value test)
X (if.then exp)
X (if.else exp))
X notepad))
X ((and (conditional? test)
X (constant? (if.then test))
X (constant? (if.else test)))
X (cond ((and (constant.value (if.then test))
X (constant.value (if.else test)))
X (post-simplify-begin
X (list 'begin (if.test test)
X (simplify (if.then exp) notepad))
X notepad))
X ((and (not (constant.value (if.then test)))
X (not (constant.value (if.then test))))
X (post-simplify-begin
X (list 'begin (if.test test)
X (simplify (if.else exp) notepad))
X notepad))
X (else (if.then-set! exp (simplify (if.then test) notepad))
X (if.else-set! exp (simplify (if.else test) notepad))
X (if (not (constant.value (if.then test)))
X (let ((temp (if.then exp)))
X (if.then-set! exp (if.else exp))
X (if.else-set! exp temp)))
X exp)))
X ((begin? test)
X (let ((exprs (reverse (begin.exprs test))))
X (if.test-set! exp (car exprs))
X (if.then-set! exp (simplify (if.then test) notepad))
X (if.else-set! exp (simplify (if.else test) notepad))
X (post-simplify-begin
X (cons 'begin
X (reverse (cons exp (cdr exprs))))
X notepad)))
X ((and (call? test)
X (variable? (call.proc test))
X (eq? (variable.name (call.proc test)) 'NOT)
X (integrable? 'NOT)
X (= (length (call.args test)) 1))
X (let ((temp (if.then exp)))
X (if.then-set! exp (if.else exp))
X (if.else-set! exp temp))
X (loop (car (call.args test))))
X (else (if.then-set! exp (simplify (if.then exp) notepad))
X (if.else-set! exp (simplify (if.else exp) notepad))
X exp))))
X
X(define (simplify-sequential exp notepad)
X (let ((exprs (map (lambda (exp) (simplify exp notepad))
X (begin.exprs exp))))
X (begin.exprs-set! exp exprs)
X (post-simplify-begin exp notepad)))
X
X; Given (BEGIN E0 E1 E2 ...) where the E_i are simplified expressions,
X; flattens any nested BEGINs and removes trivial expressions that
X; don't appear in the last position. The second argument is used only
X; if a lambda expression is removed.
X; This procedure is careful to return E instead of (BEGIN E).
X; Fairly harmless bug: a variable reference removed by this procedure
X; may remain on the notepad when it shouldn't.
X
X(define (post-simplify-begin exp notepad)
X ; (flatten exprs '()) returns the flattened exprs in reverse order.
X (define (flatten exprs flattened)
X (cond ((null? exprs) flattened)
X ((begin? (car exprs))
X (flatten (cdr exprs)
X (flatten (begin.exprs (car exprs)) flattened)))
X (else (flatten (cdr exprs) (cons (car exprs) flattened)))))
X (define (filter exprs filtered)
X (if (null? exprs)
X filtered
X (let ((exp (car exprs)))
X (cond ((constant? exp) (filter (cdr exprs) filtered))
X ((variable? exp) (filter (cdr exprs) filtered))
X ((lambda? exp)
X (notepad.lambdas-set! notepad
X (remq exp (notepad.lambdas notepad)))
X (filter (cdr exprs) filtered))
X (else (filter (cdr exprs) (cons exp filtered)))))))
X (let ((exprs (flatten (begin.exprs exp) '())))
X (begin.exprs-set! exp (filter (cdr exprs) (list (car exprs))))
X (if (null? (cdr (begin.exprs exp)))
X (car (begin.exprs exp))
X exp)))
X
X(define (simplify-call exp notepad)
X (call.proc-set! exp (simplify (call.proc exp) notepad))
X (call.args-set! exp (map (lambda (arg) (simplify arg notepad))
X (call.args exp)))
X (if (lambda? (call.proc exp))
X (simplify-let exp notepad)
X exp))
X
X; SIMPLIFY-LET performs these transformations:
X;
X; ((lambda () (begin) (quote R) E)) -> E
X;
X; ((lambda (I_1 ... I_k . I_rest) ---) E1 ... Ek Ek+1 ...)
X; -> ((lambda (I_1 ... I_k I_rest) ---) E1 ... Ek (CONS Ek+1 ...))
X;
X; ((lambda (IGNORED I2 ...) ---) E1 E2 ...)
X; -> (begin E1 ((lambda (I2 ...) ---) E2 ...))
X;
X; (Single assignment analysis, performed by the simplifier for lambda
X; expressions, detects unused arguments and replaces them in the argument
X; list by the special identifier IGNORED.)
X
X(define (simplify-let exp notepad)
X (define proc (call.proc exp))
X (define (loop formals actuals processed-formals processed-actuals for-effect)
X (cond ((null? formals)
X (if (not (null? actuals))
X (pass2-error p2error:wna exp))
X (return processed-formals processed-actuals for-effect))
X ((symbol? formals)
X (if (ignored? formals)
X (return processed-formals
X processed-actuals
X (append actuals for-effect))
X (return (cons formals processed-formals)
X (cons (make-call-to-LIST actuals) processed-actuals)
X for-effect)))
X ((ignored? (car formals))
X (if (null? actuals)
X (pass2-error p2error:wna exp))
X (loop (cdr formals)
X (cdr actuals)
X processed-formals
X processed-actuals
X (cons (car actuals) for-effect)))
X (else (if (null? actuals)
X (pass2-error p2error:wna exp))
X (loop (cdr formals)
X (cdr actuals)
X (cons (car formals) processed-formals)
X (cons (car actuals) processed-actuals)
X for-effect))))
X (define (return formals actuals for-effect)
X (lambda.args-set! proc (reverse formals))
X (call.args-set! exp (reverse actuals))
X (let ((exp (if (and (null? (lambda.defs proc))
X (null? actuals))
X (begin (for-each (lambda (I)
X (notepad-var-add! notepad I))
X (lambda.F proc))
X (lambda.body proc))
X exp)))
X (if (null? for-effect)
X exp
X (post-simplify-begin (make-begin (append for-effect (list exp)))
X notepad))))
X (loop (lambda.args proc) (call.args exp) '() '() '()))
X
X; Single assignment analysis performs the transformation
X;
X; (lambda (... I ...)
X; (begin D ...)
X; (quote ... (I ((set! I L)) #t) ...)
X; (begin (set! I L) E1 ...))
X; -> (lambda (... IGNORED ...)
X; (begin (define I L) D ...)
X; (quote ... (I () #t) ...)
X; (begin E1 ...))
X;
X; For best results, pass 1 should sort internal definitions and LETRECs so
X; that procedure definitions/bindings come first.
X;
X; This procedure operates by side effect.
X
X(define (single-assignment-analysis L)
X (let ((formals (lambda.args L))
X (defs (lambda.defs L))
X (R (lambda.R L))
X (body (lambda.body L)))
X (if (begin? body)
X (let ((first (car (begin.exprs body))))
X (if (assignment? first)
X (let ((I (assignment.lhs first))
X (rhs (assignment.rhs first)))
X (if (and (lambda? rhs)
X (local? R I)
X (= 1 (length (assignments R I)))
X (= (length (calls R I))
X (length (references R I))))
X (begin (flag-as-ignored I L)
X (lambda.defs-set! L
X (cons (make-definition I rhs)
X (lambda.defs L)))
X (assignments-set! R I '())
X (begin.exprs-set! body (cdr (begin.exprs body)))
X (lambda.body-set! L (post-simplify-begin body '()))
X (single-assignment-analysis L)))))))))
X
X; Assignment elimination replaces variables that appear on the left
X; hand side of an assignment by data structures. This is necessary
X; to avoid some nasty complications with lambda lifting.
X;
X; This procedure operates by side effect.
X
X(define (assignment-elimination L)
X (let ((formals (lambda.args L))
X (R (lambda.R L)))
X
X ; Given a list of entries, return those for assigned variables.
X
X (define (loop entries assigned)
X (cond ((null? entries)
X (if (not (null? assigned))
X (eliminate assigned)))
X ((not (null? (R-entry.assignments (car entries))))
X (loop (cdr entries) (cons (car entries) assigned)))
X ((null? (R-entry.references (car entries)))
X (flag-as-ignored (R-entry.name (car entries)) L)
X (loop (cdr entries) assigned))
X (else (loop (cdr entries) assigned))))
X
X ; Given a list of entries for assigned variables I1 ...,
X ; remove the assignments by replacing the body by a LET of the form
X ; ((LAMBDA (V1 ...) ...) (MAKE-CELL I1) ...), by replacing references
X ; by calls to CELL-REF, and by replacing assignments by calls to
X ; CELL-SET!.
X
X (define (eliminate assigned)
X (let ((augmented-entries
X (map (lambda (entry)
X (list (generate-new-name (R-entry.name entry)) entry))
X assigned)))
X (for-each cellify! augmented-entries)
X (let ((newbody
X (make-call
X (make-lambda (map car augmented-entries)
X '()
X (map new-reference-info augmented-entries)
X (union (list name:CELL-REF name:CELL-SET!)
X (map car augmented-entries)
X (difference (lambda.F L)
X (map R-entry.name assigned)))
X (lambda.body L))
X (map (lambda (name)
X (make-call (make-variable name:MAKE-CELL)
X (list (make-variable name))))
X (map R-entry.name assigned)))))
X (lambda.F-set! L (union (list name:MAKE-CELL name:CELL-REF name:CELL-SET!)
X (lambda.F L)))
X (for-each update-old-reference-info!
X (map (lambda (arg)
X (car (call.args arg)))
X (call.args newbody)))
X (lambda.body-set! L newbody))))
X
X (define (generate-new-name name)
X (string->symbol (string-append "CELL:" (symbol->string name))))
X
X ; In addition to replacing references and assignments involving the
X ; old variable by calls to CELL-REF and CELL-SET! on the new, CELLIFY!
X ; uses the old entry to collect the referencing information for the
X ; new variable.
X
X (define (cellify! augmented-entry)
X (let ((newname (car augmented-entry))
X (entry (cadr augmented-entry)))
X (do ((refs (R-entry.references entry)
X (cdr refs)))
X ((null? refs))
X (let* ((reference (car refs))
X (newref (make-variable newname)))
X (set-car! reference (make-variable name:CELL-REF))
X (set-car! (cdr reference) newref)
X (set-car! refs newref)))
X (do ((assigns (R-entry.assignments entry)
X (cdr assigns)))
X ((null? assigns))
X (let* ((assignment (car assigns))
X (newref (make-variable newname)))
X (set-car! assignment (make-variable name:CELL-SET!))
X (set-car! (cdr assignment) newref)
X (R-entry.references-set! entry
X (cons newref
X (R-entry.references entry)))))
X (R-entry.assignments-set! entry '())))
X
X ; This procedure creates a brand new entry for a new variable, extracting
X ; the references stored in the old entry by CELLIFY!.
X
X (define (new-reference-info augmented-entry)
X (make-R-entry (car augmented-entry)
X (R-entry.references (cadr augmented-entry))
X '()
X '()))
X
X ; This procedure updates the old entry to reflect the fact that it is
X ; now referenced once and never assigned.
X
X (define (update-old-reference-info! ref)
X (references-set! R (variable.name ref) (list ref))
X (assignments-set! R (variable.name ref) '())
X (calls-set! R (variable.name ref) '()))
X
X (loop R '())))
X
X; Lambda lifting raises internal definitions to outer scopes to avoid
X; having to choose between creating a closure or losing tail recursion.
X; If L is not #f, then L2 is a lambda expression nested within L.
X; Any internal definitions that occur within L2 may be lifted to L
X; by adding extra arguments to the defined procedure and to all calls to it.
X; Lambda lifting is not a clear win, because the extra arguments could
X; easily become more expensive than creating a closure and referring
X; to the non-local arguments through the closure. The heuristics used
X; to decide whether to lift a group of internal definitions are isolated
X; within the POLICY:LIFT? procedure.
X
X(define (lambda-lifting L2 L)
X
X ; The call to sort is optional. It gets the added arguments into
X ; the same order they appear in the formals list, which is an
X ; advantage for register targeting.
X
X (define (lift L2 L)
X (let ((formals (make-null-terminated (lambda.args L2))))
X (do ((defs (lambda.defs L2) (cdr defs)))
X ((null? defs))
X (let* ((def (car defs))
X (entry (R-lookup (lambda.R L2) (def.lhs def)))
X (calls (R-entry.calls entry))
X (added (sort (intersection (lambda.F (def.rhs def)) formals)
X (lambda (x y)
X (> (length (memq x formals))
X (length (memq y formals)))))))
X (lambda.args-set! (def.rhs def)
X (append added (lambda.args (def.rhs def))))
X (for-each (lambda (call)
X (let ((newargs (map make-variable added)))
X ; The referencing information is made obsolete here!
X (call.args-set! call
X (append newargs (call.args call)))))
X calls)
X (lambda.R-set! L (cons entry (lambda.R L)))
X (lambda.R-set! L2 (remq entry (lambda.R L2)))))
X (lambda.defs-set! L (append (lambda.defs L2) (lambda.defs L)))
X (lambda.defs-set! L2 '())))
X
X (if (and L
X (not (null? (lambda.defs L2)))
X (POLICY:LIFT? L2 L))
X (lift L2 L)))
X
X; Hey, it's a prototype.
X
X(define (POLICY:LIFT? L2 L) #t)
X
X; To do:
X; * Add number-of-argument checking and rest-list elimination
X; to single-assignment-analysis.
END_OF_FILE
if test 20907 -ne `wc -c <'pass2.sch'`; then
echo shar: \"'pass2.sch'\" unpacked with wrong size!
fi
# end of 'pass2.sch'
fi
if test -f 'pass2.tests.sch' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'pass2.tests.sch'\"
else
echo shar: Extracting \"'pass2.tests.sch'\" \(11550 characters\)
sed "s/^X//" >'pass2.tests.sch' <<'END_OF_FILE'
X; Test data.
X
X; MAKE-READABLE strips the referencing information
X; and replaces (begin I) by I.
X
X(define (make-readable exp)
X (case (car exp)
X ((quote) exp)
X ((lambda) `(lambda ,(lambda.args exp)
X ,@(map (lambda (def)
X `(define ,(def.lhs def)
X ,(make-readable (def.rhs def))))
X (lambda.defs exp))
X ,(make-readable (lambda.body exp))))
X ((set!) `(set! ,(assignment.lhs exp)
X ,(make-readable (assignment.rhs exp))))
X ((if) `(if ,(make-readable (if.test exp))
X ,(make-readable (if.then exp))
X ,(make-readable (if.else exp))))
X ((begin) (if (variable? exp)
X (variable.name exp)
X `(begin ,@(map make-readable (begin.exprs exp)))))
X (else `(,(make-readable (call.proc exp))
X ,@(map make-readable (call.args exp))))))
X
X; MAKE-UNREADABLE does the reverse.
X; It assumes there are no internal definitions.
X
X(define (make-unreadable exp)
X (cond ((symbol? exp) (list 'begin exp))
X ((pair? exp)
X (case (car exp)
X ((quote) exp)
X ((lambda) (list 'lambda
X (cadr exp)
X '(begin)
X '(() ())
X (make-unreadable (cons 'begin (cddr exp)))))
X ((set!) (list 'set! (cadr exp) (make-unreadable (caddr exp))))
X ((if) (list 'if
X (make-unreadable (cadr exp))
X (make-unreadable (caddr exp))
X (if (= (length exp) 3)
X (list 'quote #!unspecified)
X (make-unreadable (cadddr exp)))))
X ((begin) (if (= (length exp) 2)
X (make-unreadable (cadr exp))
X (cons 'begin (map make-unreadable (cdr exp)))))
X (else (map make-unreadable exp))))
X (else (list 'quote exp))))
X
X; ANNOTATE takes an expression in the format accepted by pass 2
X; and returns a copy of the expression with freshly computed
X; referencing and free variable information.
X
X(define (annotate exp)
X
X ; (f x e np) returns a copy of the expression x, using the environment e
X ; to accumulate referencing information and the notepad np to accumulate
X ; free variable information.
X ;
X ; The environment e has the form
X ; (( ) ...)
X ; so the operations on R-tables can be used on environments.
X
X (define (f x e np)
X (case (car x)
X ((quote) (list 'quote (cadr x)))
X ((begin) (if (variable? x)
X (let* ((name (variable.name x))
X (var (make-variable name))
X (entry (R-entry e name)))
X (notepad-var-add! np name)
X (if entry
X (R-entry.references-set!
X entry
X (cons var (R-entry.references entry))))
X var)
X (cons 'begin
X (map (lambda (x) (f x e np))
X (begin.exprs x)))))
X ((lambda) (let* ((entries
X (map (lambda (name) (make-R-entry name '() '() '()))
X (append (map def.lhs (lambda.defs x))
X (make-null-terminated
X (lambda.args x)))))
X (e2 (append entries e))
X (newnotepad (make-notepad x))
X (newdefs (map (lambda (def)
X (list 'define
X (def.lhs def)
X (f (def.rhs def) e2 newnotepad)))
X (lambda.defs x)))
X (y (f (lambda.body x) e2 newnotepad)))
X (list 'lambda
X (copy (lambda.args x))
X (cons 'begin newdefs)
X (list 'quote
X (list entries
X (union (notepad.vars newnotepad)
X (apply union
X (map (lambda (formals free)
X (difference free formals))
X (map make-null-terminated
X (map lambda.args
X (map def.rhs newdefs)))
X (map lambda.F
X (map def.rhs newdefs)))))))
X y)))
X ((set!) (let ((y (list 'set!
X (assignment.lhs x)
X (f (assignment.rhs x) e np)))
X (entry (R-entry e (assignment.lhs x))))
X (if entry
X (R-entry.assignments-set! entry
X (cons y (R-entry.assignments entry))))
X y))
X ((if) (list 'if
X (f (if.test x) e np)
X (f (if.then x) e np)
X (f (if.else x) e np)))
X (else (let ((proc (f (call.proc x) e np))
X (args (map (lambda (y) (f y e np)) (call.args x))))
X (let ((y (make-call proc args)))
X (if (variable? proc)
X (let ((entry (R-entry e (variable.name proc))))
X (if entry
X (R-entry.calls-set! entry
X (cons y (R-entry.calls entry))))))
X y)))))
X (f exp '() (make-notepad #f)))
X
X; Copies a list structure, preserving sharing relationships.
X
X(define (copy x)
X (define (copy x e k)
X (cond ((not (pair? x))
X (k x e))
X ((assq x e)
X (k (cdr (assq x e)) e))
X (else (let* ((p (cons '* '*))
X (e2 (cons (cons x p) e)))
X (copy (car x)
X e2
X (lambda (y e3)
X (set-car! p y)
X (copy (cdr x)
X e3
X (lambda (y e4)
X (set-cdr! p y)
X (k p e4)))))))))
X (copy x '() (lambda (x e) x)))
X
X(define (f x)
X (pretty-print (make-readable x))
X (let ((y (pass2 x)))
X (pretty-print (make-readable y))
X (pretty-print y)))
X
X; (define (loop n)
X; (if (zero? n)
X; 'done
X; (loop (- n 2))))
X
X(define (test0)
X (f (annotate
X (make-unreadable
X '(set! loop
X (lambda (z)
X ((lambda (loop)
X (begin
X (set! loop
X (lambda (n)
X (if (zero? n) 'done (loop (- n 1)))))
X ((lambda () (loop z)))))
X #!unspecified)))))))
X
X; (define (loop n)
X; (set! n (+ n 1))
X; (if (zero? n)
X; 'done
X; (loop (- n 2))))
X
X(define (test1)
X (f (annotate
X (make-unreadable
X '(set! loop
X (lambda (z)
X ((lambda (loop)
X (begin
X (set! loop
X (lambda (n)
X (begin (set! n (1+ n))
X (if (zero? n) 'done (loop (- n 2))))))
X ((lambda () (loop z)))))
X #!unspecified)))))))
X
X; (define (reverse x)
X; (define (loop x y)
X; (if (null? x)
X; y
X; (loop (cdr x) (cons (car x) y))))
X; (loop x '()))
X
X(define (test2)
X (f (annotate
X (make-unreadable
X '(set! rev
X (lambda (z)
X ((lambda (reverse)
X (begin
X (set! reverse
X (lambda (w)
X ((lambda (loop)
X (begin
X (set! loop
X (lambda (x y)
X (if (null? x)
X y
X (loop (cdr x)
X (cons (car x) y)))))
X ((lambda ()
X (loop w '())))))
X #!unspecified)))
X ((lambda ()
X (reverse z)))))
X #!unspecified)))))))
X
X(define (test3) #t)
X
X; (define (length x)
X; (do ((x x (cdr x))
X; (n 0 (+ n 1)))
X; ((null? x) n)))
X
X(define (test4)
X (f (annotate
X (make-unreadable
X '(set! len
X (lambda (z)
X ((lambda (length)
X (begin
X (set! length
X (lambda (w)
X ((lambda (DO18)
X (begin
X (set! DO18
X (lambda (x n)
X (if (null? x)
X n
X (DO18 (cdr x) (1+ n)))))
X ((lambda ()
X (DO18 w 0)))))
X #!unspecified)))
X ((lambda ()
X (length z)))))
X #!unspecified)))))))
X
X; (define (ip v1 v2)
X; (define (loop i sum)
X; (if (negative? i)
X; sum
X; (loop (- i 1)
X; (+ sum (* (vector-ref v1 i)
X; (vector-ref v2 i))))))
X; (define n (vector-length v1))
X; (if (= n (vector-length v2))
X; (loop (- n 1) 0)
X; (error ...)))
X
X(define (test5)
X (f (annotate
X (make-unreadable
X '(set! ip
X (lambda (z1 z2)
X ((lambda (ip)
X (begin
X (set! ip
X (lambda (v1 v2)
X ((lambda (loop n)
X (begin
X (set! loop
X (lambda (i sum)
X (if (> 0 i)
X sum
X (loop (- i 1)
X (+ sum
X (* (vector-ref v1 i)
X (vector-ref v2
X i)))))))
X (set! n (vector-length v1))
X ((lambda ()
X (if (= n (vector-length v2))
X (loop (- n 1) 0)
X (error ...))))))
X #!unspecified
X #!unspecified)))
X ((lambda ()
X (ip z1 z2)))))
X #!unspecified)))))))
END_OF_FILE
if test 11550 -ne `wc -c <'pass2.tests.sch'`; then
echo shar: \"'pass2.tests.sch'\" unpacked with wrong size!
fi
# end of 'pass2.tests.sch'
fi
echo shar: End of shell archive.
exit 0