From: Chris Hanson Date: Sat, 20 Dec 1986 23:49:57 +0000 (+0000) Subject: *** empty log message *** X-Git-Tag: 20090517-FFI~13782 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=919e50888d933523b6740180389d14d2682f3834;p=mit-scheme.git *** empty log message *** --- diff --git a/v7/src/compiler/back/lapgn1.scm b/v7/src/compiler/back/lapgn1.scm index 5b1f45e63..be691477a 100644 --- a/v7/src/compiler/back/lapgn1.scm +++ b/v7/src/compiler/back/lapgn1.scm @@ -37,11 +37,12 @@ ;;;; LAP Code Generation -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn1.scm,v 1.20 1986/12/20 22:52:16 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn1.scm,v 1.21 1986/12/20 23:48:34 cph Exp $ (declare (usual-integrations)) (using-syntax (access compiler-syntax-table compiler-package) +(define *block-start-label*) (define *code-object-label*) (define *code-object-entry*) (define *current-rnode*) @@ -72,17 +73,27 @@ (set! *code-object-entry* rnode) (cgen-rnode rnode))) +(define *cgen-rules* + '()) + +(define (add-statement-rule! pattern result-procedure) + (set! *cgen-rules* + (cons (cons pattern result-procedure) + *cgen-rules*)) + pattern) + (define (cgen-rnode rnode) - (define (cgen-right-node next) - (if (and next (not (node-marked? next))) - (begin (if (node-previous>1? next) - (let ((snode (statement->snode '(NOOP)))) - (set-rnode-lap! snode - (clear-map-instructions - (rnode-register-map rnode))) - (node-mark! snode) - (insert-snode-in-edge! rnode next snode))) - (cgen-rnode next)))) + (define (cgen-right-node edge) + (let ((next (edge-right-node edge))) + (if (and next (not (node-marked? next))) + (begin (if (node-previous>1? next) + (let ((snode (statement->snode '(NOOP)))) + (set-rnode-lap! snode + (clear-map-instructions + (rnode-register-map rnode))) + (node-mark! snode) + (edge-insert-snode! edge snode))) + (cgen-rnode next))))) (node-mark! rnode) ;; LOOP is for easy restart while debugging. (let loop () @@ -100,18 +111,10 @@ (set-rnode-register-map! rnode *register-map*)) (begin (error "CGEN-RNODE: No matching rules" (rnode-rtl rnode)) (loop))))) - ;; **** Works because of kludge in definition of RTL-SNODE. - (cgen-right-node (pnode-consequent rnode)) - (cgen-right-node (pnode-alternative rnode))) - -(define *cgen-rules* - '()) - -(define (add-statement-rule! pattern result-procedure) - (set! *cgen-rules* - (cons (cons pattern result-procedure) - *cgen-rules*)) - pattern) + (if (rtl-snode? rnode) + (cgen-right-node (snode-next-edge rnode)) + (begin (cgen-right-node (pnode-consequent-edge rnode)) + (cgen-right-node (pnode-alternative-edge rnode))))) (define (rnode-input-register-map rnode) (if (or (eq? rnode *code-object-entry*) diff --git a/v7/src/compiler/base/cfg1.scm b/v7/src/compiler/base/cfg1.scm index 689f0ea2e..7210a51c5 100644 --- a/v7/src/compiler/base/cfg1.scm +++ b/v7/src/compiler/base/cfg1.scm @@ -37,7 +37,7 @@ ;;;; Control Flow Graph Abstraction -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg1.scm,v 1.143 1986/12/20 22:51:15 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg1.scm,v 1.144 1986/12/20 23:48:20 cph Exp $ (declare (usual-integrations)) (using-syntax (access compiler-syntax-table compiler-package) @@ -172,7 +172,7 @@ ;;;; Previous Connections (define-integrable (node-previous=0? node) - (edges=0? (node-previous node))) + (edges=0? (node-previous-edges node))) (define (edges=0? edges) (cond ((null? edges) true) @@ -180,7 +180,7 @@ (else (edges=0? (cdr edges))))) (define-integrable (node-previous>0? node) - (edges>0? (node-previous node))) + (edges>0? (node-previous-edges node))) (define (edges>0? edges) (cond ((null? edges) false) @@ -188,20 +188,20 @@ (else (edges>0? (cdr edges))))) (define-integrable (node-previous=1? node) - (edges=1? (node-previous node))) + (edges=1? (node-previous-edges node))) (define (edges=1? edges) (if (null? edges) false - ((if (entry-holder-hook? (car edges)) edges=1? edges=0?) (cdr edges)))) + ((if (edge-left-node (car edges)) edges=0? edges=1?) (cdr edges)))) (define-integrable (node-previous>1? node) - (edges>1? (node-previous node))) + (edges>1? (node-previous-edges node))) (define (edges>1? edges) (if (null? edges) false - ((if (entry-holder-hook? (car edges)) edges>1? edges>0?) (cdr edges)))) + ((if (edge-left-node (car edges)) edges>0? edges>1?) (cdr edges)))) (define-integrable (node-previous-first node) (edges-first-node (node-previous-edges node))) @@ -221,40 +221,32 @@ ;;;; Noops -(define noop-node-tag (make-vector-tag cfg-node-tag 'NOOP)) -(define-vector-slots noop-node 1 previous next) +(define noop-node-tag (make-vector-tag snode-tag 'NOOP)) (define *noop-nodes*) (define-integrable (make-noop-node) - (let ((node (vector noop-node-tag '() false))) + (let ((node (make-snode noop-node-tag))) (set! *noop-nodes* (cons node *noop-nodes*)) node)) (define (delete-noop-nodes!) - (for-each noop-node-delete! *noop-nodes*) + (for-each snode-delete! *noop-nodes*) (set! *noop-nodes* '())) -(define (noop-node-delete! noop-node) - (node-next-replace! noop-node - noop-node-next - (let ((previous (noop-node-previous noop-node))) - (hooks-disconnect! previous noop-node) - previous))) +(define (constant->pcfg value) + ((if value make-true-pcfg make-false-pcfg))) (define (make-false-pcfg) (let ((node (make-noop-node))) (make-pcfg node '() - (list (make-hook node set-noop-node-next!))))) + (list (make-hook node set-snode-next!))))) (define (make-true-pcfg) (let ((node (make-noop-node))) (make-pcfg node - (list (make-hook node set-noop-node-next!)) + (list (make-hook node set-snode-next!)) '()))) - -(define (constant->pcfg value) - ((if value make-true-pcfg make-false-pcfg))) ;;;; Miscellaneous @@ -343,7 +335,7 @@ (define-integrable cfg-null? false?) (define-integrable (snode->scfg snode) - (node->scfg snode set-snode-next!)) + (node->scfg snode set-snode-next-edge!)) (define (node->scfg node set-node-next!) (make-scfg node @@ -351,8 +343,8 @@ (define-integrable (pnode->pcfg pnode) (node->pcfg pnode - set-pnode-consequent! - set-pnode-alternative!)) + set-pnode-consequent-edge! + set-pnode-alternative-edge!)) (define (node->pcfg node set-node-consequent! set-node-alternative!) (make-pcfg node diff --git a/v7/src/compiler/machines/bobcat/lapgen.scm b/v7/src/compiler/machines/bobcat/lapgen.scm index 6846a9eca..b3e302384 100644 --- a/v7/src/compiler/machines/bobcat/lapgen.scm +++ b/v7/src/compiler/machines/bobcat/lapgen.scm @@ -37,7 +37,7 @@ ;;;; RTL Rules for 68020 -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 1.141 1986/12/18 13:24:11 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 1.142 1986/12/20 23:49:41 cph Exp $ (declare (usual-integrations)) (using-syntax (access lap-generator-syntax-table compiler-package) @@ -702,8 +702,6 @@ '()) `(,@(make-external-label internal-label))))) -(define *block-start-label*) - (define (make-external-label label) `((DC W (- ,label ,*block-start-label*)) (LABEL ,label))) diff --git a/v7/src/compiler/machines/bobcat/make.scm-68040 b/v7/src/compiler/machines/bobcat/make.scm-68040 index 1e216fe6e..e4668e2e0 100644 --- a/v7/src/compiler/machines/bobcat/make.scm-68040 +++ b/v7/src/compiler/machines/bobcat/make.scm-68040 @@ -59,6 +59,7 @@ "cfg.bin" ;control flow graph "ctypes.bin" ;CFG datatypes "dtypes.bin" ;DFG datatypes + "bblock.bin" ;Basic block datatype "dfg.bin" ;data flow graph "rtl.bin" ;register transfer language "emodel.bin" ;environment model @@ -74,12 +75,9 @@ "dflow.bin" ;Dataflow analyzer ) - (CALL-CONSTRUCTOR-PACKAGE - "calls.bin" ;Call-sequence constructor - ) - (RTL-GENERATOR-PACKAGE - "cgen.bin" ;RTL generator + "rtlgen.bin" ;RTL generator + "rgcomb.bin" ;RTL generator: combinations "linear.bin" ;linearization ) @@ -125,7 +123,7 @@ (define :version) (define :modification) - (parse-rcs-header "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 1.9 1986/12/15 05:48:57 cph Exp $" + (parse-rcs-header "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 1.10 1986/12/20 23:49:57 cph Exp $" (lambda (filename version date time author state) (set! :version (car version)) (set! :modification (cadr version)))))) diff --git a/v7/src/compiler/rtlgen/rgcomb.scm b/v7/src/compiler/rtlgen/rgcomb.scm index 11a2528c9..bd150e28f 100644 --- a/v7/src/compiler/rtlgen/rgcomb.scm +++ b/v7/src/compiler/rtlgen/rgcomb.scm @@ -37,7 +37,7 @@ ;;;; RTL Generation: Combinations -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 1.1 1986/12/20 22:53:13 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 1.2 1986/12/20 23:48:42 cph Exp $ (declare (usual-integrations)) (using-syntax (access compiler-syntax-table compiler-package) @@ -235,43 +235,42 @@ ;;;; Reductions (define (combination:reduction combination offset) - (fluid-let ((*continuation* false)) - (let ((operator (combination-known-operator combination)) - (block (combination-block combination))) - (define (choose-generator ic closure stack) - ((cond ((ic-block? block) ic) - ((closure-procedure-block? block) closure) - ((stack-procedure-block? block) stack) - (else (error "Unknown caller type" block))) - combination offset)) - (cond ((normal-primitive-constant? operator) - (choose-generator reduction:ic->primitive - reduction:closure->primitive - reduction:stack->primitive)) - ((or (not operator) - (not (procedure? operator))) - (choose-generator reduction:ic->unknown - reduction:closure->unknown - reduction:stack->unknown)) - ((ic-procedure? operator) - (choose-generator reduction:ic->ic - reduction:closure->ic - reduction:stack->ic)) - ((closure-procedure? operator) - (choose-generator reduction:ic->closure - reduction:closure->closure - reduction:stack->closure)) - ((stack-procedure? operator) - (choose-generator reduction:ic->stack - reduction:closure->stack - (let ((block* (procedure-block operator))) - (cond ((block-child? block block*) - reduction:stack->child) - ((block-sibling? block block*) - reduction:stack->sibling) - (else - reduction:stack->ancestor))))) - (else (error "Unknown callee type" operator)))))) + (let ((operator (combination-known-operator combination)) + (block (combination-block combination))) + (define (choose-generator ic closure stack) + ((cond ((ic-block? block) ic) + ((closure-procedure-block? block) closure) + ((stack-procedure-block? block) stack) + (else (error "Unknown caller type" block))) + combination offset)) + (cond ((normal-primitive-constant? operator) + (choose-generator reduction:ic->primitive + reduction:closure->primitive + reduction:stack->primitive)) + ((or (not operator) + (not (procedure? operator))) + (choose-generator reduction:ic->unknown + reduction:closure->unknown + reduction:stack->unknown)) + ((ic-procedure? operator) + (choose-generator reduction:ic->ic + reduction:closure->ic + reduction:stack->ic)) + ((closure-procedure? operator) + (choose-generator reduction:ic->closure + reduction:closure->closure + reduction:stack->closure)) + ((stack-procedure? operator) + (choose-generator reduction:ic->stack + reduction:closure->stack + (let ((block* (procedure-block operator))) + (cond ((block-child? block block*) + reduction:stack->child) + ((block-sibling? block block*) + reduction:stack->sibling) + (else + reduction:stack->ancestor))))) + (else (error "Unknown callee type" operator))))) (define (reduction:ic->unknown combination offset) (make-call:unknown combination offset invocation-prefix:null false)) diff --git a/v7/src/compiler/rtlopt/rlife.scm b/v7/src/compiler/rtlopt/rlife.scm index c91e50e02..772c33043 100644 --- a/v7/src/compiler/rtlopt/rlife.scm +++ b/v7/src/compiler/rtlopt/rlife.scm @@ -38,7 +38,7 @@ ;;;; RTL Register Lifetime Analysis ;;; Based on the GNU C Compiler -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rlife.scm,v 1.53 1986/12/20 22:53:21 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rlife.scm,v 1.54 1986/12/20 23:48:53 cph Exp $ (declare (usual-integrations)) (using-syntax (access compiler-syntax-table compiler-package) @@ -88,7 +88,7 @@ (if (rtl:invocation? rtl) (for-each-regset-member old register-crosses-call!)) (if (instruction-dead? rtl old) - (rtl-snode-delete! rnode) + (snode-delete! rnode) (begin (update-live-registers! old dead live rtl rnode) (for-each-regset-member old increment-register-live-length!)))))) @@ -116,18 +116,6 @@ (let ((register (rtl:register-number address))) (and (pseudo-register? register) (not (regset-member? needed register)))))))) - -(define (rtl-snode-delete! rnode) - (let ((previous (node-previous rnode)) - (next (snode-next rnode)) - (bblock (node-bblock rnode))) - (snode-delete! rnode) - (if (eq? rnode (bblock-entry bblock)) - (if (eq? rnode (bblock-exit bblock)) - (set! *bblocks* (delq! bblock *bblocks*)) - (set-bblock-entry! bblock next)) - (if (eq? rnode (bblock-exit bblock)) - (set-bblock-exit! bblock (hook-node (car previous))))))) (define (mark-set-registers! needed dead rtl rnode) ;; **** This code safely ignores PRE-INCREMENT and POST-INCREMENT @@ -234,7 +222,7 @@ (= (rtl:register-number expression) register)) (set-expression! (rtl:assign-expression rtl))))) - (rtl-snode-delete! rnode) + (snode-delete! rnode) (reset-register-n-refs! register) (reset-register-n-deaths! register) (reset-register-live-length! register)