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 / rcse1.scm < prev    next >
Encoding:
Text File  |  1999-01-02  |  16.0 KB  |  449 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: rcse1.scm,v 4.24 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. ;;;; RTL Common Subexpression Elimination: Codewalker
  23. ;;;  Based on the GNU C Compiler
  24. ;;; package: (compiler rtl-cse)
  25.  
  26. (declare (usual-integrations))
  27.  
  28. (define *initial-queue*)
  29. (define *branch-queue*)
  30.  
  31. (define (common-subexpression-elimination rgraphs)
  32.   (with-new-node-marks (lambda () (for-each cse-rgraph rgraphs))))
  33.  
  34. (define (cse-rgraph rgraph)
  35.   (fluid-let ((*current-rgraph* rgraph)
  36.           (*next-quantity-number* 0)
  37.           (*initial-queue* (make-queue))
  38.           (*branch-queue* '()))
  39.     (for-each (lambda (edge)
  40.         (enqueue!/unsafe *initial-queue* (edge-right-node edge)))
  41.           (rgraph-initial-edges rgraph))
  42.     (fluid-let ((*register-tables*
  43.          (register-tables/make (rgraph-n-registers rgraph)))
  44.         (*hash-table*)
  45.         (*stack-offset*)
  46.         (*stack-reference-quantities*))
  47.       (continue-walk))))
  48.  
  49. (define (continue-walk)
  50.   (cond ((not (null? *branch-queue*))
  51.      (let ((entry (car *branch-queue*)))
  52.        (set! *branch-queue* (cdr *branch-queue*))
  53.        (let ((state (car entry)))
  54.          (set! *register-tables* (state/register-tables state))
  55.          (set! *hash-table* (state/hash-table state))
  56.          (set! *stack-offset* (state/stack-offset state))
  57.          (set! *stack-reference-quantities*
  58.            (state/stack-reference-quantities state)))
  59.        (walk-bblock (cdr entry))))
  60.     ((not (queue-empty? *initial-queue*))
  61.      (state/reset!)
  62.      (walk-bblock (dequeue!/unsafe *initial-queue*)))))
  63.  
  64. (define-structure (state (type vector) (conc-name state/))
  65.   (register-tables false read-only true)
  66.   (hash-table false read-only true)
  67.   (stack-offset false read-only true)
  68.   (stack-reference-quantities false read-only true))
  69.  
  70. (define (state/reset!)
  71.   (register-tables/reset! *register-tables*)
  72.   (set! *hash-table* (make-hash-table))
  73.   (set! *stack-offset* 0)
  74.   (set! *stack-reference-quantities* '())
  75.   unspecific)
  76.  
  77. (define (state/get)
  78.   (make-state (register-tables/copy *register-tables*)
  79.           (hash-table-copy *hash-table*)
  80.           *stack-offset*
  81.           (map (lambda (entry)
  82.              (cons (car entry) (quantity-copy (cdr entry))))
  83.            *stack-reference-quantities*)))
  84.  
  85. (define (walk-bblock bblock)
  86.   (let loop ((rinst (bblock-instructions bblock)))
  87.     (let ((rtl (rinst-rtl rinst)))
  88.       ((if (eq? (rtl:expression-type rtl) 'ASSIGN)
  89.        cse/assign
  90.        (let ((entry (assq (rtl:expression-type rtl) cse-methods)))
  91.          (if (not entry)
  92.          (error "Missing CSE method" (rtl:expression-type rtl)))
  93.          (cdr entry)))
  94.        rtl))
  95.     (if (rinst-next rinst)
  96.     (loop (rinst-next rinst))))
  97.   (node-mark! bblock)
  98.   (if (sblock? bblock)
  99.       (let ((next (snode-next bblock)))
  100.     (if (walk-next? next)
  101.         (walk-next next)
  102.         (continue-walk)))
  103.       (let ((consequent (pnode-consequent bblock))
  104.         (alternative (pnode-alternative bblock)))
  105.     (if (walk-next? consequent)
  106.         (if (walk-next? alternative)
  107.         (if (node-previous>1? consequent)
  108.             (begin (enqueue!/unsafe *initial-queue* consequent)
  109.                (walk-next alternative))
  110.             (begin (if (node-previous>1? alternative)
  111.                    (enqueue!/unsafe *initial-queue* alternative)
  112.                    (set! *branch-queue*
  113.                      (cons (cons (state/get) alternative)
  114.                        *branch-queue*)))
  115.                (walk-bblock consequent)))
  116.         (walk-next consequent))
  117.         (if (walk-next? alternative)
  118.         (walk-next alternative)
  119.         (continue-walk))))))
  120.  
  121. (define-integrable (walk-next? bblock)
  122.   (and bblock (not (node-marked? bblock))))
  123.  
  124. (define-integrable (walk-next bblock)
  125.   (if (node-previous>1? bblock) (state/reset!))
  126.   (walk-bblock bblock))
  127.  
  128. (define (define-cse-method type method)
  129.   (let ((entry (assq type cse-methods)))
  130.     (if entry
  131.     (set-cdr! entry method)
  132.     (set! cse-methods (cons (cons type method) cse-methods))))
  133.   type)
  134.  
  135. (define cse-methods
  136.   '())
  137.  
  138. (define (cse/assign statement)
  139.   (expression-replace! rtl:assign-expression rtl:set-assign-expression!
  140.                statement
  141.     (lambda (volatile? insert-source!)
  142.       ((let ((address (rtl:assign-address statement)))
  143.      (if volatile? (notice-pop! (rtl:assign-expression statement)))
  144.      (cond ((rtl:register? address) cse/assign/register)
  145.            ((stack-reference? address) cse/assign/stack-reference)
  146.            ((and (rtl:pre-increment? address)
  147.              (interpreter-stack-pointer?
  148.               (rtl:address-register address)))
  149.         cse/assign/stack-push)
  150.            ((interpreter-register-reference? address)
  151.         cse/assign/interpreter-register)
  152.            (else
  153.         (let ((address (expression-canonicalize address)))
  154.           (rtl:set-assign-address! statement address)
  155.           cse/assign/general))))
  156.        (rtl:assign-address statement)
  157.        (rtl:assign-expression statement)
  158.        volatile?
  159.        insert-source!))))
  160.  
  161. (define (cse/assign/register address expression volatile? insert-source!)
  162.   (if (interpreter-stack-pointer? address)
  163.       (if (and (rtl:offset? expression)
  164.            (interpreter-stack-pointer? (rtl:offset-base expression))
  165.            (rtl:machine-constant? (rtl:offset-offset expression)))
  166.       (stack-pointer-adjust!
  167.        (rtl:machine-constant-value (rtl:offset-offset expression)))
  168.       (begin
  169.         (stack-invalidate!)
  170.         (stack-pointer-invalidate!)))
  171.       (register-expression-invalidate! address))
  172.   (if (and (not volatile?)
  173.        (pseudo-register? (rtl:register-number address)))
  174.       (insert-register-destination! address (insert-source!))))
  175.  
  176. (define (cse/assign/stack-reference address expression volatile?
  177.                     insert-source!)
  178.   expression
  179.   (stack-reference-invalidate! address)
  180.   (if (not volatile?)
  181.       (insert-stack-destination! address (insert-source!))))
  182.  
  183. (define (cse/assign/stack-push address expression volatile? insert-source!)
  184.   expression
  185.   (let ((adjust!
  186.      (lambda ()
  187.        (stack-pointer-adjust! (rtl:address-number address)))))
  188.     (if (not volatile?)
  189.     (let ((element (insert-source!)))
  190.       (adjust!)
  191.       (insert-stack-destination!
  192.        (rtl:make-offset (interpreter-stack-pointer)
  193.                 (rtl:make-machine-constant 0))
  194.        element))
  195.     (adjust!))))
  196.  
  197. (define (cse/assign/interpreter-register address expression volatile?
  198.                      insert-source!)
  199.   expression
  200.   (let ((hash (expression-hash address)))
  201.     (let ((memory-invalidate!
  202.        (lambda ()
  203.          (hash-table-delete! hash (hash-table-lookup hash address)))))
  204.       (if volatile?
  205.       (memory-invalidate!)
  206.       (assignment-memory-insertion address
  207.                        hash
  208.                        insert-source!
  209.                        memory-invalidate!)))))
  210.  
  211. (define (cse/assign/general address expression volatile? insert-source!)
  212.   expression
  213.   (full-expression-hash address
  214.     (lambda (hash volatile?* in-memory?)
  215.       in-memory?
  216.       (let ((memory-invalidate!
  217.          (cond ((stack-pop? address)
  218.             (lambda () unspecific))
  219.            ((and (memq (rtl:expression-type address)
  220.                    '(PRE-INCREMENT POST-INCREMENT))
  221.              (interpreter-free-pointer?
  222.               (rtl:address-register address)))
  223.             (lambda ()
  224.               (register-expression-invalidate!
  225.                (rtl:address-register address))))
  226.            ((expression-address-varies? address)
  227.             (lambda ()
  228.               (hash-table-delete-class! element-in-memory?)))
  229.            (else
  230.             (lambda ()
  231.               (hash-table-delete! hash
  232.                       (hash-table-lookup hash address))
  233.               (varying-address-invalidate!))))))
  234.     (if (or volatile? volatile?*)
  235.         (memory-invalidate!)
  236.         (assignment-memory-insertion address
  237.                      hash
  238.                      insert-source!
  239.                      memory-invalidate!)))))
  240.   (notice-pop! address))
  241.  
  242. (define (notice-pop! expression)
  243.   ;; **** Kludge.  Works only because stack-pointer
  244.   ;; gets used in very fixed way by code generator.
  245.   (if (stack-pop? expression)
  246.       (stack-pointer-adjust! (rtl:address-number expression))))
  247.  
  248. (define (assignment-memory-insertion address hash insert-source!
  249.                      memory-invalidate!)
  250.   #|
  251.   ;; This does not cause bugs (false hash number passed to
  252.   ;; insert-memory-destination! fixed one), but does not do anything
  253.   ;; useful.  The idea of doing optimization on the address of a
  254.   ;; memory assignment does not work since the RTL does not
  255.   ;; distinguish addresses from references.  When the RTL is changed,
  256.   ;; we can do CSE on the memory address.
  257.   (let ((address (find-cheapest-expression address hash false)))
  258.     (let ((element (insert-source!)))
  259.       (memory-invalidate!)
  260.       (insert-memory-destination! address element false)))
  261.   |#
  262.   hash
  263.   (insert-source!)
  264.   (memory-invalidate!)
  265.   (mention-registers! address))
  266.  
  267. (define (trivial-action volatile? insert-source!)
  268.   (if (not volatile?)
  269.       (insert-source!)))
  270.  
  271. (define (define-trivial-one-arg-method type get set)
  272.   (define-cse-method type
  273.     (lambda (statement)
  274.       (expression-replace! get set statement trivial-action))))
  275.  
  276. (define (define-trivial-two-arg-method type get-1 set-1 get-2 set-2)
  277.   (define-cse-method type
  278.     (lambda (statement)
  279.       (expression-replace! get-1 set-1 statement trivial-action)
  280.       (expression-replace! get-2 set-2 statement trivial-action))))
  281.  
  282. (define-trivial-two-arg-method 'EQ-TEST
  283.   rtl:eq-test-expression-1 rtl:set-eq-test-expression-1!
  284.   rtl:eq-test-expression-2 rtl:set-eq-test-expression-2!)
  285.  
  286. (define-trivial-one-arg-method 'PRED-1-ARG
  287.   rtl:pred-1-arg-operand rtl:set-pred-1-arg-operand!)
  288.  
  289. (define-trivial-two-arg-method 'PRED-2-ARGS
  290.   rtl:pred-2-args-operand-1 rtl:set-pred-2-args-operand-1!
  291.   rtl:pred-2-args-operand-2 rtl:set-pred-2-args-operand-2!)
  292.  
  293. (define-trivial-one-arg-method 'FIXNUM-PRED-1-ARG
  294.   rtl:fixnum-pred-1-arg-operand rtl:set-fixnum-pred-1-arg-operand!)
  295.  
  296. (define-trivial-two-arg-method 'FIXNUM-PRED-2-ARGS
  297.   rtl:fixnum-pred-2-args-operand-1 rtl:set-fixnum-pred-2-args-operand-1!
  298.   rtl:fixnum-pred-2-args-operand-2 rtl:set-fixnum-pred-2-args-operand-2!)
  299.  
  300. (define-trivial-one-arg-method 'FLONUM-PRED-1-ARG
  301.   rtl:flonum-pred-1-arg-operand rtl:set-flonum-pred-1-arg-operand!)
  302.  
  303. (define-trivial-two-arg-method 'FLONUM-PRED-2-ARGS
  304.   rtl:flonum-pred-2-args-operand-1 rtl:set-flonum-pred-2-args-operand-1!
  305.   rtl:flonum-pred-2-args-operand-2 rtl:set-flonum-pred-2-args-operand-2!)
  306.  
  307. (define-trivial-one-arg-method 'TYPE-TEST
  308.   rtl:type-test-expression rtl:set-type-test-expression!)
  309.  
  310. (define (method/noop statement)
  311.   statement
  312.   unspecific)
  313.  
  314. (define-cse-method 'OVERFLOW-TEST method/noop)
  315. (define-cse-method 'POP-RETURN method/noop)
  316. (define-cse-method 'CONTINUATION-ENTRY method/noop)
  317. (define-cse-method 'CONTINUATION-HEADER method/noop)
  318. (define-cse-method 'IC-PROCEDURE-HEADER method/noop)
  319. (define-cse-method 'OPEN-PROCEDURE-HEADER method/noop)
  320. (define-cse-method 'PROCEDURE-HEADER method/noop)
  321. (define-cse-method 'CLOSURE-HEADER method/noop)
  322. (define-cse-method 'INVOCATION:JUMP method/noop)
  323. (define-cse-method 'INVOCATION:LEXPR method/noop)
  324.  
  325. (define (method/unknown-invocation statement)
  326.   (for-each-pseudo-register
  327.    (lambda (register)
  328.      (let ((expression (register-expression register)))
  329.        (if expression
  330.        (register-expression-invalidate! expression)))))
  331.   (stack-pointer-adjust!
  332.    (stack->memory-offset (rtl:invocation-pushed statement)))
  333.   (expression-invalidate! (interpreter-value-register))
  334.   (expression-invalidate! (interpreter-free-pointer)))
  335.  
  336. (define-cse-method 'INVOCATION:APPLY method/unknown-invocation)
  337. (define-cse-method 'INVOCATION:COMPUTED-JUMP method/unknown-invocation)
  338. (define-cse-method 'INVOCATION:COMPUTED-LEXPR method/unknown-invocation)
  339. (define-cse-method 'INVOCATION:UUO-LINK method/unknown-invocation)
  340. (define-cse-method 'INVOCATION:GLOBAL-LINK method/unknown-invocation)
  341. (define-cse-method 'INVOCATION:PRIMITIVE method/unknown-invocation)
  342. (define-cse-method 'INVOCATION:SPECIAL-PRIMITIVE method/unknown-invocation)
  343.  
  344. (define-cse-method 'INVOCATION:CACHE-REFERENCE
  345.   (lambda (statement)
  346.     (expression-replace! rtl:invocation:cache-reference-name
  347.              rtl:set-invocation:cache-reference-name!
  348.              statement
  349.              trivial-action)
  350.     (method/unknown-invocation statement)))
  351.  
  352. (define-cse-method 'INVOCATION:LOOKUP
  353.   (lambda (statement)
  354.     (expression-replace! rtl:invocation:lookup-environment
  355.              rtl:set-invocation:lookup-environment!
  356.              statement
  357.              trivial-action)
  358.     (method/unknown-invocation statement)))
  359.  
  360. (define-cse-method 'INVOCATION-PREFIX:MOVE-FRAME-UP
  361.   (lambda (statement)
  362.     (expression-replace! rtl:invocation-prefix:move-frame-up-locative
  363.              rtl:set-invocation-prefix:move-frame-up-locative!
  364.              statement
  365.              trivial-action)
  366.     (stack-invalidate!)
  367.     (stack-pointer-invalidate!)))
  368.  
  369. (define-cse-method 'INVOCATION-PREFIX:DYNAMIC-LINK
  370.   (lambda (statement)
  371.     (expression-replace! rtl:invocation-prefix:dynamic-link-locative
  372.              rtl:set-invocation-prefix:dynamic-link-locative!
  373.              statement
  374.              trivial-action)
  375.     (expression-replace! rtl:invocation-prefix:dynamic-link-register
  376.              rtl:set-invocation-prefix:dynamic-link-register!
  377.              statement
  378.              trivial-action)
  379.     (stack-invalidate!)
  380.     (stack-pointer-invalidate!)))
  381.  
  382. (define (define-lookup-method type get-environment set-environment! register)
  383.   (define-cse-method type
  384.     (lambda (statement)
  385.       (expression-replace! get-environment set-environment! statement
  386.     (lambda (volatile? insert-source!)
  387.       (expression-invalidate! (register))
  388.       (non-object-invalidate!)
  389.       (if (not volatile?) (insert-source!)))))))
  390.  
  391. (define-lookup-method 'INTERPRETER-CALL:ACCESS
  392.   rtl:interpreter-call:access-environment
  393.   rtl:set-interpreter-call:access-environment!
  394.   interpreter-register:access)
  395.  
  396. (define-lookup-method 'INTERPRETER-CALL:CACHE-REFERENCE
  397.   rtl:interpreter-call:cache-reference-name
  398.   rtl:set-interpreter-call:cache-reference-name!
  399.   interpreter-register:cache-reference)
  400.  
  401. (define-lookup-method 'INTERPRETER-CALL:CACHE-UNASSIGNED?
  402.   rtl:interpreter-call:cache-unassigned?-name
  403.   rtl:set-interpreter-call:cache-unassigned?-name!
  404.   interpreter-register:cache-unassigned?)
  405.  
  406. (define-lookup-method 'INTERPRETER-CALL:LOOKUP
  407.   rtl:interpreter-call:lookup-environment
  408.   rtl:set-interpreter-call:lookup-environment!
  409.   interpreter-register:lookup)
  410.  
  411. (define-lookup-method 'INTERPRETER-CALL:UNASSIGNED?
  412.   rtl:interpreter-call:unassigned?-environment
  413.   rtl:set-interpreter-call:unassigned?-environment!
  414.   interpreter-register:unassigned?)
  415.  
  416. (define-lookup-method 'INTERPRETER-CALL:UNBOUND?
  417.   rtl:interpreter-call:unbound?-environment
  418.   rtl:set-interpreter-call:unbound?-environment!
  419.   interpreter-register:unbound?)
  420.  
  421. (define (define-assignment-method type
  422.       get-environment set-environment!
  423.       get-value set-value!)
  424.   (define-cse-method type
  425.     (lambda (statement)
  426.       (expression-replace! get-value set-value! statement trivial-action)
  427.       (expression-replace! get-environment set-environment! statement
  428.     (lambda (volatile? insert-source!)
  429.       (varying-address-invalidate!)
  430.       (non-object-invalidate!)
  431.       (if (not volatile?) (insert-source!)))))))
  432.  
  433. (define-assignment-method 'INTERPRETER-CALL:CACHE-ASSIGNMENT
  434.   rtl:interpreter-call:cache-assignment-name
  435.   rtl:set-interpreter-call:cache-assignment-name!
  436.   rtl:interpreter-call:cache-assignment-value
  437.   rtl:set-interpreter-call:cache-assignment-value!)
  438.  
  439. (define-assignment-method 'INTERPRETER-CALL:DEFINE
  440.   rtl:interpreter-call:define-environment
  441.   rtl:set-interpreter-call:define-environment!
  442.   rtl:interpreter-call:define-value
  443.   rtl:set-interpreter-call:define-value!)
  444.  
  445. (define-assignment-method 'INTERPRETER-CALL:SET!
  446.   rtl:interpreter-call:set!-environment
  447.   rtl:set-interpreter-call:set!-environment!
  448.   rtl:interpreter-call:set!-value
  449.   rtl:set-interpreter-call:set!-value!)