home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / comp / front_end / simpfy_call.t < prev    next >
Encoding:
Text File  |  1990-04-12  |  7.5 KB  |  192 lines
  1. (herald (front_end simplify_call)
  2.   (env t (orbit_top defs)))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. ;;;                 Simplifying Call-nodes
  28. ;;;===========================================================================
  29. ;;; Simplify the node in the car of NODE-PAIR.  Trys a series of simplification
  30. ;;; procedures, going back to the beginning whenever a change is made.  The 
  31. ;;; simplifiers are only allowed to change the node and its descendents.  No
  32. ;;; changes may be made to any other part of the tree.
  33.  
  34. (define (simplify-call lambda-node)
  35.   (let ((node (lambda-body lambda-node)))
  36.     (cond ((node-simplified? node)
  37.            node)
  38.           (else
  39.            (iterate loop ((node node))
  40.              (let ((proc (call-proc node)))
  41.                (cond ((and (lambda-node? proc)
  42.                            (simplify-let proc node))
  43.                       (loop (lambda-body lambda-node)))
  44.                      ((and (reference-node? proc)
  45.                            (integrate-definition proc))
  46.                       (loop (lambda-body lambda-node)))
  47.                      ((simplify-call-ignoring-exits node proc)
  48.                       (loop (lambda-body lambda-node)))
  49.                      ((simplify-call-using-exits node)
  50.                       (loop (lambda-body lambda-node)))
  51.                      (else nil))))))))
  52.  
  53. ;;; Simplify the non-exit arguments of NODE and NODE itself.  Returns T if any
  54. ;;; change is made.
  55.  
  56. (define (simplify-call-ignoring-exits node proc)
  57.   (set (node-simplified? proc) t) ; Nothing to do here anyway
  58.   (simplify-non-exit-args node)
  59.   (set (node-simplified? node) t)
  60.   (or (simplify-call-using-proc proc node)
  61.       (not (node-simplified? node))))
  62.  
  63. ;;; Simplify the exits of NODE.  Remove it if has no side effects and its value
  64. ;;; is not used.
  65.  
  66. (define (simplify-call-using-exits node)
  67.   (simplify-exit-args node)
  68.   (or (flush-unused-call node)
  69.       (not (node-simplified? node))))
  70.  
  71. ;;; Simplify the specified children.  These use the NODE-SIMPLIFIED? flag
  72. ;;; to determine if a change has been made.
  73.  
  74. (define (simplify-non-exit-args node)
  75.   (walkcdr simplify (nthcdr (call-args node) (call-exits node))))
  76.  
  77. ;;; Simplify the exits of call-node NODE.  If the node does a test, propogate
  78. ;;; appropriate results of the test down the two arms.  This is a small (but
  79. ;;; helpful) bit of type inferencing.
  80.  
  81. (define (simplify-exit-args node)
  82.   (case (call-exits node)
  83.     ((0) (return))
  84.     ((1) (simplify (call-args node)))
  85.     ((2) (add-to-value-table node 'true)
  86.          (simplify (call-args node))
  87.          (add-to-value-table node 'false)
  88.          (simplify (cdr (call-args node)))
  89.          (add-to-value-table node nil))
  90.     (else
  91.      (do ((args (call-args node) (cdr args))
  92.           (exits (call-exits node) (fx- exits '1)))
  93.          ((fx<= exits '0))
  94.        (simplify args)))))
  95.  
  96. ;;; *VALUE-TABLE* is bound by MAKE-CODE-TREE+SHAPE
  97.  
  98. (lset *value-table* (make-table '*value-table*))
  99.  
  100. (define (add-to-value-table call value)
  101.   (destructure (((#f #f test arg1 arg2) (call-args call)))
  102.     (cond ((and (primop-ref? test primop/test)
  103.                 (primop-ref? arg1 primop/true?)
  104.                 (reference-node? arg2))
  105.            (set (table-entry *value-table* (reference-variable arg2))
  106.                 value))
  107.           (else
  108.            nil))))
  109.  
  110. ;;; Calls to literals are flushed.
  111. ;;; Primops are simplified using their own methods.
  112. ;;; Calls to objects are simplified (the handler is flushed).
  113. ;;; If the second argument is a reference to a known object operation dispatch
  114. ;;;   will be attempted.
  115.  
  116. (define (simplify-call-using-proc proc node)
  117.   (cond ((object-node? proc)
  118.          (replace proc (detach (object-proc proc)))
  119.          t)
  120.         ((or (not (leaf-node? proc))
  121.              (literal-node? proc))
  122.          nil)
  123.         ((known-primop proc)
  124.          => (lambda (primop)
  125.               (primop.simplify primop node)))
  126. ;;      ((and (bound-to-operation? (call-proc node))
  127. ;;            (cdr (call-args node))
  128. ;;            (bound-to-object? ((call-arg 2) node)))
  129. ;;       (simplify-operation-dispatch node obj-exp))
  130.         (else
  131.          nil)))
  132.  
  133. ;;; Remove a call that has no side effects and produces no useful result.
  134.  
  135. (define (flush-unused-call node)
  136.   (cond ((and (not (side-effects? (call-proc node)))
  137.               (unused-call? node))
  138.          (replace node (detach (lambda-body ((call-arg 1) node))))
  139.          t)
  140.         (else
  141.          nil)))
  142.  
  143. (define (unused-call? node)
  144.   (and (fx= 1 (call-exits node))
  145.        (leaf-node? (call-proc node))
  146.        (lambda-node? ((call-arg 1) node))
  147.        (every? (lambda (var)
  148.                  (or (not var)
  149.                      (null? (variable-refs var))))
  150.                (lambda-rest+variables ((call-arg 1) node)))))
  151.  
  152. (define (side-effects? proc)
  153.   (cond ((known-primop proc)
  154.          => primop.side-effects?)
  155.         (else
  156.          t)))
  157.  
  158. ;;; OBJ is an object-lambda.  The methods are searched to see if there is
  159. ;;; one corresponding to the procedure being called.  If so, the method is
  160. ;;; substituted in-line.
  161.  
  162. (define (simplify-operation-dispatch call obj def)
  163.   (destructure (((#f op? proc ops methods) obj))
  164.     (ignore op? proc)
  165.     (let ((op-def (variable-definition (reference-variable (call-proc call))))
  166.           (env (definition-env def)))
  167.       (iterate loop ((ops ops) (methods methods))
  168.         (cond ((null? ops)
  169.                nil)
  170.               ((let ((var (vector->variable (car ops) env)))
  171.                  (and (variable? var)
  172.                       (eq? op-def (variable-definition var))))
  173.                (replace-operation-with-method call (car methods) def))
  174.               (else
  175.                (loop (cdr ops) (cdr methods))))))))
  176.  
  177. ;;;  (<op> <cont> <object> . <args>)
  178. ;;;   => (<method> <cont> <object>  . <args>)
  179. ;;; where <method> is <object>'s method for <op>.
  180.  
  181. (define (replace-operation-with-method call method def)
  182.   (let ((new (create-call-node (fx+ 1 (length (call-args call))) 1)))
  183.     (mark-reference-used (call-proc call))
  184.     (mark-reference-used ((call-arg 2) call))
  185.     (relate call-proc new (vector->node method (definition-env def)))
  186.     (relate-call-args new `(,(detach ((call-arg 1) call))
  187.                             . ,(map detach (cdr (call-args call)))))
  188.     (replace call new)
  189.     t))
  190.  
  191.  
  192.