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 / rtlopt / rcsesr.scm < prev    next >
Encoding:
Text File  |  1999-01-02  |  3.5 KB  |  100 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: rcsesr.scm,v 4.4 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1987-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. ;;;; RTL Common Subexpression Elimination: Stack References
  23.  
  24. (declare (usual-integrations))
  25.  
  26. (define *stack-offset*)
  27. (define *stack-reference-quantities*)
  28.  
  29. (define-integrable (memory->stack-offset offset)
  30.   ;; Assume this operation is a self-inverse.
  31.   (stack->memory-offset offset))
  32.  
  33. (define (stack-push? expression)
  34.   (and (rtl:pre-increment? expression)
  35.        (interpreter-stack-pointer? (rtl:address-register expression))
  36.        (= -1 (memory->stack-offset (rtl:address-number expression)))))
  37.  
  38. (define (stack-pop? expression)
  39.   (and (rtl:post-increment? expression)
  40.        (interpreter-stack-pointer? (rtl:address-register expression))
  41.        (= 1 (memory->stack-offset (rtl:address-number expression)))))
  42.  
  43. (define (stack-reference? expression)
  44.   (and (rtl:offset? expression)
  45.        (interpreter-stack-pointer? (rtl:address-register expression))))
  46.  
  47. (define (stack-reference-quantity expression)
  48.   (let ((n (+ *stack-offset*
  49.           (rtl:machine-constant-value (rtl:offset-offset expression)))))
  50.     (let ((entry (ass= n *stack-reference-quantities*)))
  51.       (if entry
  52.       (cdr entry)
  53.       (let ((quantity (new-quantity false)))
  54.         (set! *stack-reference-quantities*
  55.           (cons (cons n quantity)
  56.             *stack-reference-quantities*))
  57.         quantity)))))
  58.  
  59. (define (set-stack-reference-quantity! expression quantity)
  60.   (let ((n (+ *stack-offset*
  61.           (rtl:machine-constant-value (rtl:offset-offset expression)))))
  62.     (let ((entry (ass= n *stack-reference-quantities*)))
  63.       (if entry
  64.       (set-cdr! entry quantity)
  65.       (set! *stack-reference-quantities*
  66.         (cons (cons n quantity)
  67.               *stack-reference-quantities*)))))
  68.   unspecific)
  69.  
  70. (define (stack-pointer-adjust! offset)
  71.   (let ((offset (memory->stack-offset offset)))
  72.     (if (positive? offset)        ;i.e. if a pop
  73.     (stack-region-invalidate! 0 offset)))
  74.   (set! *stack-offset* (+ *stack-offset* offset))
  75.   (stack-pointer-invalidate!))
  76.  
  77. (define-integrable (stack-pointer-invalidate!)
  78.   (register-expression-invalidate! (interpreter-stack-pointer)))
  79.  
  80. (define-integrable (stack-invalidate!)
  81.   (set! *stack-reference-quantities* '()))
  82.  
  83. (define (stack-region-invalidate! start end)
  84.   (let loop ((i start) (quantities *stack-reference-quantities*))
  85.     (if (< i end)
  86.     (loop (1+ i)
  87.           (del-ass=! (+ *stack-offset* (stack->memory-offset i))
  88.              quantities))
  89.     (set! *stack-reference-quantities* quantities))))
  90.  
  91. (define (stack-reference-invalidate! expression)
  92.   (expression-invalidate! expression)
  93.   (set! *stack-reference-quantities*
  94.     (del-ass=! (+ *stack-offset*
  95.               (rtl:machine-constant-value
  96.                (rtl:offset-offset expression)))
  97.            *stack-reference-quantities*)))
  98.  
  99. (define ass= (association-procedure = car))
  100. (define del-ass=! (delete-association-procedure list-deletor! = car))