home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / front_end / simplify.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  7.7 KB  |  200 lines
  1. (herald (front_end simplify)
  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. ;;;  Optimization of CPS code tree
  28.  
  29. ;;; Post-CPS code has these properties:
  30. ;;;   For every LAMBDA node L:
  31. ;;;     - L's body is a call.
  32. ;;;     - L's parent is a call or an object, or else L is the top of the tree.
  33. ;;;   For every call node N:
  34. ;;;     - N's procedure and arguments are all non-calls.
  35. ;;;     - N's parent is a LAMBDA.
  36.  
  37. ;;; (SIMPLIFY node-pair)
  38. ;;;============================================================================
  39. ;;;   Post-CPS optimizer.  All simplifications are done by changing the
  40. ;;; structure of the node tree.  NODE-PAIR is a pair whose CAR contains a
  41. ;;; leaf-node or a lambda-node.
  42. ;;;
  43. ;;; There are three requirements for the simplification procedures:
  44. ;;;    1) They must return T if the tree has been changed and NIL otherwise.
  45. ;;;    2) Only the node being simplified and its descendents may be changed.
  46. ;;;    3) If a node is changed the NODE-SIMPLIFIED? flag of that node and all
  47. ;;;       its ancestors must be set to false.
  48.  
  49. ;;; Keep simplifying a node until it stops changing.
  50.  
  51. (define (simplify node-pair)
  52.   (let ((node (car node-pair)))
  53.     (cond ((not (node-simplified? node))
  54.            (iterate loop ((node node))
  55.              (if (cond ((lambda-node? node) (simplify-lambda node))
  56.                        ((leaf-node?   node) (simplify-leaf   node))
  57.                        ((object-node? node) (simplify-object node))
  58.                        (else nil))
  59.                  (loop (car node-pair))
  60.                  (set (node-simplified? node) t)))))))
  61.  
  62.  
  63. ;;; (SIMPLIFY-LEAF node)
  64. ;;;==========================================================================
  65. ;;;   Leaf nodes are simplified only if they are variables with declaration
  66. ;;; information.
  67.  
  68. (define (simplify-leaf node)
  69.   (cond ((and (reference-node? node)
  70.               (not (nonvalue-reference? node)))
  71.          (integrate-definition node))
  72.         (else
  73.          nil)))
  74.  
  75. ;;; (INTEGRATE-DEFINITION node)
  76. ;;;============================================================================
  77. ;;;    NODE is a reference to a variable with declared information.  The value
  78. ;;; is substituted in-line if possible, otherwise nothing is done.
  79. ;;;  
  80. ;;; This needs to deal with call exit nodes....
  81.  
  82. (define (integrate-definition node)
  83.   (let* ((var (reference-variable node))
  84.          (def (get-variable-definition var)))
  85.     (cond ((not (and def
  86.                      (eq? 'constant (definition-variant def))
  87.                      (definition-value def)))
  88.            nil)
  89.           ((not (node-type-check? node (get-definition-type def node)))
  90.            (fix-early-bound-variable-error node (get-definition-type def node)))
  91.           ((get-integrable-node node def)
  92.            => (lambda (new)
  93.                 (replace node new)
  94.                 (if (and (primop-node? new)
  95.                          (eq? (node-role new) call-proc))
  96.                     (primop.presimplify (primop-value new) (node-parent new)))
  97.                 (mark-variable-used var)
  98.                 t))
  99.           (else nil))))
  100.  
  101. (define (node-type-check? node type)
  102.   (cond ((eq? (node-role node) call-proc)
  103.          (and (callable-type? type)
  104.               (arg-check-of-type type (node-parent node))))
  105.         (else t)))
  106.  
  107. ;;; Get the value of the variable referenced by NODE and check to see if
  108. ;;; it can be substituted in-line.  Primops are asked if they want to be
  109. ;;; integrated.  Objects are taken care of by their own procedure.  Literals
  110. ;;; are always integrated, callable values are integrated in call position
  111. ;;; only.
  112.  
  113. (define (get-integrable-node node def)
  114.   (cond ((definition->primop def)
  115.          => (lambda (primop)
  116.               (if (primop.integrate? primop node)
  117.                   (create-primop-node primop)
  118.                   nil)))
  119.         ((definition->object def)
  120.          => (lambda (obj)
  121.               (get-integrable-object obj node def)))
  122.         ((neq? (node-role node) call-proc)
  123.          (if (eq? (definition-type def) 'literal)
  124.              (definition->node def)
  125.              nil))
  126.         (else
  127.          (definition->node def))))
  128.  
  129. ;;; The procedure of the object is integrated if it is referenced in call
  130. ;;; position.  Operation dispatch is not currently dealt with.
  131.  
  132. (define (get-integrable-object obj node def)
  133.   (cond ((eq? (node-role node) call-proc)
  134.          (if (pair? obj)
  135.              (vector->node (caddr obj) (definition-env def))
  136.              nil))
  137.         (else
  138.          nil)))  ;;; Eventually do operation dispatch here.
  139.  
  140. ;;; (SIMPLIFY-LAMBDA node)
  141. ;;;============================================================================
  142. ;;;     Simplify a lambda node.
  143. ;;; (lambda () (x)) => x if the node is an exit or an argument to a lambda
  144. ;;; node.
  145.  
  146. (define (simplify-lambda node)
  147.   (simplify-call node)
  148.   (cond ((and (or (call-exit? node)
  149.                   (let-node? (node-parent node)))
  150.               (not (lambda-rest-var node))
  151.               (null? (lambda-variables node))
  152.               (null? (call-args (lambda-body node)))
  153.               (reference-node? (call-proc (lambda-body node)))
  154.               (variable-binder
  155.                 (reference-variable (call-proc (lambda-body node)))))
  156.          (replace node (detach (call-proc (lambda-body node))))
  157.          t)
  158.         (else
  159.          nil)))
  160.  
  161. (define (let-node? node)
  162.   (and (call-node? node)
  163.        (lambda-node? (call-proc node))))
  164.  
  165. ;;; Simplifying objects
  166. ;;;   The child nodes are all simplified.  If the procedure is a literal-node
  167. ;;;;or a reference to a variable bound to a literal it is replace by a
  168. ;;; lambda-node that calls PRIMOP/UNDEFINED-EFFECT.
  169. ;;;
  170. ;;; If the node is in call position should it be replaced with its procedure?
  171.  
  172. (define (simplify-object node)
  173.   (simplify (object-proc-pair node))
  174.   (walkcdr simplify (object-operations node))
  175.   (walkcdr simplify (object-methods node))
  176.   (let ((proc (known-value (object-proc node))))
  177.     (cond ((and proc 
  178.                 (or (and (node? proc) (literal-node? proc))
  179.                     (and (pair? proc) (eq? (car proc) 'literal))))
  180.            (replace (object-proc node)
  181.                     (let-nodes ((l1 (() c)
  182.                                     (($ primop/undefined-effect)
  183.                                      1
  184.                                      (* c)
  185.                                      '"calling an object that has no procedure")))
  186.                       l1))
  187.            t)
  188.           (else nil))))
  189.   
  190.  
  191.  
  192.  
  193.  
  194.  
  195.  
  196.  
  197.  
  198.  
  199.  
  200.