From 93c158fdcc334ab33bb42f898d9a86b21620c086 Mon Sep 17 00:00:00 2001 From: Stephen Adams Date: Thu, 23 Mar 1995 04:17:10 +0000 Subject: [PATCH] Changed to be much smarter about where the coercion code should be inserted. Removed comments saying how dumb it was. --- v8/src/compiler/midend/coerce.scm | 328 ++++++++++++++++++------------ 1 file changed, 198 insertions(+), 130 deletions(-) diff --git a/v8/src/compiler/midend/coerce.scm b/v8/src/compiler/midend/coerce.scm index ed025f8d4..7cecd904e 100644 --- a/v8/src/compiler/midend/coerce.scm +++ b/v8/src/compiler/midend/coerce.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -52,33 +52,7 @@ With 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%. |# @@ -103,83 +77,167 @@ because it is stupid: (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 @@ -193,26 +251,20 @@ because it is stupid: `(BEGIN ,@(coerce/expr* env actions))) (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)) @@ -240,6 +292,10 @@ because it is stupid: +(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/) @@ -250,50 +306,62 @@ because it is stupid: (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)))))) -- 2.25.1