From 68c92d4830e236d3a947ac550f1bf83a53e408d3 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sat, 13 Jun 1987 21:18:20 +0000 Subject: [PATCH] Initial revision --- v7/src/compiler/back/lapgn2.scm | 207 +++++++++++++++++++++ v7/src/compiler/back/lapgn3.scm | 142 ++++++++++++++ v7/src/compiler/base/cfg2.scm | 205 ++++++++++++++++++++ v7/src/compiler/base/cfg3.scm | 318 ++++++++++++++++++++++++++++++++ 4 files changed, 872 insertions(+) create mode 100644 v7/src/compiler/back/lapgn2.scm create mode 100644 v7/src/compiler/back/lapgn3.scm create mode 100644 v7/src/compiler/base/cfg2.scm create mode 100644 v7/src/compiler/base/cfg3.scm diff --git a/v7/src/compiler/back/lapgn2.scm b/v7/src/compiler/back/lapgn2.scm new file mode 100644 index 000000000..2f6fa7f4a --- /dev/null +++ b/v7/src/compiler/back/lapgn2.scm @@ -0,0 +1,207 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn2.scm,v 1.1 1987/06/13 21:18:05 cph Exp $ + +Copyright (c) 1987 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; LAP Generator + +(declare (usual-integrations)) + +(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)))) \ No newline at end of file diff --git a/v7/src/compiler/back/lapgn3.scm b/v7/src/compiler/back/lapgn3.scm new file mode 100644 index 000000000..4b8b38eb2 --- /dev/null +++ b/v7/src/compiler/back/lapgn3.scm @@ -0,0 +1,142 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn3.scm,v 1.1 1987/06/13 21:18:20 cph Exp $ + +Copyright (c) 1987 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; LAP Generator + +(declare (usual-integrations)) + +;;;; Constants + +(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)) + (set-rnode-frame-pointer-offset! rnode offset))) \ No newline at end of file diff --git a/v7/src/compiler/base/cfg2.scm b/v7/src/compiler/base/cfg2.scm new file mode 100644 index 000000000..0b34b479b --- /dev/null +++ b/v7/src/compiler/base/cfg2.scm @@ -0,0 +1,205 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg2.scm,v 1.1 1987/06/13 21:16:51 cph Exp $ + +Copyright (c) 1987 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Control Flow Graph Abstraction + +(declare (usual-integrations)) + +;;;; 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)) \ No newline at end of file diff --git a/v7/src/compiler/base/cfg3.scm b/v7/src/compiler/base/cfg3.scm new file mode 100644 index 000000000..617c35f02 --- /dev/null +++ b/v7/src/compiler/base/cfg3.scm @@ -0,0 +1,318 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg3.scm,v 1.1 1987/06/13 21:16:37 cph Exp $ + +Copyright (c) 1987 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Control Flow Graph Abstraction + +(declare (usual-integrations)) + +;;;; 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 + (error "Unknown CFG tag" consequent)))) \ No newline at end of file -- 2.25.1