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 / rtlbase / rtlexp.scm < prev    next >
Text File  |  1999-01-02  |  10KB  |  309 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: rtlexp.scm,v 4.20 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. ;;;; Register Transfer Language: Expression Operations
  23. ;;; package: (compiler)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define (rtl:invocation? rtl)
  28.   (memq (rtl:expression-type rtl)
  29.     '(INVOCATION:APPLY
  30.       INVOCATION:JUMP
  31.       INVOCATION:COMPUTED-JUMP
  32.       INVOCATION:LEXPR
  33.       INVOCATION:COMPUTED-LEXPR
  34.       INVOCATION:PRIMITIVE
  35.       INVOCATION:SPECIAL-PRIMITIVE
  36.       INVOCATION:UUO-LINK
  37.       INVOCATION:GLOBAL-LINK
  38.       INVOCATION:CACHE-REFERENCE
  39.       INVOCATION:LOOKUP)))
  40.  
  41. (define (rtl:invocation-prefix? rtl)
  42.   (memq (rtl:expression-type rtl)
  43.     '(INVOCATION-PREFIX:DYNAMIC-LINK
  44.       INVOCATION-PREFIX:MOVE-FRAME-UP)))
  45.  
  46. (define (rtl:expression-value-class expression)
  47.   (case (rtl:expression-type expression)
  48.     ((REGISTER)
  49.      (register-value-class (rtl:register-number expression)))
  50.     ((CONS-NON-POINTER CONS-POINTER CONSTANT FIXNUM->OBJECT FLOAT->OBJECT
  51.                GENERIC-BINARY GENERIC-UNARY OFFSET POST-INCREMENT
  52.                PRE-INCREMENT)
  53.      value-class=object)
  54.     ((FIXNUM->ADDRESS OBJECT->ADDRESS
  55.               ASSIGNMENT-CACHE VARIABLE-CACHE
  56.               CONS-CLOSURE CONS-MULTICLOSURE
  57.               ENTRY:CONTINUATION ENTRY:PROCEDURE
  58.               OFFSET-ADDRESS
  59.               FLOAT-OFFSET-ADDRESS
  60.               BYTE-OFFSET-ADDRESS)
  61.      value-class=address)
  62.     ((MACHINE-CONSTANT)
  63.      value-class=immediate)
  64.     ((BYTE-OFFSET CHAR->ASCII)
  65.      value-class=ascii)
  66.     ((OBJECT->DATUM)
  67.      value-class=datum)
  68.     ((ADDRESS->FIXNUM FIXNUM-1-ARG FIXNUM-2-ARGS OBJECT->FIXNUM
  69.               OBJECT->UNSIGNED-FIXNUM)
  70.      value-class=fixnum)
  71.     ((OBJECT->TYPE)
  72.      value-class=type)
  73.     ((OBJECT->FLOAT FLONUM-1-ARG FLONUM-2-ARGS FLOAT-OFFSET)
  74.      value-class=float)
  75.     (else
  76.      (error "unknown RTL expression type" expression))))
  77.  
  78. (define (rtl:object-valued-expression? expression)
  79.   (value-class=object? (rtl:expression-value-class expression)))
  80.  
  81. (define (rtl:volatile-expression? expression)
  82.   (memq (rtl:expression-type expression) '(POST-INCREMENT PRE-INCREMENT)))
  83.  
  84. (define (rtl:machine-register-expression? expression)
  85.   (and (rtl:register? expression)
  86.        (machine-register? (rtl:register-number expression))))
  87.  
  88. (define (rtl:pseudo-register-expression? expression)
  89.   (and (rtl:register? expression)
  90.        (pseudo-register? (rtl:register-number expression))))
  91.  
  92. (define (rtl:stack-reference-expression? expression)
  93.   (and (rtl:offset? expression)
  94.        (interpreter-stack-pointer? (rtl:offset-base expression))))
  95.  
  96. (define (rtl:register-assignment? rtl)
  97.   (and (rtl:assign? rtl)
  98.        (rtl:register? (rtl:assign-address rtl))))
  99.  
  100. (define (rtl:expression-cost expression)
  101.   (if (rtl:register? expression)
  102.       1
  103.       (or (rtl:constant-cost expression)
  104.       (let loop ((parts (cdr expression)) (cost 2))
  105.         (if (null? parts)
  106.         cost
  107.         (loop (cdr parts)
  108.               (if (pair? (car parts))
  109.               (+ cost (rtl:expression-cost (car parts)))
  110.               cost)))))))
  111.  
  112. (define (rtl:map-subexpressions expression procedure)
  113.   (if (rtl:constant? expression)
  114.       expression
  115.       (cons (car expression)
  116.         (map (lambda (x)
  117.            (if (pair? x)
  118.                (procedure x)
  119.                x))
  120.          (cdr expression)))))
  121.  
  122. (define (rtl:for-each-subexpression expression procedure)
  123.   (if (not (rtl:constant? expression))
  124.       (for-each (lambda (x)
  125.           (if (pair? x)
  126.               (procedure x)))
  127.         (cdr expression))))
  128.  
  129. (define (rtl:any-subexpression? expression predicate)
  130.   (and (not (rtl:constant? expression))
  131.        (there-exists? (cdr expression)
  132.      (lambda (x)
  133.        (and (pair? x)
  134.         (predicate x))))))
  135.  
  136. (define (rtl:expression-contains? expression predicate)
  137.   (let loop ((expression expression))
  138.     (or (predicate expression)
  139.     (rtl:any-subexpression? expression loop))))
  140.  
  141. (define (rtl:all-subexpressions? expression predicate)
  142.   (or (rtl:constant? expression)
  143.       (for-all? (cdr expression)
  144.     (lambda (x)
  145.       (or (not (pair? x))
  146.           (predicate x))))))
  147.  
  148. (define (rtl:reduce-subparts expression operator initial if-expression if-not)
  149.   (let ((remap
  150.      (if (rtl:constant? expression)
  151.          if-not
  152.          (lambda (x)
  153.            (if (pair? x)
  154.            (if-expression x)
  155.            (if-not x))))))
  156.     (let loop ((parts (cdr expression)) (accum initial))
  157.       (if (null? parts)
  158.       accum
  159.       (loop (cdr parts)
  160.         (operator accum (remap (car parts))))))))
  161.  
  162. (define (rtl:expression=? x y)
  163.   (let ((type (car x)))
  164.     (and (eq? type (car y))
  165.      (if (eq? type 'CONSTANT)
  166.          (eqv? (cadr x) (cadr y))
  167.          (let loop ((x (cdr x)) (y (cdr y)))
  168.            ;; Because of fixed format, all expressions of same
  169.            ;; type have the same length, and each entry is either
  170.            ;; a subexpression or a non-expression.
  171.            (or (null? x)
  172.            (and (if (pair? (car x))
  173.                 (rtl:expression=? (car x) (car y))
  174.                 (eqv? (car x) (car y)))
  175.             (loop (cdr x) (cdr y)))))))))
  176.  
  177. (define (rtl:match-subexpressions x y predicate)
  178.   (let ((type (car x)))
  179.     (and (eq? type (car y))
  180.      (if (eq? type 'CONSTANT)
  181.          (eqv? (cadr x) (cadr y))
  182.          (let loop ((x (cdr x)) (y (cdr y)))
  183.            (or (null? x)
  184.            (and (if (pair? (car x))
  185.                 (predicate (car x) (car y))
  186.                 (eqv? (car x) (car y)))
  187.             (loop (cdr x) (cdr y)))))))))
  188.  
  189. (define (rtl:refers-to-register? rtl register)
  190.   (let loop
  191.       ((expression
  192.     (if (rtl:register-assignment? rtl) (rtl:assign-expression rtl) rtl)))
  193.     (cond ((not (pair? expression)) false)
  194.       ((rtl:register? expression)
  195.        (= (rtl:register-number expression) register))
  196.       ((rtl:contains-no-substitutable-registers? expression) false)
  197.       (else (there-exists? (cdr expression) loop)))))
  198.  
  199. (define (rtl:subst-register rtl register substitute)
  200.   (letrec
  201.       ((loop
  202.     (lambda (expression)
  203.       (cond ((not (pair? expression)) expression)
  204.         ((rtl:register? expression)
  205.          (if (= (rtl:register-number expression) register)
  206.              substitute
  207.              expression))
  208.         ((rtl:contains-no-substitutable-registers? expression)
  209.          expression)
  210.         (else (cons (car expression) (map loop (cdr expression))))))))
  211.     (if (rtl:register-assignment? rtl)
  212.     (list (rtl:expression-type rtl)
  213.           (rtl:assign-address rtl)
  214.           (loop (rtl:assign-expression rtl)))
  215.     (loop rtl))))
  216.  
  217. (define (rtl:substitutable-registers rtl)
  218.   (if (rtl:register-assignment? rtl)
  219.       (rtl:substitutable-registers (rtl:assign-expression rtl))
  220.       (let outer ((expression rtl) (registers '()))
  221.     (cond ((not (pair? expression)) registers)
  222.           ((rtl:register? expression)
  223.            (let ((register (rtl:register-number expression)))
  224.          (if (memq register registers)
  225.              registers
  226.              (cons register registers))))
  227.           ((rtl:contains-no-substitutable-registers? expression) registers)
  228.           (else
  229.            (let inner
  230.            ((subexpressions (cdr expression)) (registers registers))
  231.          (if (null? subexpressions)
  232.              registers
  233.              (inner (cdr subexpressions)
  234.                 (outer (car subexpressions) registers)))))))))
  235.  
  236. (define (rtl:contains-no-substitutable-registers? expression)
  237.   ;; True for all expressions that cannot possibly contain registers.
  238.   ;; In addition, this is also true of expressions that do contain
  239.   ;; registers but are not candidates for substitution (e.g.
  240.   ;; `pre-increment').
  241.   (memq (rtl:expression-type expression)
  242.     '(ASSIGNMENT-CACHE
  243.       CONS-CLOSURE
  244.       CONS-MULTICLOSURE
  245.       CONSTANT
  246.       ENTRY:CONTINUATION
  247.       ENTRY:PROCEDURE
  248.       MACHINE-CONSTANT
  249.       POST-INCREMENT
  250.       PRE-INCREMENT
  251.       VARIABLE-CACHE)))
  252.  
  253. (define (rtl:constant-expression? expression)
  254.   (case (rtl:expression-type expression)
  255.     ((ASSIGNMENT-CACHE
  256.       CONSTANT
  257.       ENTRY:CONTINUATION
  258.       ENTRY:PROCEDURE
  259.       MACHINE-CONSTANT
  260.       VARIABLE-CACHE)
  261.      true)
  262.     ((BYTE-OFFSET-ADDRESS
  263.       CHAR->ASCII
  264.       CONS-NON-POINTER
  265.       CONS-POINTER
  266.       FIXNUM-1-ARG
  267.       FIXNUM-2-ARGS
  268.       FIXNUM->ADDRESS
  269.       FIXNUM->OBJECT
  270.       FLOAT-OFFSET-ADDRESS
  271.       FLONUM-1-ARG
  272.       FLONUM-2-ARGS
  273.       GENERIC-BINARY
  274.       GENERIC-UNARY
  275.       OBJECT->ADDRESS
  276.       OBJECT->DATUM
  277.       OBJECT->FIXNUM
  278.       OBJECT->TYPE
  279.       OBJECT->UNSIGNED-FIXNUM
  280.       OFFSET-ADDRESS)
  281.      (let loop ((subexpressions (cdr expression)))
  282.        (or (null? subexpressions)
  283.        (and (let ((expression (car subexpressions)))
  284.           (or (not (pair? expression))
  285.               (rtl:constant-expression? expression)))
  286.         (loop (cdr subexpressions))))))
  287.     (else
  288.      false)))
  289.  
  290. (define (rtx-set/union* set sets)
  291.   (let loop ((set set) (sets sets) (accum '()))
  292.     (let ((set (rtx-set/union set accum)))
  293.       (if (null? sets)
  294.       set
  295.       (loop (car sets) (cdr sets) set)))))
  296.  
  297. (define (rtx-set/union x y)
  298.   (if (null? y)
  299.       x
  300.       (let loop ((x x) (y y))
  301.     (if (null? x)
  302.         y
  303.         (loop (cdr x)
  304.           (let ((x (car x)))
  305.             (if (there-exists? y
  306.               (lambda (y)
  307.                 (rtl:expression=? x y)))
  308.             y
  309.             (cons x y))))))))