From: Chris Hanson Date: Tue, 8 Dec 1987 13:56:09 +0000 (+0000) Subject: Major redesign of front end of compiler. Continuations are now X-Git-Tag: 20090517-FFI~13003 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=669f7e7d5a8fbff9d359b1fb65cd1b5da8cdb8b4;p=mit-scheme.git Major redesign of front end of compiler. Continuations are now modeled more exactly by means of a CPS-style analysis. Poppers have been flushed in favor of dynamic links, and optimizations have been added that eliminate the use of static and dynamic links in many cases. --- diff --git a/v7/src/compiler/rtlopt/rcse1.scm b/v7/src/compiler/rtlopt/rcse1.scm index b96aefb87..87a1be6ea 100644 --- a/v7/src/compiler/rtlopt/rcse1.scm +++ b/v7/src/compiler/rtlopt/rcse1.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse1.scm,v 1.114 1987/09/03 05:12:54 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse1.scm,v 4.1 1987/12/08 13:55:03 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -41,41 +41,54 @@ MIT in each case. |# (define *branch-queue*) (define (common-subexpression-elimination rgraphs) - (with-new-node-marks - (lambda () - (for-each cse-rgraph rgraphs)))) + (with-new-node-marks (lambda () (for-each cse-rgraph rgraphs)))) (define (cse-rgraph rgraph) (fluid-let ((*current-rgraph* rgraph) (*next-quantity-number* 0) (*initial-queue* (make-queue)) (*branch-queue* '())) - (for-each (lambda (edge) - (enqueue! *initial-queue* (edge-right-node edge))) + (for-each (lambda (edge) (enqueue! *initial-queue* (edge-right-node edge))) (rgraph-initial-edges rgraph)) (fluid-let ((*register-tables* (register-tables/make (rgraph-n-registers rgraph))) - (*hash-table*)) + (*hash-table*) + (*stack-offset*) + (*stack-reference-quantities*)) (continue-walk)))) (define (continue-walk) (cond ((not (null? *branch-queue*)) (let ((entry (car *branch-queue*))) (set! *branch-queue* (cdr *branch-queue*)) - (set! *register-tables* (caar entry)) - (set! *hash-table* (cdar entry)) + (let ((state (car entry))) + (set! *register-tables* (state/register-tables state)) + (set! *hash-table* (state/hash-table state)) + (set! *stack-offset* (state/stack-offset state)) + (set! *stack-reference-quantities* + (state/stack-reference-quantities state))) (walk-bblock (cdr entry)))) ((not (queue-empty? *initial-queue*)) - (state:reset!) + (state/reset!) (walk-bblock (dequeue! *initial-queue*))))) -(define (state:reset!) - (register-tables/reset! *register-tables*) - (set! *hash-table* (make-hash-table))) +(define-structure (state (type vector) (conc-name state/)) + (register-tables false read-only true) + (hash-table false read-only true) + (stack-offset false read-only true) + (stack-reference-quantities false read-only true)) -(define (state:get) - (cons (register-tables/copy *register-tables*) - (hash-table-copy *hash-table*))) +(define (state/reset!) + (register-tables/reset! *register-tables*) + (set! *hash-table* (make-hash-table)) + (set! *stack-offset* 0) + (set! *stack-reference-quantities* '())) + +(define (state/get) + (make-state (register-tables/copy *register-tables*) + (hash-table-copy *hash-table*) + *stack-offset* + (list-copy *stack-reference-quantities*))) (define (walk-bblock bblock) (define (loop rinst) @@ -104,7 +117,7 @@ MIT in each case. |# (begin (if (node-previous>1? alternative) (enqueue! *initial-queue* alternative) (set! *branch-queue* - (cons (cons (state:get) alternative) + (cons (cons (state/get) alternative) *branch-queue*))) (walk-bblock consequent))) (walk-next consequent)) @@ -116,7 +129,7 @@ MIT in each case. |# (and bblock (not (node-marked? bblock)))) (define (walk-next bblock) - (if (node-previous>1? bblock) (state:reset!)) + (if (node-previous>1? bblock) (state/reset!)) (walk-bblock bblock)) (define (define-cse-method type method) @@ -134,59 +147,60 @@ MIT in each case. |# statement (lambda (volatile? insert-source!) (let ((address (rtl:assign-address statement))) - (if (rtl:register? address) - (begin - (register-expression-invalidate! address) - (if (and (not volatile?) - (not (rtl:machine-register-expression? - (rtl:assign-expression statement))) - ;; This is a kludge. If the address is the - ;; frame pointer, then the source is the stack - ;; pointer. If this is not done then some of - ;; the references to stack locations use the - ;; stack pointer instead of the frame pointer. - ;; This is not a bug but I want the stack - ;; addressing to be uniform for now. -- cph - (not (interpreter-frame-pointer? address))) - (insert-register-destination! address (insert-source!)))) + (cond ((rtl:register? address) + (register-expression-invalidate! address) + (if (and (not volatile?) + (not (rtl:machine-register-expression? + (rtl:assign-expression statement)))) + (insert-register-destination! address (insert-source!)))) + ((stack-reference? address) + (stack-reference-invalidate! address) + (if (not volatile?) + (insert-stack-destination! address (insert-source!)))) + (else - (let ((address (expression-canonicalize address))) - (rtl:set-assign-address! statement address) - (full-expression-hash address - (lambda (hash volatile?* in-memory?*) - (let ((memory-invalidate! - (cond ((and (memq (rtl:expression-type address) - '(PRE-INCREMENT POST-INCREMENT)) - (or (interpreter-stack-pointer? - (rtl:address-register address)) - (interpreter-free-pointer? - (rtl:address-register address)))) - (lambda () - (register-expression-invalidate! - (rtl:address-register address)))) - ((expression-address-varies? address) - (lambda () - (hash-table-delete-class! - element-in-memory?))) - (else - (lambda () - (hash-table-delete! - hash - (hash-table-lookup hash address)) - (hash-table-delete-class! - element-address-varies?)))))) - (cond (volatile?* (memory-invalidate!)) - ((not volatile?) - (let ((address - (find-cheapest-expression address hash - false))) - (let ((element (insert-source!))) - (memory-invalidate!) - (insert-memory-destination! - address - element - (modulo (+ (symbol-hash 'ASSIGN) hash) - n-buckets))))))))))))))) + (let ((address (expression-canonicalize address))) + (rtl:set-assign-address! statement address) + (full-expression-hash address + (lambda (hash volatile?* in-memory?*) + (let ((memory-invalidate! + (cond ((stack-push/pop? address) + (lambda () 'DONE)) + ((and (memq (rtl:expression-type address) + '(PRE-INCREMENT POST-INCREMENT)) + (interpreter-free-pointer? + (rtl:address-register address))) + (lambda () + (register-expression-invalidate! + (rtl:address-register address)))) + ((expression-address-varies? address) + (lambda () + (hash-table-delete-class! + element-in-memory?))) + (else + (lambda () + (hash-table-delete! + hash + (hash-table-lookup hash address)) + (hash-table-delete-class! + element-address-varies?)))))) + (cond (volatile?* (memory-invalidate!)) + ((not volatile?) + (let ((address + (find-cheapest-expression address hash + false))) + (let ((element (insert-source!))) + (memory-invalidate!) + (insert-memory-destination! + address + element + (modulo (+ (symbol-hash 'ASSIGN) hash) + (hash-table-size)))))))))) + ;; **** Kludge. Works only because stack-pointer + ;; gets used in very fixed way by code generator. + (if (stack-push/pop? address) + (stack-pointer-adjust! + (rtl:address-number address)))))))))) (define (trivial-action volatile? insert-source!) (if (not volatile?) @@ -219,7 +233,7 @@ MIT in each case. |# (define (method/noop statement) 'DONE) -(define-cse-method 'RETURN method/noop) +(define-cse-method 'POP-RETURN method/noop) (define-cse-method 'PROCEDURE-HEAP-CHECK method/noop) (define-cse-method 'CONTINUATION-HEAP-CHECK method/noop) (define-cse-method 'INVOCATION:APPLY method/noop) @@ -229,18 +243,19 @@ MIT in each case. |# (define-cse-method 'INVOCATION:SPECIAL-PRIMITIVE method/noop) (define-cse-method 'INVOCATION:UUO-LINK method/noop) -(define (method/invalidate-stack statement) +(define (method/trash-stack statement) + (stack-invalidate!) (stack-pointer-invalidate!)) -(define-cse-method 'SETUP-LEXPR method/invalidate-stack) -(define-cse-method 'MESSAGE-SENDER:VALUE method/invalidate-stack) -(define-cse-method 'MESSAGE-RECEIVER:CLOSURE method/invalidate-stack) -(define-cse-method 'MESSAGE-RECEIVER:STACK method/invalidate-stack) -(define-cse-method 'MESSAGE-RECEIVER:SUBPROBLEM method/invalidate-stack) +(define-cse-method 'SETUP-LEXPR method/trash-stack) +(define-cse-method 'INVOCATION-PREFIX:MOVE-FRAME-UP method/trash-stack) +(define-cse-method 'INVOCATION-PREFIX:DYNAMIC-LINK method/trash-stack) (define-cse-method 'INTERPRETER-CALL:ENCLOSE (lambda (statement) - (stack-pointer-invalidate!) + (let ((n (rtl:interpreter-call:enclose-size statement))) + (stack-region-invalidate! 0 n) + (stack-pointer-adjust! n)) (expression-invalidate! (interpreter-register:enclose)))) (define-cse-method 'INVOCATION:CACHE-REFERENCE diff --git a/v7/src/compiler/rtlopt/rcse2.scm b/v7/src/compiler/rtlopt/rcse2.scm index cd0459728..9ad3b58ad 100644 --- a/v7/src/compiler/rtlopt/rcse2.scm +++ b/v7/src/compiler/rtlopt/rcse2.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse2.scm,v 1.1 1987/06/09 19:56:56 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse2.scm,v 4.1 1987/12/08 13:55:35 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -75,12 +75,19 @@ MIT in each case. |# (element-first-value element*))))) (define (expression-canonicalize expression) - (if (rtl:register? expression) - (or (register-expression - (quantity-first-register - (get-register-quantity (rtl:register-number expression)))) - expression) - (rtl:map-subexpressions expression expression-canonicalize))) + (cond ((rtl:register? expression) + (or (register-expression + (quantity-first-register + (get-register-quantity (rtl:register-number expression)))) + expression)) + ((stack-reference? expression) + (let ((register + (quantity-first-register + (stack-reference-quantity expression)))) + (or (and register (register-expression register)) + expression))) + (else + (rtl:map-subexpressions expression expression-canonicalize)))) ;;;; Invalidation @@ -97,9 +104,8 @@ MIT in each case. |# (define (expression-address-varies? expression) (if (memq (rtl:expression-type expression) '(OFFSET PRE-INCREMENT POST-INCREMENT)) - (let ((expression (rtl:address-register expression))) - (not (or (= regnum:regs-pointer (rtl:register-number expression)) - (= regnum:frame-pointer (rtl:register-number expression))))) + (not (= regnum:regs-pointer + (rtl:register-number (rtl:address-register expression)))) (rtl:any-subexpression? expression expression-address-varies?))) (define (expression-invalidate! expression) @@ -111,9 +117,6 @@ MIT in each case. |# (lambda (element) (expression-refers-to? (element-expression element) expression))))) -(define-integrable (stack-pointer-invalidate!) - (register-expression-invalidate! (interpreter-stack-pointer))) - (define (register-expression-invalidate! expression) ;; Invalidate a register expression. These expressions are handled ;; specially for efficiency -- the register is marked invalid but we @@ -162,10 +165,19 @@ MIT in each case. |# (let ((expression (element-expression class))) (cond ((rtl:register? expression) (register-equivalence! - (get-register-quantity (rtl:register-number expression))))))) + (get-register-quantity (rtl:register-number expression)))) + ((stack-reference? expression) + (register-equivalence! + (stack-reference-quantity expression)))))) (set-element-in-memory?! (hash-table-insert! (expression-hash expression) expression class) false))) + +(define (insert-stack-destination! expression element) + (set-element-in-memory?! (hash-table-insert! (expression-hash expression) + expression + (element->class element)) + false)) (define (insert-memory-destination! expression element hash) (let ((class (element->class element))) @@ -255,8 +267,14 @@ MIT in each case. |# (quantity-number (get-register-quantity (rtl:register-number expression)))) ((OFFSET) - (set! hash-arg-in-memory? true) - (continue expression)) + ;; Note that stack-references do not get treated as + ;; memory for purposes of invalidation. This is because + ;; (supposedly) no one ever accesses the stack directly + ;; except the compiler's output, which is explicit. + (if (interpreter-stack-pointer? (rtl:offset-register expression)) + (quantity-number (stack-reference-quantity expression)) + (begin (set! hash-arg-in-memory? true) + (continue expression)))) ((PRE-INCREMENT POST-INCREMENT) (set! hash-arg-in-memory? true) (set! do-not-record? true) @@ -272,4 +290,6 @@ MIT in each case. |# (else (hash object)))))) (let ((hash (loop expression))) - (receiver (modulo hash n-buckets) do-not-record? hash-arg-in-memory?)))) \ No newline at end of file + (receiver (modulo hash (hash-table-size)) + do-not-record? + hash-arg-in-memory?)))) \ No newline at end of file diff --git a/v7/src/compiler/rtlopt/rcseep.scm b/v7/src/compiler/rtlopt/rcseep.scm index 43d667218..f4be81545 100644 --- a/v7/src/compiler/rtlopt/rcseep.scm +++ b/v7/src/compiler/rtlopt/rcseep.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcseep.scm,v 1.5 1987/05/18 23:26:09 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcseep.scm,v 4.1 1987/12/08 13:56:02 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -47,10 +47,13 @@ MIT in each case. |# ((REGISTER) (register-equivalent? x y)) ((OFFSET) - (and (register-equivalent? (rtl:offset-register x) - (rtl:offset-register y)) - (= (rtl:offset-number x) - (rtl:offset-number y)))) + (let ((rx (rtl:offset-register x))) + (and (register-equivalent? rx (rtl:offset-register y)) + (if (interpreter-stack-pointer? rx) + (eq? (stack-reference-quantity x) + (stack-reference-quantity y)) + (= (rtl:offset-number x) + (rtl:offset-number y)))))) (else (rtl:match-subexpressions x y loop)))))) diff --git a/v7/src/compiler/rtlopt/rcseht.scm b/v7/src/compiler/rtlopt/rcseht.scm index c4a490bc7..3263a5c4e 100644 --- a/v7/src/compiler/rtlopt/rcseht.scm +++ b/v7/src/compiler/rtlopt/rcseht.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcseht.scm,v 1.3 1987/05/07 00:18:15 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcseht.scm,v 4.1 1987/12/08 13:55:52 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -37,31 +37,46 @@ MIT in each case. |# (declare (usual-integrations)) -(define n-buckets 31) - (define (make-hash-table) - (make-vector n-buckets false)) + (make-vector 31 false)) (define *hash-table*) +(define-integrable (hash-table-size) + (vector-length *hash-table*)) + (define-integrable (hash-table-ref hash) (vector-ref *hash-table* hash)) (define-integrable (hash-table-set! hash element) (vector-set! *hash-table* hash element)) -(define element-tag (make-vector-tag false 'ELEMENT)) -(define element? (tagged-vector-predicate element-tag)) - -(define-vector-slots element 1 - expression cost in-memory? - next-hash previous-hash - next-value previous-value first-value - copy-cache) - -(define (make-element expression) - (vector element-tag expression false false false false false false false - false)) +(define-structure (element + (constructor %make-element) + (constructor make-element (expression)) + (print-procedure (standard-unparser 'ELEMENT false))) + (expression false read-only true) + (cost false) + (in-memory? false) + (next-hash false) + (previous-hash false) + (next-value false) + (previous-value false) + (first-value false) + (copy-cache false)) + +(set-type-object-description! + element + (lambda (element) + `((ELEMENT-EXPRESSION ,(element-expression element)) + (ELEMENT-COST ,(element-cost element)) + (ELEMENT-IN-MEMORY? ,(element-in-memory? element)) + (ELEMENT-NEXT-HASH ,(element-next-hash element)) + (ELEMENT-PREVIOUS-HASH ,(element-previous-hash element)) + (ELEMENT-NEXT-VALUE ,(element-next-value element)) + (ELEMENT-PREVIOUS-VALUE ,(element-previous-value element)) + (ELEMENT-FIRST-VALUE ,(element-first-value element)) + (ELEMENT-COPY-CACHE ,(element-copy-cache element))))) (define (hash-table-lookup hash expression) (define (loop element) @@ -144,16 +159,16 @@ MIT in each case. |# (define (per-element element previous) (and element (let ((element* - (vector element-tag - (element-expression element) - (element-cost element) - (element-in-memory? element) - (per-element (element-next-hash element) element) - previous - (element-next-value element) - (element-previous-value element) - (element-first-value element) - element))) + (%make-element (element-expression element) + (element-cost element) + (element-in-memory? element) + (per-element (element-next-hash element) + element) + previous + (element-next-value element) + (element-previous-value element) + (element-first-value element) + element))) (set-element-copy-cache! element element*) element*))) (if (null? elements) diff --git a/v7/src/compiler/rtlopt/rcserq.scm b/v7/src/compiler/rtlopt/rcserq.scm index a6e464cde..1adc2ab58 100644 --- a/v7/src/compiler/rtlopt/rcserq.scm +++ b/v7/src/compiler/rtlopt/rcserq.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcserq.scm,v 1.4 1987/08/07 17:07:33 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcserq.scm,v 4.1 1987/12/08 13:55:45 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -37,33 +37,35 @@ MIT in each case. |# (declare (usual-integrations)) -(define quantity-tag (make-vector-tag false 'QUANTITY)) -(define quantity? (tagged-vector-predicate quantity-tag)) -(define-vector-slots quantity 1 number first-register last-register) +(define-structure (quantity + (copier quantity-copy) + (print-procedure (standard-unparser 'QUANTITY false))) + (number false read-only true) + (first-register false) + (last-register false)) + +(set-type-object-description! + quantity + (lambda (quantity) + `((QUANTITY-NUMBER ,(quantity-number quantity)) + (QUANTITY-FIRST-REGISTER ,(quantity-first-register quantity)) + (QUANTITY-LAST-REGISTER ,(quantity-last-register quantity))))) -(define *next-quantity-number*) +(define (get-register-quantity register) + (or (register-quantity register) + (let ((quantity (new-quantity register))) + (set-register-quantity! register quantity) + quantity))) + +(define (new-quantity register) + (make-quantity (generate-quantity-number) register register)) (define (generate-quantity-number) (let ((n *next-quantity-number*)) (set! *next-quantity-number* (1+ *next-quantity-number*)) n)) -(define (make-quantity number first-register last-register) - (vector quantity-tag number first-register last-register)) - -(define (new-quantity register) - (make-quantity (generate-quantity-number) register register)) - -(define (quantity-copy quantity) - (make-quantity (quantity-number quantity) - (quantity-first-register quantity) - (quantity-last-register quantity))) - -(define (get-register-quantity register) - (or (register-quantity register) - (let ((quantity (new-quantity register))) - (set-register-quantity! register quantity) - quantity))) +(define *next-quantity-number*) (define (register-tables/make n-registers) (vector (make-vector n-registers) diff --git a/v7/src/compiler/rtlopt/rcsesr.scm b/v7/src/compiler/rtlopt/rcsesr.scm index 0871bb7e6..3e934c93a 100644 --- a/v7/src/compiler/rtlopt/rcsesr.scm +++ b/v7/src/compiler/rtlopt/rcsesr.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcsesr.scm,v 1.1 1987/03/19 00:49:12 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcsesr.scm,v 4.1 1987/12/08 13:56:09 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -33,13 +33,16 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; RTL Common Subexpression Elimination: Stack References -;;; Based on the GNU C Compiler (declare (usual-integrations)) (define *stack-offset*) (define *stack-reference-quantities*) +(define (stack-push/pop? expression) + (and (memq (rtl:expression-type expression) '(PRE-INCREMENT POST-INCREMENT)) + (interpreter-stack-pointer? (rtl:address-register expression)))) + (define (stack-reference? expression) (and (eq? (rtl:expression-type expression) 'OFFSET) (interpreter-stack-pointer? (rtl:address-register expression))))