home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / compiler / base / cfg2.scm < prev    next >
Text File  |  1999-01-02  |  6KB  |  218 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: cfg2.scm,v 4.4 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1987, 1989, 1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Control Flow Graph Abstraction
  23.  
  24. (declare (usual-integrations))
  25.  
  26. ;;;; Editing
  27.  
  28. (define (snode-delete! snode)
  29.   (let ((next-edge (snode-next-edge snode)))
  30.     (if next-edge
  31.     (begin
  32.       (edges-replace-right! (node-previous-edges snode)
  33.                 (edge-right-node next-edge))
  34.       (edge-disconnect! next-edge))
  35.     (edges-disconnect-right! (node-previous-edges snode)))))
  36.  
  37. (define (edge-insert-snode! edge snode)
  38.   (let ((next (edge-right-node edge)))
  39.     (edge-replace-right! edge snode)
  40.     (create-edge! snode set-snode-next-edge! next)))
  41.  
  42. (define (node-insert-snode! node snode)
  43.   (edges-replace-right! (node-previous-edges node) snode)
  44.   (create-edge! snode set-snode-next-edge! node))
  45.  
  46. (define-integrable (node-disconnect-on-right! node)
  47.   (edges-disconnect-right! (node-previous-edges node)))
  48.  
  49. (define (node-disconnect-on-left! node)
  50.   (if (snode? node)
  51.       (snode-disconnect-on-left! node)
  52.       (pnode-disconnect-on-left! node)))
  53.  
  54. (define (snode-disconnect-on-left! node)
  55.   (let ((edge (snode-next-edge node)))
  56.     (if edge
  57.     (edge-disconnect-left! edge))))
  58.  
  59. (define (pnode-disconnect-on-left! node)
  60.   (let ((edge (pnode-consequent-edge node)))
  61.     (if edge
  62.     (edge-disconnect-left! edge)))
  63.   (let ((edge (pnode-alternative-edge node)))
  64.     (if edge
  65.     (edge-disconnect-left! edge))))
  66.  
  67. (define (node-replace! old-node new-node)
  68.   (if (snode? old-node)
  69.       (snode-replace! old-node new-node)
  70.       (pnode-replace! old-node new-node)))
  71.  
  72. (define (snode-replace! old-node new-node)
  73.   (node-replace-on-right! old-node new-node)
  74.   (snode-replace-on-left! old-node new-node))
  75.  
  76. (define (pnode-replace! old-node new-node)
  77.   (node-replace-on-right! old-node new-node)
  78.   (pnode-replace-on-left! old-node new-node))
  79.  
  80. (define-integrable (node-replace-on-right! old-node new-node)
  81.   (edges-replace-right! (node-previous-edges old-node) new-node))
  82.  
  83. (define (node-replace-on-left! old-node new-node)
  84.   (if (snode? old-node)
  85.       (snode-replace-on-left! old-node new-node)
  86.       (pnode-replace-on-left! old-node new-node)))
  87.  
  88. (define (snode-replace-on-left! old-node new-node)
  89.   (let ((edge (snode-next-edge old-node)))
  90.     (if edge
  91.     (edge-replace-left! edge new-node set-snode-next-edge!))))
  92.  
  93. (define (pnode-replace-on-left! old-node new-node)
  94.   (let ((edge (pnode-consequent-edge old-node)))
  95.     (if edge
  96.     (edge-replace-left! edge new-node set-pnode-consequent-edge!)))
  97.   (let ((edge (pnode-alternative-edge old-node)))
  98.     (if edge
  99.     (edge-replace-left! edge new-node set-pnode-alternative-edge!))))
  100.  
  101. ;;;; Previous Connections
  102.  
  103. (define-integrable (node-previous=0? node)
  104.   (edges=0? (node-previous-edges node)))
  105.  
  106. (define (edges=0? edges)
  107.   (cond ((null? edges) true)
  108.     ((edge-left-node (car edges)) false)
  109.     (else (edges=0? (cdr edges)))))
  110.  
  111. (define-integrable (node-previous>0? node)
  112.   (edges>0? (node-previous-edges node)))
  113.  
  114. (define (edges>0? edges)
  115.   (cond ((null? edges) false)
  116.     ((edge-left-node (car edges)) true)
  117.     (else (edges>0? (cdr edges)))))
  118.  
  119. (define-integrable (node-previous=1? node)
  120.   (edges=1? (node-previous-edges node)))
  121.  
  122. (define (edges=1? edges)
  123.   (if (null? edges)
  124.       false
  125.       ((if (edge-left-node (car edges)) edges=0? edges=1?) (cdr edges))))
  126.  
  127. (define-integrable (node-previous>1? node)
  128.   (edges>1? (node-previous-edges node)))
  129.  
  130. (define (edges>1? edges)
  131.   (if (null? edges)
  132.       false
  133.       ((if (edge-left-node (car edges)) edges>0? edges>1?) (cdr edges))))
  134.  
  135. (define-integrable (node-previous-first node)
  136.   (edges-first-node (node-previous-edges node)))
  137.  
  138. (define (edges-first-node edges)
  139.   (if (null? edges)
  140.       (error "No first hook")
  141.       (or (edge-left-node (car edges))
  142.       (edges-first-node (cdr edges)))))
  143.  
  144. (define (for-each-previous-node node procedure)
  145.   (for-each (lambda (edge)
  146.           (let ((node (edge-left-node edge)))
  147.         (if node
  148.             (procedure node))))
  149.         (node-previous-edges node)))
  150.  
  151. ;;;; Noops
  152.  
  153. (package (cfg-node-tag/noop! cfg-node-tag/noop?)
  154.  
  155. (define-export (cfg-node-tag/noop! tag)
  156.   (vector-tag-put! tag noop-tag-property true))
  157.  
  158. (define-export (cfg-node-tag/noop? tag)
  159.   (vector-tag-get tag noop-tag-property))
  160.  
  161. (define noop-tag-property
  162.   "noop-tag-property")
  163.  
  164. )
  165.  
  166. (define-integrable (cfg-node/noop? node)
  167.   (cfg-node-tag/noop? (tagged-vector/tag node)))
  168.  
  169. (define noop-node-tag
  170.   (make-vector-tag snode-tag 'NOOP false))
  171.  
  172. (cfg-node-tag/noop! noop-node-tag)
  173.  
  174. (define-integrable (make-noop-node)
  175.   (let ((node (make-snode noop-node-tag)))
  176.     (set! *noop-nodes* (cons node *noop-nodes*))
  177.     node))
  178.  
  179. (define *noop-nodes*)
  180.  
  181. (define (cleanup-noop-nodes thunk)
  182.   (fluid-let ((*noop-nodes* '()))
  183.     (let ((value (thunk)))
  184.       (for-each snode-delete! *noop-nodes*)
  185.       value)))
  186.  
  187. (define (make-false-pcfg)
  188.   (snode->pcfg-false (make-noop-node)))
  189.  
  190. (define (make-true-pcfg)
  191.   (snode->pcfg-true (make-noop-node)))
  192.  
  193. ;;;; Miscellaneous
  194.  
  195. (package (with-new-node-marks
  196.       node-marked?
  197.       node-mark!)
  198.  
  199. (define *generation*)
  200.  
  201. (define-export (with-new-node-marks thunk)
  202.   (fluid-let ((*generation* (make-generation)))
  203.     (thunk)))
  204.  
  205. (define make-generation
  206.   (let ((generation 0))
  207.     (named-lambda (make-generation)
  208.       (let ((value generation))
  209.     (set! generation (1+ generation))
  210.     value))))
  211.  
  212. (define-export (node-marked? node)
  213.   (eq? (node-generation node) *generation*))
  214.  
  215. (define-export (node-mark! node)
  216.   (set-node-generation! node *generation*))
  217.  
  218. )