#| -*-Scheme-*-
-$Id: coerce.scm,v 1.1 1995/03/20 02:44:31 adams Exp $
+$Id: coerce.scm,v 1.2 1995/03/23 04:17:10 adams Exp $
Copyright (c) 1995 Massachusetts Institute of Technology
At the moment it is pretty naïve about inserting this kind of code.
For the right kind of program (sort, feeley-like closure compiler) it
-wins by 8-10%. This could be even better if
-COERCE-TO-COMPILED-PROCEDURE understood arity dispatched entities
-(merely a matter of extending the primitive).
-
-It loses big-time (up to a factor of 2) on other kinds of program
-because it is stupid:
-
- . It does this transformation for all lambda-bindings that are used
- in operator position like F, including those which are really
- LET-bindings. It should only do this if the call site in in a
- lambda expression that will be a loop or a closure - i.e. has
- potential for many repeated executions.
-
- . The new binding is inserted as high as possible in the lambda with
- the original binding. In code which has branches with calls to F
- with different number of arguments in each branch (like the system
- code for MAP and FOR-EACH) this is a disaster as one of the
- coercions is guaranteed to cons a trampoline. The coercion needs
- to be restricted to the branch where it applies.
-
- . The coercion could be much better engineered - a quick check to
- prevent the call to the primitive in the `no-op' case would be a
- big benefit, and perhaps so would a preserving call or hook or
- compiler utility for the out-of-line case.
-
- . The HP-PA LAP code for INVOCATION:REGISTER with a continuation
- could be one insn shorter.
+wins by about 10%.
|#
(coerce/env/lookup*! env name `(LOOKUP ,name) 'ORDINARY))
(define-coercer LAMBDA (lambda-list body)
+ (coerce/lambda* env lambda-list body 'LAMBDA))
+
+(define (coerce/lambda* env lambda-list body env-kind)
(let ((env* (coerce/env/make
+ env-kind
env
(map coerce/binding/make (lambda-list->names lambda-list)))))
(let ((body* (coerce/expr env* body)))
- (coerce/lambda/finish! env* lambda-list body*))))
-
-(define coerce/lambda/finish!
+ (set-coerce/env/form! env* body*)
+ (coerce/lambda/finish! env*)
+ `(LAMBDA ,lambda-list ,body*))))
+
+(define (coerce/lambda/finish! env)
+ (let binding-loop ((bindings (coerce/env/bindings env)))
+ (if (null? bindings)
+ 'done
+ (let* ((binding (car bindings))
+ (name (coerce/binding/name binding)))
+ (let ref-loop ((refs (coerce/binding/operator-refs binding))
+ (arity-map '()))
+ (if (null? refs)
+ (begin
+ (for-each (lambda (arity.refs)
+ (coerce/rewrite! env name
+ (car arity.refs)
+ (cdr arity.refs)))
+ arity-map)
+ (binding-loop (cdr bindings)))
+ (let* ((ref (car refs))
+ (text (coerce/reference/form ref))
+ (len (length (call/operands text)))
+ (arity.refs (assv len arity-map)))
+ (cond (arity.refs
+ (set-cdr! arity.refs
+ (cons ref (cdr arity.refs)))
+ (ref-loop (cdr refs) arity-map))
+ (else
+ (ref-loop (cdr refs)
+ (cons (list len ref) arity-map)))))))))))
+
+(define (coerce/rewrite! env name arity refs)
+ ;; Find highest least
+ (define (same-extent? ref)
+ (let loop ((env* (coerce/reference/env ref)))
+ (cond ((eq? env* env) #T)
+ ((eq? (coerce/env/kind env*) 'LAMBDA) #F)
+ (else (loop (coerce/env/parent env*))))))
+ (define (common-env e1 e2)
+ (cond ((eq? e1 e2) e1)
+ ((< (coerce/env/depth e1) (coerce/env/depth e2))
+ (common-env e1 (coerce/env/parent e2)))
+ ((> (coerce/env/depth e1) (coerce/env/depth e2))
+ (common-env (coerce/env/parent e1) e2))
+ (else
+ (common-env (coerce/env/parent e1) (coerce/env/parent e2)))))
+ (define (maximize-extent env*)
+ (let loop ((chosen env*) (env* env*))
+ (cond ((eq? env* env) chosen)
+ ((eq? (coerce/env/kind env*) 'LAMBDA)
+ (loop (coerce/env/parent env*) (coerce/env/parent env*)))
+ (else
+ (loop chosen (coerce/env/parent env*))))))
+ (define (within? env base-env)
+ (cond ((eq? env base-env) #T)
+ ((< (coerce/env/depth env) (coerce/env/depth base-env)) #F)
+ (else (within? (coerce/env/parent env) base-env))))
+ (call-with-values
+ (lambda ()
+ (list-split refs same-extent?))
+ (lambda (same-extent other-extent)
+ (cond
+ ((> arity 120) 'cant)
+ ((null? other-extent) 'not-worth-while)
+ (else
+ (let ((common-env
+ (reduce common-env #F (map coerce/reference/env other-extent))))
+ (let* ((coercion-env (maximize-extent common-env))
+ (name* (variable/rename name))
+ (form (coerce/env/form coercion-env))
+ (body (form/preserve form)))
+ (form/rewrite! form
+ (bind name* (coerce/make-coercion name arity) body))
+ (let loop ((refs refs) (replaced 0) (kept 0))
+ (if (null? refs)
+ (if compiler:guru?
+ (let ((t error-irritant/noise))
+ (internal-warning "strength reduced call"
+ (t "\n;Reduced call to") name
+ (t " with") arity
+ (t " args. Operators replaced:")
+ replaced
+ (t ", unchanged:")
+ kept)))
+ (let ((ref (car refs)))
+ (cond ((within? (coerce/reference/env ref)
+ coercion-env)
+ (coerce/rewrite-call!
+ (coerce/reference/form ref)
+ arity name*)
+ (loop (cdr refs) (+ replaced 1) kept))
+ (else
+ 'leave-it-alone
+ (loop (cdr refs) replaced (+ kept 1))))))))))))))
+
+(define coerce/make-coercion
(let ((coerce-to-compiled
(make-primitive-procedure 'COERCE-TO-COMPILED-PROCEDURE)))
- (lambda (env lambda-list body)
- (define (rewrite-call! call arity coerced-operator)
- ;;(form/rewrite! (call/operator call)
- ;; `(LOOKUP ,coerced-operator))
- (form/rewrite! call
- `(CALL ',%internal-apply-unchecked
- ,(call/continuation call)
- ',arity
- (LOOKUP ,coerced-operator)
- ,@(call/operands call))))
- (define (make-coercion name len)
- `(CALL ',coerce-to-compiled '#F (LOOKUP ,name) ',len)
- `(IF (IF (CALL ',%compiled-entry? '#F (LOOKUP ,name))
- (CALL ',%compiled-entry-maximum-arity? '#F
- ',(+ len 1)
- (LOOKUP ,name))
- '#F)
- (LOOKUP ,name)
- (CALL ',coerce-to-compiled '#F (LOOKUP ,name) ',len)))
- (let ((names '())
- (values '()))
- (let loop ((bindings (coerce/env/bindings env)))
- (if (null? bindings)
- `(LAMBDA ,lambda-list
- ,(if (null? names)
- body
- (bind* names values body)))
- (let* ((binding (car bindings))
- (name (coerce/binding/name binding)))
- (let ref-loop ((refs (coerce/binding/operator-refs binding))
- (arity-map '()))
- (if (null? refs)
- (loop (cdr bindings))
- (let* ((ref (car refs))
- (len (length (call/operands ref)))
- (arity.name (assv len arity-map)))
- (cond (arity.name
- (rewrite-call! (car refs) len (cdr arity.name))
- (ref-loop (cdr refs) arity-map))
- ((<= 0 len 120)
- (let* ((name* (variable/rename name)))
- (rewrite-call! (car refs) len name*)
- (set! names (cons name* names))
- (set! values
- (cons (make-coercion name len)
- values))
- (ref-loop (cdr refs) (cons (cons len name*) arity-map))))
- (else
- (ref-loop (cdr refs) arity-map)))))))))))))
+ (lambda (name len)
+ `(CALL ',coerce-to-compiled '#F (LOOKUP ,name) ',len)
+ `(IF (IF (CALL ',%compiled-entry? '#F (LOOKUP ,name))
+ (CALL ',%compiled-entry-maximum-arity? '#F
+ ',(+ len 1)
+ (LOOKUP ,name))
+ '#F)
+ (LOOKUP ,name)
+ (CALL ',coerce-to-compiled '#F (LOOKUP ,name) ',len)))))
+
+(define (coerce/rewrite-call! call arity coerced-operator)
+ ;;(form/rewrite! (call/operator call)
+ ;; `(LOOKUP ,coerced-operator))
+ (form/rewrite! call
+ `(CALL ',%internal-apply-unchecked
+ ,(call/continuation call)
+ ',arity
+ (LOOKUP ,coerced-operator)
+ ,@(call/operands call))))
(define-coercer LET (bindings body)
- `(LET ,(map (lambda (binding)
- (list (car binding)
- (coerce/expr env (cadr binding))))
- bindings)
- ,(coerce/expr env body)))
+ (let* ((names (map car bindings))
+ (values (map cadr bindings))
+ (inner-env
+ (coerce/env/make 'LET env (map coerce/binding/make names))))
+ (let ((body* (coerce/expr inner-env body)))
+ (set-coerce/env/form! inner-env body*)
+ `(LET ,(map (lambda (name value)
+ (list name (coerce/expr env value)))
+ names values)
+ ,body*))))
(define-coercer LETREC (bindings body)
- `(LETREC ,(map (lambda (binding)
- (list (car binding)
- (coerce/expr env (cadr binding))))
- bindings)
- ,(coerce/expr env body)))
+ (let* ((names (map car bindings))
+ (values (map cadr bindings))
+ (inner-env
+ (coerce/env/make 'LETREC env (map coerce/binding/make names))))
+ (let ((form*
+ `(LETREC ,(map (lambda (name value)
+ (list name (coerce/expr inner-env value)))
+ names values)
+ ,(coerce/expr inner-env body))))
+ (set-coerce/env/form! inner-env form*)
+ form*)))
+
(define-coercer IF (pred conseq alt)
- `(IF ,(coerce/expr env pred)
- ,(coerce/expr env conseq)
- ,(coerce/expr env alt)))
+ (let ((env1 (coerce/env/make 'CONDITIONAL env '()))
+ (env2 (coerce/env/make 'CONDITIONAL env '())))
+ (let ((conseq* (coerce/expr env1 conseq))
+ (alt* (coerce/expr env2 alt)))
+ (set-coerce/env/form! env1 conseq*)
+ (set-coerce/env/form! env2 alt*)
+ `(IF ,(coerce/expr env pred) ,conseq* ,alt*))))
(define-coercer QUOTE (object)
env
`(BEGIN ,@(coerce/expr* env actions)))
\f
(define-coercer CALL (rator cont #!rest rands)
- (define (default)
- `(CALL ,(coerce/expr env rator)
+ (define (default rator*)
+ `(CALL ,rator*
,(coerce/expr env cont)
,@(coerce/expr* env rands)))
(cond ((LAMBDA/? rator)
- ;;`(CALL (LAMBDA ,(lambda/formals rator)
- ;; ,(coerce/expr env (lambda/body rator)))
- ;; ,(coerce/expr env cont)
- ;; ,@(coerce/expr* env rands))
- (default))
+ (default
+ (coerce/lambda* env (lambda/formals rator) (lambda/body rator)
+ 'LET)))
((LOOKUP/? rator)
(let* ((name (lookup/name rator))
- (call `(CALL (LOOKUP ,name) ,(coerce/expr env cont)
- ,@(coerce/expr* env rands))))
- ;;(coerce/env/lookup*! env name call 'OPERATOR))
- ;; This helps us not to trap `non-closed' bindings:
- (coerce/env/lookup*! (coerce/env/parent env) name call 'OPERATOR))
- )
+ (call (default `(LOOKUP ,name))))
+ (coerce/env/lookup*! env name call 'OPERATOR)))
(else
- (default))))
+ (default (coerce/expr env rator)))))
(define (coerce/expr env expr)
(if (not (pair? expr))
\f
+(define (coerce/reference/make env form) (cons form env))
+(define (coerce/reference/form ref) (car ref))
+(define (coerce/reference/env ref) (cdr ref))
+
(define-structure
(coerce/binding
(conc-name coerce/binding/)
(write-char #\space port)
(write-string (symbol-name (coerce/binding/name binding)) port)))))
- (name false read-only true)
+ (name #F read-only true)
(ordinary-refs '() read-only false)
(operator-refs '() read-only false))
(define-structure
(coerce/env
(conc-name coerce/env/)
- (constructor coerce/env/make (parent bindings))
+ (constructor coerce/env/%make)
(print-procedure
(standard-unparser-method 'COERCE/ENV
(lambda (env port)
+ (write-char #\Space port)
+ (write (coerce/env/kind env) port)
+ (write-char #\Space port)
+ (write (coerce/env/depth env) port)
(write-char #\Space port)
(write (map coerce/binding/name (coerce/env/bindings env))
port)))))
(bindings '() read-only true)
(parent #F read-only true)
- ;; FREE-CALLS is used to mark calls to names free in this frame but bound
- ;; in the parent frame. Used to detect mutual recursion in LETREC.
- (free-calls '() read-only false))
-
+ (depth 0 read-only true)
+ ;; kind = LAMBDA | CONDITIONAL | LET
+ (kind #F read-only true)
+ (form #F read-only false))
+
+(define (coerce/env/make kind parent bindings)
+ (coerce/env/%make bindings
+ parent
+ (if parent (+ (coerce/env/depth parent) 1) 0)
+ kind
+ #F))
(define coerce/env/frame-lookup
(association-procedure (lambda (x y) (eq? x y)) coerce/binding/name))
(define (coerce/env/lookup*! env name reference kind)
;; kind = 'OPERATOR, 'ORDINARY
- (let frame-loop ((env env))
- (cond ((not env)
- ;;(free-var-error name)
- reference
+ (let frame-loop ((frame env))
+ (cond ((not frame)
+ (free-var-error name)
+ ;;reference
)
- ((coerce/env/frame-lookup name (coerce/env/bindings env))
+ ((coerce/env/frame-lookup name (coerce/env/bindings frame))
=> (lambda (binding)
- (case kind
- ((OPERATOR)
- (set-coerce/binding/operator-refs!
- binding
- (cons reference (coerce/binding/operator-refs binding))))
- ((ORDINARY)
- (set-coerce/binding/ordinary-refs!
- binding
- (cons reference (coerce/binding/ordinary-refs binding))))
- (else
- (internal-error "coerce/lookup*! bad KIND" kind)))
+ (let ((ref (coerce/reference/make env reference)))
+ (case kind
+ ((OPERATOR)
+ (set-coerce/binding/operator-refs!
+ binding
+ (cons ref (coerce/binding/operator-refs binding))))
+ ((ORDINARY)
+ (set-coerce/binding/ordinary-refs!
+ binding
+ (cons ref (coerce/binding/ordinary-refs binding))))
+ (else
+ (internal-error "coerce/lookup*! bad KIND" kind))))
reference))
- (else (frame-loop (coerce/env/parent env))))))
+ (else (frame-loop (coerce/env/parent frame))))))
projects / mit-scheme.git / commitdiff