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 / rinvex.scm < prev    next >
Encoding:
Text File  |  1999-01-02  |  12.8 KB  |  358 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: rinvex.scm,v 1.9 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 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. ;;;; RTL Invertible Expression Elimination
  23. ;;; package: (compiler rtl-optimizer invertible-expression-elimination)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define *initial-queue*)
  28. (define *branch-queue*)
  29. (define *register-values*)
  30.  
  31. (define (invertible-expression-elimination rgraphs)
  32.   (with-new-node-marks (lambda () (for-each walk-rgraph rgraphs))))
  33.  
  34. (define (walk-rgraph rgraph)
  35.   (fluid-let ((*current-rgraph* rgraph)
  36.           (*initial-queue* (make-queue))
  37.           (*branch-queue* '())
  38.           (*register-values*
  39.            (make-vector (rgraph-n-registers rgraph) false)))
  40.     (for-each (lambda (edge)
  41.         (enqueue!/unsafe *initial-queue* (edge-right-node edge)))
  42.           (rgraph-initial-edges rgraph))
  43.     (continue-walk)))
  44.  
  45. (define (continue-walk)
  46.   (cond ((not (null? *branch-queue*))
  47.      (let ((entry (car *branch-queue*)))
  48.        (set! *branch-queue* (cdr *branch-queue*))
  49.        (set! *register-values* (car entry))
  50.        (walk-bblock (cdr entry))))
  51.     ((not (queue-empty? *initial-queue*))
  52.      (vector-fill! *register-values* false)
  53.      (walk-bblock (dequeue!/unsafe *initial-queue*)))))
  54.  
  55. (define (walk-bblock bblock)
  56.   (let loop ((rinst (bblock-instructions bblock)))
  57.     (let ((rtl (rinst-rtl rinst)))
  58.       ((lookup-method (rtl:expression-type rtl)) rtl))
  59.     (if (rinst-next rinst)
  60.     (loop (rinst-next rinst))))
  61.   (node-mark! bblock)
  62.   (if (sblock? bblock)
  63.       (let ((next (snode-next bblock)))
  64.     (if (walk-next? next)
  65.         (walk-next next)
  66.         (continue-walk)))
  67.       (let ((consequent (pnode-consequent bblock))
  68.         (alternative (pnode-alternative bblock)))
  69.     (if (walk-next? consequent)
  70.         (if (walk-next? alternative)
  71.         (if (node-previous>1? consequent)
  72.             (begin
  73.               (enqueue!/unsafe *initial-queue* consequent)
  74.               (walk-next alternative))
  75.             (begin
  76.               (if (node-previous>1? alternative)
  77.               (enqueue!/unsafe *initial-queue* alternative)
  78.               (set! *branch-queue*
  79.                 (cons (cons (vector-copy *register-values*)
  80.                         alternative)
  81.                       *branch-queue*)))
  82.               (walk-bblock consequent)))
  83.         (walk-next consequent))
  84.         (if (walk-next? alternative)
  85.         (walk-next alternative)
  86.         (continue-walk))))))
  87.  
  88. (define-integrable (walk-next? bblock)
  89.   (and bblock (not (node-marked? bblock))))
  90.  
  91. (define-integrable (walk-next bblock)
  92.   (if (node-previous>1? bblock) (vector-fill! *register-values* false))
  93.   (walk-bblock bblock))
  94.  
  95. (define-integrable (register-value register)
  96.   (vector-ref *register-values* register))
  97.  
  98. (define-integrable (set-register-value! register value)
  99.   (vector-set! *register-values* register value)
  100.   unspecific)
  101.  
  102. (define (expression-update! get-expression set-expression! object)
  103.   ;; Note: The following code may cause pseudo-register copies to be
  104.   ;; generated since it would have to propagate some of the
  105.   ;; simplifications, and then delete the now unused registers.  This
  106.   ;; is not worthwhile since the previous register is likely to be
  107.   ;; dead at this point, so the lap-level register allocator will
  108.   ;; reuse the alias achieving the effect of the deletion.  Ultimately
  109.   ;; the expression invertibility code should be integrated into the
  110.   ;; CSE and this register deletion would happen there.
  111.   (set-expression!
  112.    object
  113.    (let loop ((expression (get-expression object)))
  114.      (if (rtl:register? expression)
  115.      expression
  116.      (optimize-expression (rtl:map-subexpressions expression loop))))))
  117.  
  118. (define (optimize-expression expression)
  119.   (let loop
  120.       ((identities
  121.     (list-transform-positive identities
  122.       (let ((type (rtl:expression-type expression)))
  123.         (lambda (identity)
  124.           (eq? type (car (cadr identity))))))))
  125.     (cond ((null? identities)
  126.        expression)
  127.       ((let ((identity (car identities)))
  128.          (let ((in-domain? (car identity))
  129.            (matching-operation (cadr identity)))
  130.            (let loop
  131.            ((operations (cddr identity))
  132.             (subexpression ((cadr matching-operation) expression)))
  133.          (if (null? operations)
  134.              (and (valid-subexpression? subexpression)
  135.               (in-domain?
  136.                (rtl:expression-value-class subexpression))
  137.               subexpression)
  138.              (let ((subexpression
  139.                 (canonicalize-subexpression subexpression)))
  140.                (and (eq? (caar operations)
  141.                  (rtl:expression-type subexpression))
  142.                 (loop (cdr operations)
  143.                   ((cadar operations) subexpression))))))))
  144.        => optimize-expression)
  145.       (else
  146.        (loop (cdr identities))))))
  147.  
  148. (define identities
  149.   ;; Each entry is composed of a value class and a sequence of
  150.   ;; operations whose composition is the identity for that value
  151.   ;; class.  Each operation is described by the operator and the
  152.   ;; selector for the relevant operand.
  153.   `((,value-class=value? (OBJECT->FIXNUM ,rtl:object->fixnum-expression)
  154.              (FIXNUM->OBJECT ,rtl:fixnum->object-expression))
  155.     (,value-class=value? (FIXNUM->OBJECT ,rtl:fixnum->object-expression)
  156.              (OBJECT->FIXNUM ,rtl:object->fixnum-expression))
  157.     (,value-class=value? (OBJECT->UNSIGNED-FIXNUM
  158.               ,rtl:object->unsigned-fixnum-expression)
  159.              (FIXNUM->OBJECT ,rtl:fixnum->object-expression))
  160.     (,value-class=value? (FIXNUM->OBJECT ,rtl:fixnum->object-expression)
  161.              (OBJECT->UNSIGNED-FIXNUM
  162.               ,rtl:object->unsigned-fixnum-expression))
  163.     (,value-class=value? (FIXNUM->ADDRESS ,rtl:fixnum->address-expression)
  164.              (ADDRESS->FIXNUM ,rtl:address->fixnum-expression))
  165.     (,value-class=value? (ADDRESS->FIXNUM ,rtl:address->fixnum-expression)
  166.              (FIXNUM->ADDRESS ,rtl:fixnum->address-expression))
  167.     (,value-class=value? (OBJECT->FLOAT ,rtl:object->float-expression)
  168.              (FLOAT->OBJECT ,rtl:float->object-expression))
  169.     (,value-class=value? (FLOAT->OBJECT ,rtl:float->object-expression)
  170.              (OBJECT->FLOAT ,rtl:object->float-expression))
  171.     (,value-class=address? (OBJECT->ADDRESS ,rtl:object->address-expression)
  172.                (CONS-POINTER ,rtl:cons-pointer-datum))
  173.     ;; The following are not value-class=datum? and value-class=type?
  174.     ;; because they are slightly more general.
  175.     (,value-class=immediate? (OBJECT->DATUM ,rtl:object->datum-expression)
  176.                  (CONS-NON-POINTER ,rtl:cons-non-pointer-datum))
  177.     (,value-class=immediate? (OBJECT->TYPE ,rtl:object->type-expression)
  178.                  (CONS-POINTER ,rtl:cons-pointer-type))
  179.     (,value-class=immediate? (OBJECT->TYPE ,rtl:object->type-expression)
  180.                  (CONS-NON-POINTER ,rtl:cons-non-pointer-type))))
  181.  
  182. (define (valid-subexpression? expression)
  183.   ;; Machine registers not allowed because they are volatile.
  184.   ;; Ideally at this point we could introduce a copy to the
  185.   ;; value of the machine register required, but it is too late
  186.   ;; to do this.  Perhaps always copying machine registers out
  187.   ;; before using them would make this win.
  188.   (or (not (rtl:register? expression))
  189.       (rtl:pseudo-register-expression? expression)))
  190.  
  191. (define (canonicalize-subexpression expression)
  192.   (or (and (rtl:pseudo-register-expression? expression)
  193.        (register-value (rtl:register-number expression)))
  194.       expression))
  195.  
  196. (define (define-method type method)
  197.   (let ((entry (assq type methods)))
  198.     (if entry
  199.     (set-cdr! entry method)
  200.     (set! methods (cons (cons type method) methods))))
  201.   type)
  202.  
  203. (define (lookup-method type)
  204.   (if (eq? type 'ASSIGN)
  205.       walk/assign
  206.       (let ((entry (assq type methods)))
  207.     (if (not entry)
  208.         (error "Missing method" type))
  209.     (cdr entry))))
  210.  
  211. (define methods
  212.   '())
  213.  
  214. (define (walk/assign statement)
  215.   (expression-update! rtl:assign-expression
  216.               rtl:set-assign-expression!
  217.               statement)
  218.   (let ((address (rtl:assign-address statement)))
  219.     (if (rtl:pseudo-register-expression? address)
  220.     (set-register-value! (rtl:register-number address)
  221.                  (rtl:assign-expression statement)))))
  222.  
  223. (define-method 'INVOCATION:SPECIAL-PRIMITIVE
  224.   (lambda (statement)
  225.     statement
  226.     (for-each-pseudo-register
  227.      (lambda (register)
  228.        (set-register-value! register false)))))
  229.  
  230. (for-each (lambda (type)
  231.         (define-method type (lambda (statement) statement unspecific)))
  232.       '(CLOSURE-HEADER
  233.         CONTINUATION-ENTRY
  234.         CONTINUATION-HEADER
  235.         IC-PROCEDURE-HEADER
  236.         INVOCATION:APPLY
  237.         INVOCATION:COMPUTED-JUMP
  238.         INVOCATION:COMPUTED-LEXPR
  239.         INVOCATION:JUMP
  240.         INVOCATION:LEXPR
  241.         INVOCATION:PRIMITIVE
  242.         INVOCATION:UUO-LINK
  243.         INVOCATION:GLOBAL-LINK
  244.         OPEN-PROCEDURE-HEADER
  245.         OVERFLOW-TEST
  246.         POP-RETURN
  247.         PROCEDURE-HEADER))
  248.  
  249. (define (define-one-arg-method type get set)
  250.   (define-method type
  251.     (lambda (statement)
  252.       (expression-update! get set statement))))
  253.  
  254. (define-one-arg-method 'FIXNUM-PRED-1-ARG
  255.   rtl:fixnum-pred-1-arg-operand
  256.   rtl:set-fixnum-pred-1-arg-operand!)
  257.  
  258. (define-one-arg-method 'FLONUM-PRED-1-ARG
  259.   rtl:flonum-pred-1-arg-operand
  260.   rtl:set-flonum-pred-1-arg-operand!)
  261.  
  262. (define-one-arg-method 'TYPE-TEST
  263.   rtl:type-test-expression
  264.   rtl:set-type-test-expression!)
  265.  
  266. (define-one-arg-method 'PRED-1-ARG
  267.   rtl:pred-1-arg-operand
  268.   rtl:set-pred-1-arg-operand!)
  269.  
  270. (define-one-arg-method 'INVOCATION:CACHE-REFERENCE
  271.   rtl:invocation:cache-reference-name
  272.   rtl:set-invocation:cache-reference-name!)
  273.  
  274. (define-one-arg-method 'INVOCATION:LOOKUP
  275.   rtl:invocation:lookup-environment
  276.   rtl:set-invocation:lookup-environment!)
  277.  
  278. (define-one-arg-method 'INVOCATION-PREFIX:MOVE-FRAME-UP
  279.   rtl:invocation-prefix:move-frame-up-locative
  280.   rtl:set-invocation-prefix:move-frame-up-locative!)
  281.  
  282. (define-one-arg-method 'INTERPRETER-CALL:ACCESS
  283.   rtl:interpreter-call:access-environment
  284.   rtl:set-interpreter-call:access-environment!)
  285.  
  286. (define-one-arg-method 'INTERPRETER-CALL:CACHE-REFERENCE
  287.   rtl:interpreter-call:cache-reference-name
  288.   rtl:set-interpreter-call:cache-reference-name!)
  289.  
  290. (define-one-arg-method 'INTERPRETER-CALL:CACHE-UNASSIGNED?
  291.   rtl:interpreter-call:cache-unassigned?-name
  292.   rtl:set-interpreter-call:cache-unassigned?-name!)
  293.  
  294. (define-one-arg-method 'INTERPRETER-CALL:LOOKUP
  295.   rtl:interpreter-call:lookup-environment
  296.   rtl:set-interpreter-call:lookup-environment!)
  297.  
  298. (define-one-arg-method 'INTERPRETER-CALL:UNASSIGNED?
  299.   rtl:interpreter-call:unassigned?-environment
  300.   rtl:set-interpreter-call:unassigned?-environment!)
  301.  
  302. (define-one-arg-method 'INTERPRETER-CALL:UNBOUND?
  303.   rtl:interpreter-call:unbound?-environment
  304.   rtl:set-interpreter-call:unbound?-environment!)
  305.  
  306. (define (define-two-arg-method type get-1 set-1 get-2 set-2)
  307.   (define-method type
  308.     (lambda (statement)
  309.       (expression-update! get-1 set-1 statement)
  310.       (expression-update! get-2 set-2 statement))))
  311.  
  312. (define-two-arg-method 'EQ-TEST
  313.   rtl:eq-test-expression-1
  314.   rtl:set-eq-test-expression-1!
  315.   rtl:eq-test-expression-2
  316.   rtl:set-eq-test-expression-2!)
  317.  
  318. (define-two-arg-method 'PRED-2-ARGS
  319.   rtl:pred-2-args-operand-1
  320.   rtl:set-pred-2-args-operand-1!
  321.   rtl:pred-2-args-operand-2
  322.   rtl:set-pred-2-args-operand-2!)
  323.  
  324. (define-two-arg-method 'FIXNUM-PRED-2-ARGS
  325.   rtl:fixnum-pred-2-args-operand-1
  326.   rtl:set-fixnum-pred-2-args-operand-1!
  327.   rtl:fixnum-pred-2-args-operand-2
  328.   rtl:set-fixnum-pred-2-args-operand-2!)
  329.  
  330. (define-two-arg-method 'FLONUM-PRED-2-ARGS
  331.   rtl:flonum-pred-2-args-operand-1
  332.   rtl:set-flonum-pred-2-args-operand-1!
  333.   rtl:flonum-pred-2-args-operand-2
  334.   rtl:set-flonum-pred-2-args-operand-2!)
  335.  
  336. (define-two-arg-method 'INVOCATION-PREFIX:DYNAMIC-LINK
  337.   rtl:invocation-prefix:dynamic-link-locative
  338.   rtl:set-invocation-prefix:dynamic-link-locative!
  339.   rtl:invocation-prefix:dynamic-link-register
  340.   rtl:set-invocation-prefix:dynamic-link-register!)
  341.  
  342. (define-two-arg-method 'INTERPRETER-CALL:CACHE-ASSIGNMENT
  343.   rtl:interpreter-call:cache-assignment-name
  344.   rtl:set-interpreter-call:cache-assignment-name!
  345.   rtl:interpreter-call:cache-assignment-value
  346.   rtl:set-interpreter-call:cache-assignment-value!)
  347.  
  348. (define-two-arg-method 'INTERPRETER-CALL:DEFINE
  349.   rtl:interpreter-call:define-environment
  350.   rtl:set-interpreter-call:define-environment!
  351.   rtl:interpreter-call:define-value
  352.   rtl:set-interpreter-call:define-value!)
  353.  
  354. (define-two-arg-method 'INTERPRETER-CALL:SET!
  355.   rtl:interpreter-call:set!-environment
  356.   rtl:set-interpreter-call:set!-environment!
  357.   rtl:interpreter-call:set!-value
  358.   rtl:set-interpreter-call:set!-value!)