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 / fgopt / reord.scm < prev    next >
Text File  |  1999-01-02  |  10KB  |  303 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: reord.scm,v 1.2 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1988, 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. ;;;; Parallel assignment problem
  23.  
  24. (declare (usual-integrations))
  25.  
  26. #|
  27.  
  28. Reordering algorithm for operands in tail recursive combinations.  The
  29. problem is NP-hard, so the solution below is not optimal, but it does
  30. pretty well.
  31.  
  32. The program below solves the 1-4 vars case optimally, and does an
  33. almost perfect job on 5 (it loses in less than 2% of the cases).  The
  34. behavior of the program is conceptually quadratic, but since lists are
  35. used to represent the adjacency matrix (rather than bit strings), it
  36. could perform cubically if the matrix was dense.  In practice, the
  37. matrix is often very sparse, so quadratic is a better expectation of
  38. performance.
  39.  
  40. The program below is guaranteed to find an ordering which requires no
  41. temporaries if one exists.  Thus if the reordering found requires none
  42. or one temporary, it is an optimal solution.
  43.  
  44. The algorithm is a greedy algorithm:
  45.  
  46. - It chooses a variable on which no others depend first, it then
  47. removes it from the graph.  This guarantees the optimality when no
  48. temporaries are needed.
  49.  
  50. - If there are none, it chooses a variable according to a set of
  51. heuristics, and removes it from the graph.  The collection of
  52. heuristics has been found (empirically) to be complete for n = 3 or 4,
  53. and to do fairly well for n = 5.  All of the heuristics choose one of
  54. the nodes with the highest degree (most dependencies + dependents)
  55. giving preference to dependencies, dependents, or balance.
  56.  
  57. Note that "self-loops" (edges from a variable to itself) are
  58. eliminated at the outset, since they don't have any effect on the
  59. number of assignments of any ordering.
  60.  
  61. |#
  62.  
  63. ;;;; Graph Abstraction
  64.  
  65. (define-structure (node
  66.            (constructor make-node
  67.                 (target
  68.                  value
  69.                  original-dependencies
  70.                  original-dependents)))
  71.   ;; An assignment representing a target variable (or static link) and
  72.   ;; an expression which will be assigned to the target.
  73.   (target false read-only true)
  74.   (value false read-only true)
  75.  
  76.   ;; The set of assignments on whose targets the value of this
  77.   ;; assignment depends.
  78.   original-dependencies
  79.  
  80.   ;; The set of assignments whose values depend on this assignment's
  81.   ;; target.
  82.   original-dependents
  83.  
  84.   ;; Copies of the above; modified during the reordering algorithm.
  85.   (dependencies (list-copy original-dependencies))
  86.   (dependents (list-copy original-dependents)))
  87.  
  88. (define (make-node-set targets values dependency-sets)
  89.   (map (lambda (target value dependencies)
  90.      (make-node target
  91.             value
  92.             dependencies
  93.             (let loop
  94.             ((targets targets)
  95.              (dependency-sets dependency-sets))
  96.               (cond ((null? targets)
  97.                  '())
  98.                 ;; Why no self-dependents?
  99.                 ((and (not (eq? target (car targets)))
  100.                   (memq target (car dependency-sets)))
  101.                  (cons (car targets)
  102.                    (loop (cdr targets)
  103.                      (cdr dependency-sets))))
  104.                 (else
  105.                  (loop (cdr targets)
  106.                    (cdr dependency-sets)))))))
  107.        targets
  108.        values
  109.        dependency-sets))
  110.  
  111. (define-integrable (copy-node-set nodes)
  112.   (map node-copy nodes))
  113.  
  114. (define (node-copy node)
  115.   (make-node (node-target node)
  116.          (node-value node)
  117.          (node-original-dependencies node)
  118.          (node-original-dependents node)))
  119.  
  120. ;;;; Reordering
  121.  
  122. (define (reorder-assignments nodes)
  123.   ;; Optimize trivial cases
  124.   (let ((n-nodes (length nodes)))
  125.     (case n-nodes
  126.       ((0 1)
  127.        nodes)
  128.       ((2)
  129.        (if (zero? (add-up-cost nodes))
  130.        nodes
  131.        (reverse nodes)))
  132.       ((3)
  133.        (reorder! nodes find-index-most/dependencies))
  134.       (else
  135.        (let loop ((heuristics heuristics) (nodes nodes) (cost n-nodes))
  136.      (if (null? heuristics)
  137.          nodes
  138.          (let* ((nodes* (reorder! (copy-node-set nodes) (car heuristics)))
  139.             (cost* (add-up-cost nodes*)))
  140.            (cond ((< cost* 2) nodes*)
  141.              ((< cost* cost) (loop (cdr heuristics) nodes* cost*))
  142.              (else (loop (cdr heuristics) nodes cost))))))))))
  143.  
  144. (define (add-up-cost nodes)
  145.   (if (null? nodes)
  146.       0
  147.       (let loop ((nodes nodes) (cost 0))
  148.     (if (null? (cdr nodes))
  149.         cost
  150.         (loop (cdr nodes)
  151.           (if (first-node-needs-temporary? nodes) (1+ cost) cost))))))
  152.  
  153. (define (first-node-needs-temporary? nodes)
  154.   (there-exists? (cdr nodes)
  155.     (let ((target (node-target (car nodes))))
  156.       (lambda (node)
  157.     (memq target (node-original-dependencies node))))))
  158.  
  159. (define (reorder! nodes find-index)
  160.   ;; This is expensive.  It could be done for all at once,
  161.   ;; but for now...
  162.   (let ((nodes (list->vector nodes)))
  163.     (let ((last (-1+ (vector-length nodes))))
  164.       (let loop ((index 0))
  165.     (if (< index last)
  166.         (begin
  167.           (let* ((i (find-index nodes index last))
  168.              (node (vector-ref nodes i))
  169.              (target (node-target node)))
  170.         (let loop ((low index))
  171.           (if (<= low last)
  172.               (begin
  173.             (let ((node* (vector-ref nodes low)))
  174.               (if (not (eq? node* node))
  175.                   (begin
  176.                 (set-node-dependencies!
  177.                  node*
  178.                  (delq! target (node-dependencies node*)))
  179.                 (set-node-dependents!
  180.                  node*
  181.                  (delq! target (node-dependents node*))))))
  182.             (loop (1+ low)))))
  183.         (vector-set! nodes i (vector-ref nodes index))
  184.         (vector-set! nodes index node))
  185.           (loop (1+ index))))))
  186.     (vector->list nodes)))
  187.  
  188. ;;;; Heuristics
  189.  
  190. (define (find-index-maker decision)
  191.   (lambda (nodes low high)
  192.     (let ((node (vector-ref nodes low)))
  193.       (if (null? (node-dependents node))
  194.       low
  195.       (let loop
  196.           ((i (1+ low))
  197.            (index low)
  198.            (dependencies (length (node-dependencies node)))
  199.            (dependents (length (node-dependents node))))
  200.         (if (> i high)
  201.         index
  202.         (let ((node (vector-ref nodes i)))
  203.           (if (null? (node-dependents node))
  204.               i
  205.               (let ((dependencies* (length (node-dependencies node)))
  206.                 (dependents* (length (node-dependents node))))
  207.             (if (decision dependencies dependents
  208.                       dependencies* dependents*)
  209.                 (loop (1+ i) i dependencies* dependents*)
  210.                 (loop (1+ i)
  211.                   index dependencies dependents)))))))))))
  212.  
  213. #|
  214.  
  215. ;;; This version chooses the node with the most dependencies.
  216. ;;; Among equals it gives preference to those with the most total.
  217.  
  218. (define find-index-most-dependencies
  219.   (find-index-maker
  220.    (lambda (dependencies dependents dependencies* dependents*)
  221.      (if (= dependencies* dependencies)
  222.      (> dependents* dependents)
  223.      (> dependencies* dependencies)))))
  224.  
  225. ;;; This version chooses the node with the most dependents.
  226. ;;; Among equals it gives preference to those with the most total.
  227.  
  228. (define find-index-most-dependents
  229.   (find-index-maker
  230.    (lambda (dependencies dependents dependencies* dependents*)
  231.      (if (= dependents* dependents)
  232.      (> dependencies* dependencies)
  233.      (> dependents* dependents)))))
  234.  
  235. |#
  236.  
  237. ;;; This version chooses the node with the most total edges.
  238. ;;; Among equals it gives preference to those with an approximately
  239. ;;; equal number of dependencies and dependents.
  240.  
  241. (define find-index-most/balanced
  242.   (find-index-maker
  243.    (lambda (dependencies dependents dependencies* dependents*)
  244.      (let ((total (+ dependencies dependents))
  245.        (total* (+ dependencies* dependents*)))
  246.        (if (= total* total)
  247.        (< (abs (- dependencies* dependents*))
  248.           (abs (- dependencies dependents)))
  249.        (> total* total))))))
  250.  
  251. ;;; This version chooses the node with the most total edges.
  252. ;;; Among equals it gives preference to those with the most
  253. ;;; dependencies.
  254.  
  255. (define find-index-most/dependencies
  256.   (find-index-maker
  257.    (lambda (dependencies dependents dependencies* dependents*)
  258.      (let ((total (+ dependencies dependents))
  259.        (total* (+ dependencies* dependents*)))
  260.        (if (= total* total)
  261.        (> dependencies* dependencies)
  262.        (> total* total))))))
  263.  
  264. ;;; This version chooses the node with the most total edges.
  265. ;;; Among equals it gives preference to those with the most
  266. ;;; dependents.
  267.  
  268. (define find-index-most/dependents
  269.   (find-index-maker
  270.    (lambda (dependencies dependents dependencies* dependents*)
  271.      (let ((total (+ dependencies dependents))
  272.        (total* (+ dependencies* dependents*)))
  273.        (if (= total* total)
  274.        (> dependents* dependents)
  275.        (> total* total))))))
  276.  
  277. ;;; The following two are like the two above but have preference to
  278. ;;; the right rather than the left.
  279.  
  280. (define find-index-most/dependencies-
  281.   (find-index-maker
  282.    (lambda (dependencies dependents dependencies* dependents*)
  283.      (let ((total (+ dependencies dependents))
  284.        (total* (+ dependencies* dependents*)))
  285.        (if (= total* total)
  286.        (>= dependencies* dependencies)
  287.        (> total* total))))))
  288.  
  289. (define find-index-most/dependents-
  290.   (find-index-maker
  291.    (lambda (dependencies dependents dependencies* dependents*)
  292.      (let ((total (+ dependencies dependents))
  293.        (total* (+ dependencies* dependents*)))
  294.        (if (= total* total)
  295.        (>= dependents* dependents)
  296.        (> total* total))))))
  297.  
  298. (define heuristics
  299.   (list find-index-most/dependencies
  300.     find-index-most/dependents
  301.     find-index-most/dependencies-
  302.     find-index-most/dependents-
  303.     find-index-most/balanced))