#| -*-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
promotional, or sales literature without prior written consent from
MIT in each case. |#
-;;;; LAP Code Generation
+;;;; LAP Generator
(declare (usual-integrations))
\f
(set! *cgen-rules*
(cons (list (car pattern) result)
*cgen-rules*))))))
- pattern)
-\f
-;;;; 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*))
-\f
-(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)))
-\f
-(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))))))
-\f
-(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))))
-\f
-(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))
-\f
-;;;; 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
#| -*-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
(edge-disconnect-right! edge))
(define (edges-disconnect-right! edges)
- (for-each edge-disconnect-right! edges))
-\f
-;;;; 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)))
-\f
-;;;; 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)))
-\f
-;;;; 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!))
- '())))
-\f
-;;;; 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))
-\f
-;;;; 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!))))
-\f
-;;;; 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))
-\f
-;;;; 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))))))))))))
-\f
-(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*))
-
-)
-\f
-(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*))
-
-)
-\f
-(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
projects / mit-scheme.git / commitdiff