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 / sf / emodel.scm < prev    next >
Text File  |  1999-01-02  |  7KB  |  205 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: emodel.scm,v 4.4 1999/01/02 06:19:10 cph Exp $
  4.  
  5. Copyright (c) 1987, 1993, 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. ;;;; SCode Optimizer: Environment Model
  23.  
  24. (declare (usual-integrations)
  25.      (integrate-external "object"))
  26.  
  27. (define (block/make parent safe? bound-variables)
  28.   (let ((block
  29.      (%block/make parent
  30.               safe?
  31.               (let ((n-bound-variables (length bound-variables)))
  32.             (if (fix:<= n-bound-variables block-hash-table-limit)
  33.                 (cons n-bound-variables bound-variables)
  34.                 (make-hash-table bound-variables))))))
  35.     (if parent
  36.     (set-block/children! parent (cons block (block/children parent))))
  37.     block))
  38.  
  39. (define (variable/make&bind! block name)
  40.   (or (%block/lookup-name block name)
  41.       (%variable/make&bind! block name)))
  42.  
  43. (define (%variable/make&bind! block name)
  44.   (let ((variable (variable/make block name '()))
  45.     (bound-variables (block/bound-variables block)))
  46.     (cond ((hash-table? bound-variables)
  47.        (hash-table-store! bound-variables variable))
  48.       ((fix:= (car bound-variables) block-hash-table-limit)
  49.        (set-block/bound-variables!
  50.         block
  51.         (make-hash-table (cons variable (cdr bound-variables)))))
  52.       (else
  53.        (set-car! bound-variables (fix:+ (car bound-variables) 1))
  54.        (set-cdr! bound-variables (cons variable (cdr bound-variables)))))
  55.     variable))
  56.  
  57. (define-integrable block-hash-table-limit
  58.   20)
  59.  
  60. (define (block/lookup-name block name intern?)
  61.   (let search ((block block))
  62.     (or (%block/lookup-name block name)
  63.     (if (block/parent block)
  64.         (search (block/parent block))
  65.         (and intern? (%variable/make&bind! block name))))))
  66.  
  67. (define (%block/lookup-name block name)
  68.   (let ((bound-variables (block/bound-variables block)))
  69.     (if (hash-table? bound-variables)
  70.     (hash-table-lookup bound-variables name)
  71.     (let loop ((variables (cdr bound-variables)))
  72.       (and (not (null? variables))
  73.            (if (eq? name (variable/name (car variables)))
  74.            (car variables)
  75.            (loop (cdr variables))))))))
  76.  
  77. (define (block/limited-lookup block name limit)
  78.   (let search ((block block))
  79.     (and (not (eq? block limit))
  80.      (let ((bound-variables (block/bound-variables block)))
  81.        (if (hash-table? bound-variables)
  82.            (or (hash-table-lookup bound-variables name)
  83.            (and (block/parent block)
  84.             (search (block/parent block))))
  85.            (let loop ((variables (cdr bound-variables)))
  86.          (cond ((null? variables)
  87.             (and (block/parent block)
  88.                  (search (block/parent block))))
  89.                ((eq? name (variable/name (car variables)))
  90.             (car variables))
  91.                (else
  92.             (loop (cdr variables))))))))))
  93.  
  94. (define-structure (hash-table
  95.            (type vector)
  96.            (named (string->symbol "#[(scode-optimizer)hash-table]"))
  97.            (constructor %make-hash-table))
  98.   count
  99.   buckets)
  100.  
  101. (define (make-hash-table variables)
  102.   (let ((count (length variables)))
  103.     (let ((buckets (make-hash-table-buckets (fix:+ count 1))))
  104.       (let ((table (%make-hash-table count buckets)))
  105.     (for-each (lambda (variable)
  106.             (%hash-table-store! buckets variable))
  107.           variables)
  108.     table))))
  109.  
  110. (define (hash-table-store! table variable)
  111.   (let ((count (fix:+ (hash-table-count table) 1)))
  112.     (if (fix:= count (vector-length (hash-table-buckets table)))
  113.     (let ((old-buckets (hash-table-buckets table)))
  114.       (let ((new-buckets (make-hash-table-buckets (fix:+ count count))))
  115.         (do ((h 0 (fix:+ h 1)))
  116.         ((fix:= h count))
  117.           (let ((variable (vector-ref old-buckets h)))
  118.         (if variable
  119.             (%hash-table-store! new-buckets variable))))
  120.         (set-hash-table-buckets! table new-buckets))))
  121.     (set-hash-table-count! table count))
  122.   (%hash-table-store! (hash-table-buckets table) variable))
  123.  
  124. (define (%hash-table-store! buckets variable)
  125.   (let ((k (symbol-hash (variable/name variable)))
  126.     (m (vector-length buckets)))
  127.     (let ((h1 (modulo k m)))
  128.       (if (not (vector-ref buckets h1))
  129.       (vector-set! buckets h1 variable)
  130.       (let ((h2 (fix:+ (modulo k (fix:- m 1)) 1)))
  131.         (let loop ((h h1))
  132.           (let ((h
  133.              (let ((h (fix:+ h h2)))
  134.                (if (fix:< h m)
  135.                h
  136.                (fix:- h m)))))
  137.         (if (not (vector-ref buckets h))
  138.             (vector-set! buckets h variable)
  139.             (loop h)))))))))
  140.  
  141. (define (make-hash-table-buckets n)
  142.   (make-vector (let loop ((primes prime-numbers-stream))
  143.          (if (<= n (car primes))
  144.              (car primes)
  145.              (loop (force (cdr primes)))))
  146.            false))
  147.  
  148. (define (hash-table-lookup table name)
  149.   (let ((buckets (hash-table-buckets table)))
  150.     (let ((k (symbol-hash name))
  151.       (m (vector-length buckets)))
  152.       (let ((h1 (modulo k m)))
  153.     (let ((variable (vector-ref buckets h1)))
  154.       (and variable
  155.            (if (eq? name (variable/name variable))
  156.            variable
  157.            (let ((h2 (fix:+ (modulo k (fix:- m 1)) 1)))
  158.              (let loop ((h h1))
  159.                (let ((h
  160.                   (let ((h (fix:+ h h2)))
  161.                 (if (fix:< h m)
  162.                     h
  163.                     (fix:- h m)))))
  164.              (let ((variable (vector-ref buckets h)))
  165.                (and variable
  166.                 (if (eq? name (variable/name variable))
  167.                     variable
  168.                     (loop h))))))))))))))
  169.  
  170. (define (block/lookup-names block names intern?)
  171.   (map (lambda (name)
  172.      (block/lookup-name block name intern?))
  173.        names))
  174.  
  175. (define (block/for-each-bound-variable block procedure)
  176.   (let ((bound-variables (block/bound-variables block)))
  177.     (if (hash-table? bound-variables)
  178.     (let ((buckets (hash-table-buckets bound-variables)))
  179.       (let ((m (vector-length buckets)))
  180.         (do ((h 0 (fix:+ h 1)))
  181.         ((fix:= h m))
  182.           (if (vector-ref buckets h)
  183.           (procedure (vector-ref buckets h))))))
  184.     (for-each procedure (cdr bound-variables)))))
  185.  
  186. (define (block/bound-variables-list block)
  187.   (let ((bound-variables (block/bound-variables block)))
  188.     (if (hash-table? bound-variables)
  189.     (let ((buckets (hash-table-buckets bound-variables)))
  190.       (let ((m (vector-length buckets)))
  191.         (let loop ((h 0) (result '()))
  192.           (if (fix:= h m)
  193.           result
  194.           (loop (fix:+ h 1)
  195.             (if (vector-ref buckets h)
  196.                 (cons (vector-ref buckets h) result)
  197.                 result))))))
  198.     (cdr bound-variables))))
  199.  
  200. (define (block/unsafe! block)
  201.   (if (block/safe? block)
  202.       (begin
  203.     (set-block/safe?! block false)
  204.     (if (block/parent block)
  205.         (block/unsafe! (block/parent block))))))