From 7718477f115826441d2fea375d9446444d4928e2 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Fri, 14 Jun 1991 21:19:58 +0000 Subject: [PATCH] Change the front end of the compiler to expand calls to general-car-cdr if their second argument is a positive exact integer. Remove the open-coding rule for general-car-cdr. The reason for this change is that the open-coding of general-car-cdr does not work correctly when type checking is turned on. --- v7/src/compiler/fggen/fggen.scm | 150 +++++++++++++++++------------- v7/src/compiler/rtlgen/opncod.scm | 62 +++++------- 2 files changed, 108 insertions(+), 104 deletions(-) diff --git a/v7/src/compiler/fggen/fggen.scm b/v7/src/compiler/fggen/fggen.scm index ba6d71762..04747be6d 100644 --- a/v7/src/compiler/fggen/fggen.scm +++ b/v7/src/compiler/fggen/fggen.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/fggen.scm,v 4.27 1991/05/06 22:38:06 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/fggen.scm,v 4.28 1991/06/14 21:19:42 cph Exp $ Copyright (c) 1988-1991 Massachusetts Institute of Technology @@ -578,73 +578,91 @@ MIT in each case. |# (define (generate/combination block continuation context expression) (scode/combination-components expression (lambda (operator operands) - (if (eq? not operator) - (generate/conditional block continuation context - (scode/make-conditional (car operands) #F #T)) - (let ((make-combination - (lambda (push continuation) - (make-combination - block - (continuation-reference block continuation) - (wrapper/subproblem/value - block - continuation - (make-continuation-debugging-info 'COMBINATION-OPERAND - expression - 0) - (lambda (continuation*) - (cond ((scode/lambda? operator) - (generate/lambda* - block continuation* - context (context/unconditional context) - operator (continuation/known-type continuation) - false)) - ((scode/absolute-reference? operator) - (generate/global-variable block continuation* - context operator)) - (else - (generate/expression block continuation* - context operator))))) - (let loop ((operands operands) (index 1)) - (if (null? operands) - '() - (cons (generate/subproblem/value - block continuation context - (car operands) 'COMBINATION-OPERAND - expression index) - (loop (cdr operands) (1+ index))))) - push)))) - ((continuation/case continuation - (lambda () (make-combination false continuation)) - (lambda () - (if (variable? continuation) - (make-combination false continuation) - (with-reified-continuation block - continuation - scfg*scfg->scfg! - (lambda (push continuation) + (cond ((eq? not operator) + (generate/conditional block continuation context + (scode/make-conditional (car operands) + #F #T))) + ((and (eq? general-car-cdr operator) + (let ((n (cadr operands))) + (and (exact-integer? n) + (positive? n)))) + (generate/expression + block continuation context + (let loop ((expression (car operands)) (n (cadr operands))) + (if (= n 1) + expression + (loop (scode/make-combination + (if (= (remainder n 2) 1) car cdr) + (list expression)) + (quotient n 2)))))) + (else + (let ((make-combination + (lambda (push continuation) + (make-combination + block + (continuation-reference block continuation) + (wrapper/subproblem/value + block + continuation + (make-continuation-debugging-info 'COMBINATION-OPERAND + expression + 0) + (lambda (continuation*) + (cond ((scode/lambda? operator) + (generate/lambda* + block continuation* + context (context/unconditional context) + operator + (continuation/known-type continuation) + false)) + ((scode/absolute-reference? operator) + (generate/global-variable block continuation* + context operator)) + (else + (generate/expression block continuation* + context operator))))) + (let loop ((operands operands) (index 1)) + (if (null? operands) + '() + (cons (generate/subproblem/value + block continuation context + (car operands) 'COMBINATION-OPERAND + expression index) + (loop (cdr operands) (1+ index))))) + push)))) + ((continuation/case continuation + (lambda () (make-combination false continuation)) + (lambda () + (if (variable? continuation) + (make-combination false continuation) + (with-reified-continuation block + continuation + scfg*scfg->scfg! + (lambda (push continuation) + (make-scfg + (cfg-entry-node + (make-combination push continuation)) + (continuation/next-hooks continuation)))))) + (lambda () + (with-reified-continuation block + continuation + scfg*pcfg->pcfg! + (lambda (push continuation) + (scfg*pcfg->pcfg! (make-scfg (cfg-entry-node (make-combination push continuation)) - (continuation/next-hooks continuation)))))) - (lambda () - (with-reified-continuation block - continuation - scfg*pcfg->pcfg! - (lambda (push continuation) - (scfg*pcfg->pcfg! - (make-scfg - (cfg-entry-node (make-combination push continuation)) - (continuation/next-hooks continuation)) - (make-true-test block - (continuation/rvalue continuation)))))) - (lambda () - (with-reified-continuation block - continuation - scfg*subproblem->subproblem! - (lambda (push continuation) - (make-subproblem/canonical - (make-combination push continuation) - continuation))))))))))) + (continuation/next-hooks continuation)) + (make-true-test + block + (continuation/rvalue continuation)))))) + (lambda () + (with-reified-continuation block + continuation + scfg*subproblem->subproblem! + (lambda (push continuation) + (make-subproblem/canonical + (make-combination push continuation) + continuation)))))))))))) ;;;; Assignments diff --git a/v7/src/compiler/rtlgen/opncod.scm b/v7/src/compiler/rtlgen/opncod.scm index 2fd529de1..3f9ed99be 100644 --- a/v7/src/compiler/rtlgen/opncod.scm +++ b/v7/src/compiler/rtlgen/opncod.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.43 1991/06/13 18:59:29 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.44 1991/06/14 21:19:58 cph Exp $ Copyright (c) 1988-1991 Massachusetts Institute of Technology @@ -321,12 +321,33 @@ MIT in each case. |# cleanup (if error-finish (error-finish (rtl:make-fetch register:value)) - (make-null-cfg)))))))) + (make-null-cfg))) + #| + ;; This code is preferable to the above + ;; expression in some circumstances. It + ;; creates a continuation, but the continuation + ;; is left dangling instead of being hooked + ;; back into the subsequent code. This avoids + ;; a merge in the RTL and allows the CSE to do + ;; a better job -- but the cost is that it + ;; creates a continuation that, if invoked, has + ;; unpredictable behavior. + (let ((scfg + (scfg*scfg->scfg! + (generate-primitive primitive-name + expressions + setup + label) + cleanup))) + (make-scfg (cfg-entry-node scfg) '())) + |# + ))))) (let loop ((checks checks)) (if (null? checks) non-error-cfg (pcfg*scfg->scfg! (car checks) - (loop (cdr checks)) error-cfg))))))) + (loop (cdr checks)) + error-cfg))))))) (define (generate-primitive name argument-expressions continuation-setup continuation-label) @@ -653,41 +674,6 @@ MIT in each case. |# (system-ref 'SYSTEM-HUNK3-CXR0 rtl:make-fetch 0) (system-ref 'SYSTEM-HUNK3-CXR1 rtl:make-fetch 1) (system-ref 'SYSTEM-HUNK3-CXR2 rtl:make-fetch 2)) - -(let ((make-fixed-ref - (lambda (name index) - (lambda (combination expressions finish) - (let ((expression (car expressions))) - (open-code:with-checks - combination - (list (open-code:type-check expression (ucode-type pair))) - (finish (rtl:make-fetch (rtl:locative-offset expression index))) - finish - name - expressions)))))) - (let ((car-ref (make-fixed-ref 'CAR 0)) - (cdr-ref (make-fixed-ref 'CDR 1))) - (define-open-coder/value 'GENERAL-CAR-CDR - (filter/positive-integer - (lambda (pattern) - (if (= pattern 1) - (lambda (combination expressions finish) - combination - (finish (car expressions))) - (lambda (combination expressions finish) - (let loop ((pattern pattern) - (expression (car expressions))) - (let ((new-pattern (quotient pattern 2))) - ((if (odd? pattern) car-ref cdr-ref) - combination - (list expression) - (if (= new-pattern 1) - finish - (lambda (expression) - (loop new-pattern expression))))))))) - 1 - '(0) - internal-close-coding-for-type-checks)))) (let ((make-ref (lambda (name type) -- 2.25.1