From 5c56ed4b6ac51caacad01c4de09ecf071de25979 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sat, 13 Jun 1987 21:17:14 +0000 Subject: [PATCH] Break up files into smaller pieces for compilation. --- v7/src/compiler/back/lapgn1.scm | 279 +---------- v7/src/compiler/base/cfg1.scm | 453 +----------------- v7/src/compiler/machines/bobcat/decls.scm | 23 +- .../compiler/machines/bobcat/make.scm-68040 | 8 +- 4 files changed, 21 insertions(+), 742 deletions(-) diff --git a/v7/src/compiler/back/lapgn1.scm b/v7/src/compiler/back/lapgn1.scm index eff72f573..daaf62bae 100644 --- a/v7/src/compiler/back/lapgn1.scm +++ b/v7/src/compiler/back/lapgn1.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn1.scm,v 1.36 1987/06/11 20:44:20 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn1.scm,v 1.37 1987/06/13 21:17:14 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -32,7 +32,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. |# -;;;; LAP Code Generation +;;;; LAP Generator (declare (usual-integrations)) @@ -158,279 +158,4 @@ MIT in each case. |# (set! *cgen-rules* (cons (list (car pattern) result) *cgen-rules*)))))) - pattern) - -;;;; Machine independent stuff - -(define *register-map*) -(define *prefix-instructions*) -(define *needed-registers*) - -(define-integrable (prefix-instructions! instructions) - (set! *prefix-instructions* (append! *prefix-instructions* instructions))) - -(define-integrable (need-register! register) - (set! *needed-registers* (cons register *needed-registers*))) - -(define-integrable (need-registers! registers) - ;; **** Assume EQ? works on registers here. **** - (set! *needed-registers* (eq-set-union registers *needed-registers*))) - -(define (maybe-need-register! register) - (if register (need-register! register)) - register) - -(define (register-has-alias? register type) - (if (machine-register? register) - (register-type? register type) - (pseudo-register-alias *register-map* type register))) - -(define-integrable (register-alias register type) - (maybe-need-register! (pseudo-register-alias *register-map* type register))) - -(define-integrable (register-alias-alternate register type) - (maybe-need-register! (machine-register-alias *register-map* type register))) - -(define-integrable (register-type? register type) - (or (not type) - (eq? (register-type register) type))) - -(define ((register-type-predicate type) register) - (register-type? register type)) - -(define-integrable (dead-register? register) - (memv register *dead-registers*)) - -(define (guarantee-machine-register! register type) - (if (and (machine-register? register) - (register-type? register type)) - register - (load-alias-register! register type))) - -(define (load-alias-register! register type) - (bind-allocator-values (load-alias-register *register-map* type - *needed-registers* register) - store-allocator-values!)) - -(define (allocate-alias-register! register type) - (bind-allocator-values (allocate-alias-register *register-map* type - *needed-registers* register) - (lambda (alias map instructions) - (store-allocator-values! alias - (delete-other-locations map alias) - instructions)))) - -(define (allocate-assignment-alias! target type) - (let ((target (allocate-alias-register! target type))) - (delete-dead-registers!) - target)) - -(define (allocate-temporary-register! type) - (bind-allocator-values (allocate-temporary-register *register-map* type - *needed-registers*) - store-allocator-values!)) - -(define (store-allocator-values! alias map instructions) - (need-register! alias) - (set! *register-map* map) - (prefix-instructions! instructions) - alias) - -(define-integrable (reference-alias-register! register type) - (register-reference (allocate-alias-register! register type))) - -(define-integrable (reference-assignment-alias! register type) - (register-reference (allocate-assignment-alias! register type))) - -(define-integrable (reference-temporary-register! type) - (register-reference (allocate-temporary-register! type))) - -(define (move-to-alias-register! source type target) - (reuse-pseudo-register-alias! source type - (lambda (reusable-alias) - (add-pseudo-register-alias! target reusable-alias false)) - (lambda () - (allocate-alias-register! target type)))) - -(define (move-to-temporary-register! source type) - (reuse-pseudo-register-alias! source type - need-register! - (lambda () - (allocate-temporary-register! type)))) - -(define (reuse-pseudo-register-alias! source type if-reusable if-not) - ;; IF-NOT is assumed to return a machine register. - (let ((reusable-alias - (and (dead-register? source) - (register-alias source type)))) - (if reusable-alias - (begin (delete-dead-registers!) - (if-reusable reusable-alias) - (register-reference reusable-alias)) - (let ((alias (if (machine-register? source) - source - (register-alias source false)))) - (delete-dead-registers!) - (let ((target (if-not))) - (prefix-instructions! - (cond ((not alias) (home->register-transfer source target)) - ((= alias target) '()) - (else (register->register-transfer alias target)))) - (register-reference target)))))) - -(define (add-pseudo-register-alias! register alias saved-into-home?) - (set! *register-map* - (add-pseudo-register-alias *register-map* register alias - saved-into-home?)) - (need-register! alias)) - -(define (clear-map!) - (delete-dead-registers!) - (let ((instructions (clear-map))) - (set! *register-map* (empty-register-map)) - (set! *needed-registers* '()) - instructions)) - -(define-integrable (clear-map) - (clear-map-instructions *register-map*)) - -(define (clear-registers! . registers) - (if (null? registers) - '() - (let loop ((map *register-map*) (registers registers)) - (save-machine-register map (car registers) - (lambda (map instructions) - (let ((map (delete-machine-register map (car registers)))) - (if (null? (cdr registers)) - (begin (set! *register-map* map) - instructions) - (append! instructions (loop map (cdr registers)))))))))) - -(define (save-machine-register! register) - (let ((contents (machine-register-contents *register-map* register))) - (if contents - (save-pseudo-register! contents)))) - -(define (save-pseudo-register! register) - (if (not (dead-register? register)) - (save-pseudo-register *register-map* register - (lambda (map instructions) - (set! *register-map* map) - (prefix-instructions! instructions))))) - -(define (delete-machine-register! register) - (set! *register-map* (delete-machine-register *register-map* register)) - (set! *needed-registers* (eqv-set-delete *needed-registers* register))) - -(package (delete-pseudo-register! delete-dead-registers!) - (define-export (delete-pseudo-register! register) - (delete-pseudo-register *register-map* register delete-registers!)) - (define-export (delete-dead-registers!) - (delete-pseudo-registers *register-map* *dead-registers* delete-registers!) - (set! *dead-registers* '())) - (define (delete-registers! map aliases) - (set! *register-map* map) - (set! *needed-registers* (eqv-set-difference *needed-registers* aliases)))) - -(define *next-constant*) -(define *interned-constants*) -(define *interned-variables*) -(define *interned-uuo-links*) - -(define (allocate-constant-label) - (let ((label - (string->symbol - (string-append "CONSTANT-" (write-to-string *next-constant*))))) - (set! *next-constant* (1+ *next-constant*)) - label)) - -(define (constant->label constant) - (let ((entry (assv constant *interned-constants*))) - (if entry - (cdr entry) - (let ((label (allocate-constant-label))) - (set! *interned-constants* - (cons (cons constant label) - *interned-constants*)) - label)))) - -(define (free-reference-label name) - (let ((entry (assq name *interned-variables*))) - (if entry - (cdr entry) - (let ((label (allocate-constant-label))) - (set! *interned-variables* - (cons (cons name label) - *interned-variables*)) - label)))) - -(define (free-uuo-link-label name) - (let ((entry (assq name *interned-uuo-links*))) - (if entry - (cdr entry) - (let ((label (allocate-constant-label))) - (set! *interned-uuo-links* - (cons (cons name label) - *interned-uuo-links*)) - label)))) - -(define-integrable (set-current-branches! consequent alternative) - (set-rtl-pnode-consequent-lap-generator! *current-rnode* consequent) - (set-rtl-pnode-alternative-lap-generator! *current-rnode* alternative)) - -;;;; Frame Pointer - -(define *frame-pointer-offset*) - -(define (disable-frame-pointer-offset! instructions) - (set! *frame-pointer-offset* false) - instructions) - -(define (enable-frame-pointer-offset! offset) - (if (not offset) (error "Null frame-pointer offset")) - (set! *frame-pointer-offset* offset)) - -(define (record-push! instructions) - (if *frame-pointer-offset* - (set! *frame-pointer-offset* (1+ *frame-pointer-offset*))) - instructions) - -(define (record-pop!) - (if *frame-pointer-offset* - (set! *frame-pointer-offset* (-1+ *frame-pointer-offset*)))) - -(define (decrement-frame-pointer-offset! n instructions) - (if *frame-pointer-offset* - (set! *frame-pointer-offset* - (and (<= n *frame-pointer-offset*) (- *frame-pointer-offset* n)))) - instructions) - -(define (guarantee-frame-pointer-offset!) - (if (not *frame-pointer-offset*) (error "Frame pointer not initialized"))) - -(define (increment-frame-pointer-offset! n instructions) - (guarantee-frame-pointer-offset!) - (set! *frame-pointer-offset* (+ *frame-pointer-offset* n)) - instructions) - -(define (frame-pointer-offset) - (guarantee-frame-pointer-offset!) - *frame-pointer-offset*) - -(define (record-continuation-frame-pointer-offset! label) - (let ((continuation (label->continuation label))) - (guarantee-frame-pointer-offset!) - (if (continuation-frame-pointer-offset continuation) - (if (not (= (continuation-frame-pointer-offset continuation) - *frame-pointer-offset*)) - (error "Continuation frame-pointer offset mismatch" continuation - *frame-pointer-offset*)) - (set-continuation-frame-pointer-offset! continuation - *frame-pointer-offset*)) - (enqueue! *continuation-queue* continuation))) - -(define (record-rnode-frame-pointer-offset! rnode offset) - (if (rnode-frame-pointer-offset rnode) - (if (not (and offset (= (rnode-frame-pointer-offset rnode) offset))) - (error "RNode frame-pointer offset mismatch" rnode offset)) pattern) \ No newline at end of file diff --git a/v7/src/compiler/base/cfg1.scm b/v7/src/compiler/base/cfg1.scm index daf3542f5..0e4c983b9 100644 --- a/v7/src/compiler/base/cfg1.scm +++ b/v7/src/compiler/base/cfg1.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg1.scm,v 1.148 1987/05/07 00:04:58 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg1.scm,v 1.149 1987/06/13 21:16:08 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -134,455 +134,4 @@ MIT in each case. |# (edge-disconnect-right! edge)) (define (edges-disconnect-right! edges) - (for-each edge-disconnect-right! edges)) - -;;;; Editing - -;;; BBlock information is preserved only for deletions. Doing the -;;; same for insertions is more difficult and not currently needed. - -(define (snode-delete! snode) - (let ((bblock (node-bblock snode))) - (if (and bblock - (eq? snode (bblock-exit bblock)) - (not (eq? snode (bblock-entry bblock)))) - (set-bblock-exit! bblock (node-previous-first snode)))) - (let ((previous-edges (node-previous-edges snode)) - (next-edge (snode-next-edge snode))) - (let ((node (edge-right-node next-edge))) - (edges-disconnect-right! previous-edges) - (edge-disconnect! next-edge) - (edges-connect-right! previous-edges node)))) - -(define (edge-insert-snode! edge snode) - (let ((next (edge-right-node edge))) - (edge-disconnect-right! edge) - (edge-connect-right! edge snode) - (create-edge! snode set-snode-next-edge! next))) - -(define (node-insert-snode! node snode) - (let ((previous-edges (node-previous-edges node))) - (edges-disconnect-right! previous-edges) - (edges-connect-right! previous-edges snode) - (create-edge! snode set-snode-next-edge! node))) - -(define (node->edge node) - (let ((edge (make-edge false false false))) - (edge-connect-right! edge node) - edge)) - -(define-integrable (cfg-entry-edge cfg) - (node->edge (cfg-entry-node cfg))) - -;;;; Previous Connections - -(define-integrable (node-previous=0? node) - (edges=0? (node-previous-edges node))) - -(define (edges=0? edges) - (cond ((null? edges) true) - ((edge-left-node (car edges)) false) - (else (edges=0? (cdr edges))))) - -(define-integrable (node-previous>0? node) - (edges>0? (node-previous-edges node))) - -(define (edges>0? edges) - (cond ((null? edges) false) - ((edge-left-node (car edges)) true) - (else (edges>0? (cdr edges))))) - -(define-integrable (node-previous=1? node) - (edges=1? (node-previous-edges node))) - -(define (edges=1? edges) - (if (null? edges) - false - ((if (edge-left-node (car edges)) edges=0? edges=1?) (cdr edges)))) - -(define-integrable (node-previous>1? node) - (edges>1? (node-previous-edges node))) - -(define (edges>1? edges) - (if (null? edges) - false - ((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))) - -(define (edges-first-node edges) - (if (null? edges) - (error "No first hook") - (or (edge-left-node (car edges)) - (edges-first-node (cdr edges))))) - -(define (for-each-previous-node node procedure) - (for-each (lambda (edge) - (let ((node (edge-left-node edge))) - (if node - (procedure node)))) - (node-previous-edges node))) - -;;;; Noops - -(define noop-node-tag (make-vector-tag snode-tag 'NOOP)) -(define *noop-nodes*) - -(define-integrable (make-noop-node) - (let ((node (make-snode noop-node-tag))) - (set! *noop-nodes* (cons node *noop-nodes*)) - node)) - -(define (delete-noop-nodes!) - (for-each snode-delete! *noop-nodes*) - (set! *noop-nodes* '())) - -(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-snode-next-edge!))))) - -(define (make-true-pcfg) - (let ((node (make-noop-node))) - (make-pcfg node - (list (make-hook node set-snode-next-edge!)) - '()))) - -;;;; Miscellaneous - -(package (with-new-node-marks - node-marked? - node-mark!) - -(define *generation*) - -(define-export (with-new-node-marks thunk) - (fluid-let ((*generation* (make-generation))) - (thunk))) - -(define make-generation - (let ((generation 0)) - (named-lambda (make-generation) - (let ((value generation)) - (set! generation (1+ generation)) - value)))) - -(define-export (node-marked? node) - (eq? (node-generation node) *generation*)) - -(define-export (node-mark! node) - (set-node-generation! node *generation*)) - -) - -(define (node-property-get node key) - (let ((entry (assq key (node-alist node)))) - (and entry (cdr entry)))) - -(define (node-property-put! node key item) - (let ((entry (assq key (node-alist node)))) - (if entry - (set-cdr! entry item) - (set-node-alist! node (cons (cons key item) (node-alist node)))))) - -(define (node-property-remove! node key) - (set-node-alist! node (del-assq! key (node-alist node)))) - -(define (node-label node) - (or (node-labelled? node) - (let ((label (generate-label))) - (set-node-label! node label) - label))) - -(define-integrable (node-labelled? node) - (node-property-get node node-label)) - -(define-integrable (set-node-label! node label) - (node-property-put! node node-label label)) - -;;;; CFG Datatypes - -;;; A CFG is a compound CFG-node, so there are different types of CFG -;;; corresponding to the (connective-wise) different types of -;;; CFG-node. One may insert a particular type of CFG anywhere in a -;;; graph that its corresponding node may be inserted. - -(define-integrable (make-scfg node next-hooks) - (vector 'SNODE-CFG node next-hooks)) - -(define-integrable (make-scfg* node consequent-hooks alternative-hooks) - (make-scfg node (hooks-union consequent-hooks alternative-hooks))) - -(define-integrable (make-pcfg node consequent-hooks alternative-hooks) - (vector 'PNODE-CFG node consequent-hooks alternative-hooks)) - -(define-integrable (cfg-tag cfg) - (vector-ref cfg 0)) - -(define-integrable (cfg-entry-node cfg) - (vector-ref cfg 1)) - -(define-integrable (scfg-next-hooks scfg) - (vector-ref scfg 2)) - -(define-integrable (pcfg-consequent-hooks pcfg) - (vector-ref pcfg 2)) - -(define-integrable (pcfg-alternative-hooks pcfg) - (vector-ref pcfg 3)) - -(define-integrable (make-null-cfg) false) -(define-integrable cfg-null? false?) - -(define-integrable (snode->scfg snode) - (node->scfg snode set-snode-next-edge!)) - -(define (node->scfg node set-node-next!) - (make-scfg node - (list (make-hook node set-node-next!)))) - -(define-integrable (pnode->pcfg pnode) - (node->pcfg pnode - set-pnode-consequent-edge! - set-pnode-alternative-edge!)) - -(define (node->pcfg node set-node-consequent! set-node-alternative!) - (make-pcfg node - (list (make-hook node set-node-consequent!)) - (list (make-hook node set-node-alternative!)))) - -;;;; Hook Datatype - -(define-integrable make-hook cons) -(define-integrable hook-node car) -(define-integrable hook-connect cdr) - -(define (hook=? x y) - (and (eq? (hook-node x) (hook-node y)) - (eq? (hook-connect x) (hook-connect y)))) - -(define hook-member? - (member-procedure hook=?)) - -(define (hooks-union x y) - (let loop ((x x)) - (cond ((null? x) y) - ((hook-member? (car x) y) (loop (cdr x))) - (else (cons (car x) (loop (cdr x))))))) - -(define (hooks-connect! hooks node) - (for-each (lambda (hook) - (hook-connect! hook node)) - hooks)) - -(define (hook-connect! hook node) - (create-edge! (hook-node hook) (hook-connect hook) node)) - -(define (scfg*node->node! scfg next-node) - (if (cfg-null? scfg) - next-node - (begin (if next-node - (hooks-connect! (scfg-next-hooks scfg) next-node)) - (cfg-entry-node scfg)))) - -(define (pcfg*node->node! pcfg consequent-node alternative-node) - (if (cfg-null? pcfg) - (error "PCFG*NODE->NODE!: Can't have null predicate")) - (if consequent-node - (hooks-connect! (pcfg-consequent-hooks pcfg) consequent-node)) - (if alternative-node - (hooks-connect! (pcfg-alternative-hooks pcfg) alternative-node)) - (cfg-entry-node pcfg)) - -;;;; CFG Construction - -(define-integrable (scfg-next-connect! scfg cfg) - (hooks-connect! (scfg-next-hooks scfg) (cfg-entry-node cfg))) - -(define-integrable (pcfg-consequent-connect! pcfg cfg) - (hooks-connect! (pcfg-consequent-hooks pcfg) (cfg-entry-node cfg))) - -(define-integrable (pcfg-alternative-connect! pcfg cfg) - (hooks-connect! (pcfg-alternative-hooks pcfg) (cfg-entry-node cfg))) - -(define (scfg*scfg->scfg! scfg scfg*) - (cond ((not scfg) scfg*) - ((not scfg*) scfg) - (else - (scfg-next-connect! scfg scfg*) - (make-scfg (cfg-entry-node scfg) (scfg-next-hooks scfg*))))) - -(define (scfg-append! . scfgs) - (scfg*->scfg! scfgs)) - -(define scfg*->scfg! - (let () - (define (loop first second rest) - (scfg-next-connect! first second) - (if (null? rest) - second - (loop second (car rest) (find-non-null (cdr rest))))) - - (define (find-non-null scfgs) - (if (or (null? scfgs) - (car scfgs)) - scfgs - (find-non-null (cdr scfgs)))) - - (named-lambda (scfg*->scfg! scfgs) - (let ((first (find-non-null scfgs))) - (and (not (null? first)) - (let ((second (find-non-null (cdr first)))) - (if (null? second) - (car first) - (make-scfg (cfg-entry-node (car first)) - (scfg-next-hooks - (loop (car first) - (car second) - (find-non-null (cdr second)))))))))))) - -(define (pcfg->scfg! pcfg) - (make-scfg* (cfg-entry-node pcfg) - (pcfg-consequent-hooks pcfg) - (pcfg-alternative-hooks pcfg))) - -(package (scfg*pcfg->pcfg! scfg*pcfg->scfg!) - -(define ((scfg*pcfg->cfg! transformer constructor) scfg pcfg) - (cond ((not pcfg) (error "SCFG*PCFG->CFG!: Can't have null predicate")) - ((not scfg) (transformer pcfg)) - (else - (scfg-next-connect! scfg pcfg) - (constructor (cfg-entry-node scfg) - (pcfg-consequent-hooks pcfg) - (pcfg-alternative-hooks pcfg))))) - -(define scfg*pcfg->pcfg! - (scfg*pcfg->cfg! identity-procedure make-pcfg)) - -(define scfg*pcfg->scfg! - (scfg*pcfg->cfg! pcfg->scfg! make-scfg*)) - -) - -(package (pcfg*scfg->pcfg! pcfg*scfg->scfg!) - -(define ((pcfg*scfg->cfg! transformer constructor) pcfg consequent alternative) - (cond ((not pcfg) (error "PCFG*SCFG->CFG!: Can't have null predicate")) - ((not consequent) - (if (not alternative) - (transformer pcfg) - (begin (pcfg-alternative-connect! pcfg alternative) - (constructor (cfg-entry-node pcfg) - (pcfg-consequent-hooks pcfg) - (scfg-next-hooks alternative))))) - ((not alternative) - (pcfg-consequent-connect! pcfg consequent) - (constructor (cfg-entry-node pcfg) - (scfg-next-hooks consequent) - (pcfg-alternative-hooks pcfg))) - (else - (pcfg-consequent-connect! pcfg consequent) - (pcfg-alternative-connect! pcfg alternative) - (constructor (cfg-entry-node pcfg) - (scfg-next-hooks consequent) - (scfg-next-hooks alternative))))) - -(define pcfg*scfg->pcfg! - (pcfg*scfg->cfg! identity-procedure make-pcfg)) - -(define pcfg*scfg->scfg! - (pcfg*scfg->cfg! pcfg->scfg! make-scfg*)) - -) - -(package (pcfg*pcfg->pcfg! pcfg*pcfg->scfg!) - -(define ((pcfg*pcfg->cfg! transformer constructor) pcfg consequent alternative) - (cond ((not pcfg) - (error "PCFG*PCFG->CFG!: Can't have null predicate")) - ((not consequent) - (if (not alternative) - (transformer pcfg) - (begin (pcfg-alternative-connect! pcfg alternative) - (constructor - (cfg-entry-node pcfg) - (hooks-union (pcfg-consequent-hooks pcfg) - (pcfg-consequent-hooks alternative)) - (pcfg-alternative-hooks alternative))))) - ((not alternative) - (pcfg-consequent-connect! pcfg consequent) - (constructor (cfg-entry-node pcfg) - (pcfg-consequent-hooks consequent) - (hooks-union (pcfg-alternative-hooks consequent) - (pcfg-alternative-hooks pcfg)))) - (else - (pcfg-consequent-connect! pcfg consequent) - (pcfg-alternative-connect! pcfg alternative) - (constructor (cfg-entry-node pcfg) - (hooks-union (pcfg-consequent-hooks consequent) - (pcfg-consequent-hooks alternative)) - (hooks-union (pcfg-alternative-hooks consequent) - (pcfg-alternative-hooks alternative)))))) - -(define pcfg*pcfg->pcfg! - (pcfg*pcfg->cfg! identity-procedure make-pcfg)) - -(define pcfg*pcfg->scfg! - (pcfg*pcfg->cfg! pcfg->scfg! make-scfg*)) - -) - -(define (scfg*cfg->cfg! scfg cfg) - (if (not scfg) - cfg - (begin (scfg-next-connect! scfg cfg) - (case (cfg-tag cfg) - ((SNODE-CFG) - (make-scfg (cfg-entry-node scfg) (scfg-next-hooks cfg))) - ((PNODE-CFG) - (make-pcfg (cfg-entry-node scfg) - (pcfg-consequent-hooks cfg) - (pcfg-alternative-hooks cfg))) - (else - (error "Unknown CFG tag" cfg)))))) - -(define (pcfg*cfg->pcfg! pcfg consequent alternative) - (pcfg-consequent-connect! pcfg consequent) - (pcfg-alternative-connect! pcfg alternative) - (case (cfg-tag consequent) - ((SNODE-CFG) - (case (cfg-tag alternative) - ((SNODE-CFG) - (make-pcfg (cfg-entry-node pcfg) - (scfg-next-hooks consequent) - (scfg-next-hooks alternative))) - ((PNODE-CFG) - (make-pcfg (cfg-entry-node pcfg) - (hooks-union (scfg-next-hooks consequent) - (pcfg-consequent-hooks alternative)) - (pcfg-alternative-hooks alternative))) - (else - (error "Unknown CFG tag" alternative)))) - ((PNODE-CFG) - (case (cfg-tag alternative) - ((SNODE-CFG) - (make-pcfg (cfg-entry-node pcfg) - (pcfg-consequent-hooks consequent) - (hooks-union (pcfg-alternative-hooks consequent) - (scfg-next-hooks alternative)))) - ((PNODE-CFG) - (make-pcfg (cfg-entry-node pcfg) - (hooks-union (pcfg-consequent-hooks consequent) - (pcfg-consequent-hooks alternative)) - (hooks-union (pcfg-alternative-hooks consequent) - (pcfg-alternative-hooks alternative)))) - (else - (error "Unknown CFG tag" alternative)))) - (else (for-each edge-disconnect-right! edges)) \ No newline at end of file diff --git a/v7/src/compiler/machines/bobcat/decls.scm b/v7/src/compiler/machines/bobcat/decls.scm index 824e84f8d..eef2cd0d9 100644 --- a/v7/src/compiler/machines/bobcat/decls.scm +++ b/v7/src/compiler/machines/bobcat/decls.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 1.9 1987/06/09 19:59:13 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 1.10 1987/06/13 21:14:53 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -67,8 +67,8 @@ MIT in each case. |# (define filenames/dependency-chain/base (filename/append "base" - "object" "cfg" "ctypes" "dtypes" "bblock" "dfg" "rtltyp" - "rtlreg" "rtlcfg" "emodel" "rtypes")) + "object" "cfg1" "cfg2" "cfg3" "ctypes" "dtypes" "bblock" + "dfg" "rtltyp" "rtlreg" "rtlcfg" "emodel" "rtypes")) (define filenames/dependency-chain/rcse (filename/append "front-end" "rcseht" "rcserq" "rcse1" "rcse2")) @@ -81,7 +81,7 @@ MIT in each case. |# "ralloc" "rcseep" "rcsesa" "rdeath" "rdebug" "rgcomb" "rgpcom" "rgpred" "rgproc" "rgrval" "rgstmt" "rlife" "rtlgen") - (filename/append "back-end" "lapgen"))) + (filename/append "back-end" "lapgn1" "lapgn2" "lapgn3"))) (file-dependency/integration/chain (reverse @@ -94,12 +94,13 @@ MIT in each case. |# (file-dependency/integration/join (filename/append "machines/bobcat" "instr2" "instr3") (filename/append "machines/bobcat" "instr1")) - + (file-dependency/syntax/join (append (filename/append "base" - "bblock" "cfg" "ctypes" "dfg" "dtypes" "emodel" - "linear" "object" "queue" "rtlcfg" "rtlcon" "rtlexp" - "rtlreg" "rtltyp" "rtypes" "sets" "toplev" "utils") + "bblock" "cfg1" "cfg2" "cfg3" "ctypes" "dfg" "dtypes" + "emodel" "linear" "object" "queue" "rtlcfg" "rtlcon" + "rtlexp" "rtlreg" "rtltyp" "rtypes" "sets" "toplev" + "utils") (filename/append "alpha" "dflow1" "dflow2" "dflow3" "dflow4" "dflow5" "dflow6" "fggen1" "fggen2") (filename/append "front-end" @@ -107,12 +108,14 @@ MIT in each case. |# "rcsesa" "rdeath" "rdebug" "rgcomb" "rgpcom" "rgpred" "rgproc" "rgrval" "rgstmt" "rlife" "rtlgen") (filename/append "back-end" - "asmmac" "block" "lapgen" "laptop" "regmap" "symtab") + "asmmac" "block" "lapgn1" "lapgn2" "lapgn3" "laptop" + "regmap" "symtab") (filename/append "machines/bobcat" "insmac" "machin")) compiler-syntax-table) (file-dependency/syntax/join - (append (filename/append "machines/bobcat" "lapgen") + (append (filename/append "machines/bobcat" + "lapgen" "rules1" "rules2" "rules3" "rules4") (filename/append "machines/spectrum" "lapgen")) lap-generator-syntax-table) diff --git a/v7/src/compiler/machines/bobcat/make.scm-68040 b/v7/src/compiler/machines/bobcat/make.scm-68040 index b1d690bcf..56d0d6408 100644 --- a/v7/src/compiler/machines/bobcat/make.scm-68040 +++ b/v7/src/compiler/machines/bobcat/make.scm-68040 @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 1.24 1987/06/13 21:08:57 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 1.25 1987/06/13 21:14:34 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -50,7 +50,7 @@ MIT in each case. |# (define :files) ; (parse-rcs-header -; "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 1.24 1987/06/13 21:08:57 cph Exp $" +; "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 1.25 1987/06/13 21:14:34 cph Exp $" ; (lambda (filename version date time zone author state) ; (set! :version (car version)) ; (set! :modification (cadr version)))) @@ -73,7 +73,9 @@ MIT in each case. |# "machines/bobcat/machin.bin" ;machine dependent stuff "base/toplev.bin" ;top level "base/utils.bin" ;odds and ends - "base/cfg.bin" ;control flow graph + "base/cfg1.bin" ;control flow graph + "base/cfg2.bin" + "base/cfg3.bin" "base/ctypes.bin" ;CFG datatypes "base/dtypes.bin" ;DFG datatypes "base/bblock.bin" ;Basic block datatype -- 2.25.1