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 / cfg3.scm < prev    next >
Text File  |  1999-01-02  |  10KB  |  342 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: cfg3.scm,v 4.5 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. ;;;; CFG Datatypes
  27.  
  28. ;;; A CFG is a compound CFG-node, so there are different types of CFG
  29. ;;; corresponding to the (connective-wise) different types of
  30. ;;; CFG-node.  One may insert a particular type of CFG anywhere in a
  31. ;;; graph that its corresponding node may be inserted.
  32.  
  33. (define-integrable (make-scfg node next-hooks)
  34.   (vector 'SNODE-CFG node next-hooks))
  35.  
  36. (define-integrable (make-scfg* node consequent-hooks alternative-hooks)
  37.   (make-scfg node (hooks-union consequent-hooks alternative-hooks)))
  38.  
  39. (define-integrable (make-pcfg node consequent-hooks alternative-hooks)
  40.   (vector 'PNODE-CFG node consequent-hooks alternative-hooks))
  41.  
  42. (define-integrable (cfg-tag cfg)
  43.   (vector-ref cfg 0))
  44.  
  45. (define-integrable (cfg-entry-node cfg)
  46.   (vector-ref cfg 1))
  47.  
  48. (define-integrable (scfg-next-hooks scfg)
  49.   (vector-ref scfg 2))
  50.  
  51. (define-integrable (pcfg-consequent-hooks pcfg)
  52.   (vector-ref pcfg 2))
  53.  
  54. (define-integrable (pcfg-alternative-hooks pcfg)
  55.   (vector-ref pcfg 3))
  56.  
  57. (define-integrable (make-null-cfg) false)
  58. (define-integrable cfg-null? false?)
  59.  
  60. (define-integrable (cfg-entry-edge cfg)
  61.   (node->edge (cfg-entry-node cfg)))
  62.  
  63. (define-integrable (snode->scfg snode)
  64.   (node->scfg snode set-snode-next-edge!))
  65.  
  66. (define (node->scfg node set-node-next!)
  67.   (make-scfg node
  68.          (list (make-hook node set-node-next!))))
  69.  
  70. (define-integrable (pnode->pcfg pnode)
  71.   (node->pcfg pnode
  72.           set-pnode-consequent-edge!
  73.           set-pnode-alternative-edge!))
  74.  
  75. (define (node->pcfg node set-node-consequent! set-node-alternative!)
  76.   (make-pcfg node
  77.          (list (make-hook node set-node-consequent!))
  78.          (list (make-hook node set-node-alternative!))))
  79.  
  80. (define (snode->pcfg-false snode)
  81.   (make-pcfg snode
  82.          (make-null-hooks)
  83.          (list (make-hook snode set-snode-next-edge!))))
  84.  
  85. (define (snode->pcfg-true snode)
  86.   (make-pcfg snode
  87.          (list (make-hook snode set-snode-next-edge!))
  88.          (make-null-hooks)))
  89.  
  90. (define (pcfg-invert pcfg)
  91.   (make-pcfg (cfg-entry-node pcfg)
  92.          (pcfg-alternative-hooks pcfg)
  93.          (pcfg-consequent-hooks pcfg)))
  94.  
  95. ;;;; Hook Datatype
  96.  
  97. (define-integrable make-hook cons)
  98. (define-integrable hook-node car)
  99. (define-integrable hook-connect cdr)
  100.  
  101. (define (hook=? x y)
  102.   (and (eq? (hook-node x) (hook-node y))
  103.        (eq? (hook-connect x) (hook-connect y))))
  104.  
  105. (define hook-member?
  106.   (member-procedure hook=?))
  107.  
  108. (define-integrable (make-null-hooks)
  109.   '())
  110.  
  111. (define-integrable hooks-null?
  112.   null?)
  113.  
  114. (define (hooks-union x y)
  115.   (let loop ((x x))
  116.     (cond ((null? x) y)
  117.       ((hook-member? (car x) y) (loop (cdr x)))
  118.       (else (cons (car x) (loop (cdr x)))))))
  119.  
  120. (define (hooks-connect! hooks node)
  121.   (for-each (lambda (hook)
  122.           (hook-connect! hook node))
  123.         hooks))
  124.  
  125. (define (hook-connect! hook node)
  126.   (create-edge! (hook-node hook) (hook-connect hook) node))
  127.  
  128. ;;;; Simplicity Tests
  129.  
  130. (define (scfg-simple? scfg)
  131.   (cfg-branch-simple? (cfg-entry-node scfg) (scfg-next-hooks scfg)))
  132.  
  133. (define (pcfg-simple? pcfg)
  134.   (let ((entry-node (cfg-entry-node pcfg)))
  135.     (and (cfg-branch-simple? entry-node (pcfg-consequent-hooks pcfg))
  136.      (cfg-branch-simple? entry-node (pcfg-alternative-hooks pcfg)))))
  137.  
  138. (define (cfg-branch-simple? entry-node hooks)
  139.   (and (not (null? hooks))
  140.        (null? (cdr hooks))
  141.        (eq? entry-node (hook-node (car hooks)))))
  142.  
  143. (define (scfg-null? scfg)
  144.   (or (cfg-null? scfg)
  145.       (cfg-branch-null? (cfg-entry-node scfg)
  146.             (scfg-next-hooks scfg))))
  147.  
  148. (define (pcfg-true? pcfg)
  149.   (and (hooks-null? (pcfg-alternative-hooks pcfg))
  150.        (cfg-branch-null? (cfg-entry-node pcfg)
  151.              (pcfg-consequent-hooks pcfg))))
  152.  
  153. (define (pcfg-false? pcfg)
  154.   (and (hooks-null? (pcfg-consequent-hooks pcfg))
  155.        (cfg-branch-null? (cfg-entry-node pcfg)
  156.              (pcfg-alternative-hooks pcfg))))
  157.  
  158. (define (cfg-branch-null? entry-node hooks)
  159.   (and (cfg-branch-simple? entry-node hooks)
  160.        (cfg-node/noop? entry-node)))
  161.  
  162. ;;;; Node-result Constructors
  163.  
  164. (define (scfg*node->node! scfg next-node)
  165.   (if (scfg-null? scfg)
  166.       next-node
  167.       (begin
  168.     (hooks-connect! (scfg-next-hooks scfg) next-node)
  169.     (cfg-entry-node scfg))))
  170.  
  171. (define (pcfg*node->node! pcfg consequent-node alternative-node)
  172.   (if (cfg-null? pcfg)
  173.       (error "PCFG*NODE->NODE!: Can't have null predicate"))
  174.   (cond ((pcfg-true? pcfg) consequent-node)
  175.     ((pcfg-false? pcfg) alternative-node)
  176.     (else
  177.      (hooks-connect! (pcfg-consequent-hooks pcfg) consequent-node)
  178.      (hooks-connect! (pcfg-alternative-hooks pcfg) alternative-node)
  179.      (cfg-entry-node pcfg))))
  180.  
  181. ;;;; CFG Construction
  182.  
  183. (define-integrable (scfg-next-connect! scfg cfg)
  184.   (hooks-connect! (scfg-next-hooks scfg) (cfg-entry-node cfg)))
  185.  
  186. (define-integrable (pcfg-consequent-connect! pcfg cfg)
  187.   (hooks-connect! (pcfg-consequent-hooks pcfg) (cfg-entry-node cfg)))
  188.  
  189. (define-integrable (pcfg-alternative-connect! pcfg cfg)
  190.   (hooks-connect! (pcfg-alternative-hooks pcfg) (cfg-entry-node cfg)))
  191.  
  192. (define (scfg*scfg->scfg! scfg scfg*)
  193.   (cond ((scfg-null? scfg) scfg*)
  194.     ((scfg-null? scfg*) scfg)
  195.     (else
  196.      (scfg-next-connect! scfg scfg*)
  197.      (make-scfg (cfg-entry-node scfg) (scfg-next-hooks scfg*)))))
  198.  
  199. (define (scfg-append! . scfgs)
  200.   (scfg*->scfg! scfgs))
  201.  
  202. (define scfg*->scfg!
  203.   (let ()
  204.     (define (find-non-null scfgs)
  205.       (if (and (not (null? scfgs))
  206.            (scfg-null? (car scfgs)))
  207.       (find-non-null (cdr scfgs))
  208.       scfgs))
  209.  
  210.     (define (loop first second rest)
  211.       (scfg-next-connect! first second)
  212.       (if (null? rest)
  213.       second
  214.       (loop second (car rest) (find-non-null (cdr rest)))))
  215.  
  216.     (named-lambda (scfg*->scfg! scfgs)
  217.       (let ((first (find-non-null scfgs)))
  218.     (if (null? first)
  219.         (make-null-cfg)
  220.         (let ((second (find-non-null (cdr first))))
  221.           (if (null? second)
  222.           (car first)
  223.           (make-scfg (cfg-entry-node (car first))
  224.                  (scfg-next-hooks
  225.                   (loop (car first)
  226.                     (car second)
  227.                     (find-non-null (cdr second))))))))))))
  228.  
  229. (package (scfg*pcfg->pcfg! scfg*pcfg->scfg!)
  230.  
  231. (define ((scfg*pcfg->cfg! constructor) scfg pcfg)
  232.   (if (cfg-null? pcfg)
  233.       (error "SCFG*PCFG->CFG!: Can't have null predicate"))
  234.   (cond ((scfg-null? scfg)
  235.      (constructor (cfg-entry-node pcfg)
  236.               (pcfg-consequent-hooks pcfg)
  237.               (pcfg-alternative-hooks pcfg)))
  238.     ((pcfg-true? pcfg)
  239.      (constructor (cfg-entry-node scfg)
  240.               (scfg-next-hooks scfg)
  241.               (make-null-hooks)))
  242.     ((pcfg-false? pcfg)
  243.      (constructor (cfg-entry-node scfg)
  244.               (make-null-hooks)
  245.               (scfg-next-hooks scfg)))
  246.     (else
  247.      (scfg-next-connect! scfg pcfg)
  248.      (constructor (cfg-entry-node scfg)
  249.               (pcfg-consequent-hooks pcfg)
  250.               (pcfg-alternative-hooks pcfg)))))
  251.  
  252. (define-export scfg*pcfg->pcfg!
  253.   (scfg*pcfg->cfg! make-pcfg))
  254.  
  255. (define-export scfg*pcfg->scfg!
  256.   (scfg*pcfg->cfg! make-scfg*))
  257.  
  258. )
  259.  
  260. (package (pcfg*scfg->pcfg! pcfg*scfg->scfg!)
  261.  
  262. (define ((pcfg*scfg->cfg! constructor) pcfg consequent alternative)
  263.   (if (cfg-null? pcfg)
  264.       (error "PCFG*SCFG->CFG!: Can't have null predicate"))
  265.   (cond ((pcfg-true? pcfg)
  266.      (constructor (cfg-entry-node consequent)
  267.               (scfg-next-hooks consequent)
  268.               (make-null-hooks)))
  269.     ((pcfg-false? pcfg)
  270.      (constructor (cfg-entry-node alternative)
  271.               (make-null-hooks)
  272.               (scfg-next-hooks alternative)))
  273.     (else
  274.      (constructor (cfg-entry-node pcfg)
  275.               (connect! (pcfg-consequent-hooks pcfg) consequent)
  276.               (connect! (pcfg-alternative-hooks pcfg) alternative)))))
  277.  
  278. (define (connect! hooks scfg)
  279.   (if (or (hooks-null? hooks)
  280.       (scfg-null? scfg))
  281.       hooks
  282.       (begin
  283.     (hooks-connect! hooks (cfg-entry-node scfg))
  284.     (scfg-next-hooks scfg))))
  285.  
  286. (define-export pcfg*scfg->pcfg!
  287.   (pcfg*scfg->cfg! make-pcfg))
  288.  
  289. (define-export pcfg*scfg->scfg!
  290.   (pcfg*scfg->cfg! make-scfg*))
  291.  
  292. )
  293.  
  294. (package (pcfg*pcfg->pcfg! pcfg*pcfg->scfg!)
  295.  
  296. (define ((pcfg*pcfg->cfg! constructor) pcfg consequent alternative)
  297.   (if (cfg-null? pcfg)
  298.       (error "PCFG*PCFG->CFG!: Can't have null predicate"))
  299.   (cond ((pcfg-true? pcfg)
  300.      (constructor (cfg-entry-node consequent)
  301.               (pcfg-consequent-hooks consequent)
  302.               (pcfg-alternative-hooks consequent)))
  303.     ((pcfg-false? pcfg)
  304.      (constructor (cfg-entry-node alternative)
  305.               (pcfg-consequent-hooks alternative)
  306.               (pcfg-alternative-hooks alternative)))
  307.     (else
  308.      (connect! (pcfg-consequent-hooks pcfg)
  309.            consequent
  310.            consequent-select
  311.        (lambda (cchooks cahooks)
  312.          (connect! (pcfg-alternative-hooks pcfg)
  313.                alternative
  314.                alternative-select
  315.            (lambda (achooks aahooks)
  316.          (constructor (cfg-entry-node pcfg)
  317.                   (hooks-union cchooks achooks)
  318.                   (hooks-union cahooks aahooks)))))))))
  319.  
  320. (define (connect! hooks pcfg select receiver)
  321.   (cond ((hooks-null? hooks) (receiver (make-null-hooks) (make-null-hooks)))
  322.     ((cfg-null? pcfg) (select receiver hooks))
  323.     ((pcfg-true? pcfg) (consequent-select receiver hooks))
  324.     ((pcfg-false? pcfg) (alternative-select receiver hooks))
  325.     (else
  326.      (hooks-connect! hooks (cfg-entry-node pcfg))
  327.      (receiver (pcfg-consequent-hooks pcfg)
  328.            (pcfg-alternative-hooks pcfg)))))
  329.  
  330. (define-integrable (consequent-select receiver hooks)
  331.   (receiver hooks (make-null-hooks)))
  332.  
  333. (define-integrable (alternative-select receiver hooks)
  334.   (receiver (make-null-hooks) hooks))
  335.  
  336. (define-export pcfg*pcfg->pcfg!
  337.   (pcfg*pcfg->cfg! make-pcfg))
  338.  
  339. (define-export pcfg*pcfg->scfg!
  340.   (pcfg*pcfg->cfg! make-scfg*))
  341.  
  342. )