home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / front_end / node.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  10.9 KB  |  284 lines
  1. (herald (front_end node)
  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. ;;; Creating nodes and CPS converting calls and blocks.
  28. ;;;============================================================================
  29.  
  30. ;;; Two useful ways of calling ->NODE:
  31.  
  32. ;;; Convert EXP into a value node or else.
  33.  
  34. (define (->value-node exp syntax shape)
  35.   (receive (exp-node c-parent c-role)
  36.            (->node exp syntax shape)
  37.     (ignore c-parent c-role)
  38.     (if (call-node? exp-node)
  39.         (bug '"alpha-value got a call-node ~S for ~S" exp-node exp))
  40.     exp-node))
  41.  
  42. ;;; Convert EXP into a call node.  If EXP converts to a value node then return
  43. ;;; a call that calls it's continuation with the converted EXP as the argument.
  44.  
  45. (define (->call-node exp syntax shape)
  46.   (receive (node c-parent c-role)
  47.            (->node exp syntax shape)
  48.     (cond ((call-node? node)
  49.            (return node c-parent c-role))
  50.           (else
  51.            (let ((call (create-call-node '2 '0)))
  52.              (relate (call-arg '1) call node)
  53.              (return call call call-proc))))))
  54.  
  55. ;;; A useful node building procedure:
  56.  
  57. ;;; Make a thunk that returns that value of NODE when it is called.  C-PARENT
  58. ;;; and C-ROLE locate the continuation of NODE (if it has one).
  59.  
  60. (define (make-thunk node c-parent c-role)
  61.   (let* ((var (create-variable 'k))
  62.          (l-node (create-lambda-node 'c (flist1 var '()))))
  63.     (cond ((call-node? node)
  64.            (relate lambda-body l-node node)            
  65.            (relate c-role c-parent (create-reference-node var)))
  66.           (else
  67.            (let ((call-node (create-call-node '2 '0)))
  68.              (relate call-proc call-node (create-reference-node var))
  69.              (relate (call-arg '1) call-node node)
  70.              (relate lambda-body l-node call-node))))            
  71.     l-node))
  72.  
  73. ;;;                    CPS CONVERSION OF CALLS
  74. ;;;=============================================================================
  75.  
  76. ;;; Turn a call into a node.  Just a front for CPS-ARGS.
  77.  
  78. (define (make-call exp syntax shape)
  79.   (let* ((call (create-call-node (fx+ '1 (length exp)) '1))
  80.          (top (cps-args call `(,(car exp) ,empty . ,(cdr exp)) syntax shape)))
  81.     (return top call (call-arg '1))))
  82.  
  83. ;;; Another front for CPS-ARGS.  This is called by various compilators.
  84.  
  85. (define (make-call-with-exits exits args syntax shape)
  86.   (cps-args (create-call-node (length args) exits) args syntax shape))
  87.  
  88. ;;; Structure to hold information about arguments to calls.
  89.  
  90. (define-structure-type arg
  91.   index          ; The index of this argument in the call.
  92.   rank           ; The estimated cost of executing this node at run time.
  93.   node           ; What ->NODE returned for this argument.
  94.   c-parent       ;   "
  95.   c-role         ;   "
  96.   )
  97.  
  98. (define (create-arg node index c-parent c-role)
  99.   (let ((arg (obtain-from-pool *argument-pool*)))
  100.     (set (arg-index    arg) index)
  101.     (set (arg-rank     arg) (node-rank node))
  102.     (set (arg-node     arg) node)
  103.     (set (arg-c-parent arg) c-parent)
  104.     (set (arg-c-role   arg) c-role)
  105.     arg))
  106.  
  107. ;;; Storage management for argument structures.
  108.  
  109. (define *argument-pool*
  110.   (make-pool '*argument-pool* make-arg '20 arg?))
  111.  
  112. (define (return-arg-list args)
  113.   (iterate loop ((args args))
  114.     (cond ((null? args) nil)
  115.           (else
  116.            (let ((n (cdr args)))
  117.              (return-to-pool *argument-pool* (car args))
  118.              (return-to-freelist args)
  119.              (loop n))))))
  120.  
  121. ;;; The actual work of CPS conversion.  Takes a list of ARG structures and 
  122. ;;; builds them into a call, returning the top node of the resulting tree.
  123. ;;; If an argument is a call a continuation is made for it.
  124. ;;;
  125. ;;; ((p a1 a2) EMPTY (r (s b1 b2 b3) t))
  126. ;;; =>
  127. ;;; (EMPTY    (s C_1 b1 b2 b3))              ; Call to s
  128. ;;;   (C_1 () (V_2)  (r C_3 V_2 t))          ; Call to r
  129. ;;;     (C_3 () (V_4)  (p C_5 a1 a2))        ; Call to p
  130. ;;;       (C_5 () (V_6)  (V_6 EMPTY q V_4))  ; Call to result of (p a1 a2)
  131.  
  132. (define (cps-args call args syntax shape)
  133.   (let ((arguments (make-arg-nodes args syntax shape)))
  134.     (iterate loop ((top-node call) (args arguments))
  135.       (cond ((null? args)
  136.              (return-arg-list arguments)
  137.              top-node)
  138.             (else
  139.              (let ((arg (car args)))
  140.                (cond ((call-node? (arg-node arg))
  141.                       (let* ((c-var (create-variable 'v))
  142.                              (l-node (create-lambda-node
  143.                                       'c (flist2 nil c-var '()))))
  144.                         (relate lambda-body l-node top-node)
  145.                         (relate (arg-c-role arg) (arg-c-parent arg) l-node)
  146.                         (relate (call-arg (arg-index arg))
  147.                                 call
  148.                                 (create-reference-node c-var))
  149.                         (loop (arg-node arg) (cdr args))))
  150.                      (else
  151.                       (relate (call-arg (arg-index arg)) call (arg-node arg))
  152.                       (loop top-node (cdr args))))))))))
  153.  
  154. ;;; Convert the elements of EXP into nodes (if they aren't already) and put
  155. ;;; them into an ARG structure.  Returns the list of ARG structure sorted
  156. ;;; by ARG-RANK.
  157.  
  158. (define (make-arg-nodes exp syntax shape)
  159.   (let ((do-arg (lambda (arg index)
  160.                   (receive (node c-parent c-role)
  161.                            (->node arg syntax shape)
  162.                     (create-arg node index c-parent c-role)))))
  163.     (do ((i '0 (fx+ i '1))
  164.          (args exp (cdr args))
  165.          (vals '() (if (not (empty? (car args)))
  166.                        (cons-from-freelist (do-arg (car args) i) vals)
  167.                        vals)))
  168.         ((null? args)
  169.          (sort-list! vals
  170.                      (lambda (v1 v2) (fx< (arg-rank v1) (arg-rank v2))))))))
  171.  
  172. ;;; Complexity analysis used to order argument evaluation.  More complex
  173. ;;; arguments are to be evaluated first.  This is a simple heuristic.
  174.  
  175. (define (node-rank node)
  176.   (if (or (empty? node)
  177.           (not (call-node? node)))
  178.       '0
  179.       (complexity-analyze node)))
  180.  
  181. (define (complexity-analyze node)
  182.   (cond ((empty? node)
  183.          '0)
  184.         ((reference-node? node)
  185.          (if (get-variable-definition (reference-variable node)) '0 '1))
  186.         ((leaf-node? node) '0)
  187.         ((lambda-node? node)
  188.          (complexity-analyze (lambda-body node)))
  189.         ((call-node? node)
  190.          (let ((q (complexity-analyze-list (call-proc+args node))))
  191.            (set (call-complexity node) q)
  192.            q))
  193.         ((object-node? node)
  194.          (let ((q1 (complexity-analyze (object-proc node)))
  195.                (q2 (complexity-analyze-list (object-operations node)))
  196.                (q3 (complexity-analyze-list (object-methods node))))
  197.            (fx+ q1 (fx+ q2 q3))))
  198.         (else
  199.          (bug '"funny node ~S" node))))
  200.  
  201. (define (complexity-analyze-list list)
  202.   (do ((q '0 (fx+ q (complexity-analyze (car l))))
  203.        (l list (cdr l)))
  204.       ((null? l) q)))
  205.  
  206. ;;; Convert an expression list into a block.  This is guarenteed to return a
  207. ;;; call node.  
  208. ;;;
  209. ;;; TOP-CALL is the root of the tree for the block.
  210. ;;; VALUE is the node for the previous expression if it didn't alphatize to a
  211. ;;; call.
  212. ;;; C-PARENT and C-ROLE are the latest continuation for the block.
  213. ;;;
  214. ;;; Each expression in passed to ->NODE in turn.  The resulting nodes are
  215. ;;; linked using n-ary continuation lambdas whose variables are never
  216. ;;; referenced.
  217. ;;;
  218. ;;; A non-call that is not the last expression in the block is ignored.
  219. ;;;
  220. ;;; (BLOCK (p a1 a2 ...)     
  221. ;;;        (q b1 b2 ...)
  222. ;;;        (r c1 c2 ...))
  223. ;;; =>
  224. ;;; (#empty#  (p B_1 a1 a2 ...))
  225. ;;;   (B_1 IGNORE_2 ()  (q B_3 b1 b2 ...))
  226. ;;;     (B_3 IGNORE_4 ()  (r #cont# c1 c2 ...))
  227. ;;;
  228. ;;; (BLOCK (p a1 a2 ...)     
  229. ;;;        i              ;;; This will disappear since the value is not used.
  230. ;;;        (q b1 b2 ...)
  231. ;;;        j)
  232. ;;; =>
  233. ;;; (#empty# (p B_1 a1 a2 ...))
  234. ;;;   (B_1 IGNORE_2 ()  (q B_3 b1 b2 ...))  
  235. ;;;     (B_3 IGNORE_4 ()  (#cont# j))
  236.  
  237. (define (make-block exp-list syntax shape)
  238.   (iterate loop ((exps exp-list)
  239.                  (value nil)
  240.                  (top-call nil)
  241.                  (c-parent nil)
  242.                  (c-role nil))
  243.     (cond ((and (null? exps) top-call (not value))
  244.            (return top-call c-parent c-role))
  245.           ((null? exps)
  246.            (finish-block value top-call c-parent c-role))
  247.           (else
  248.            (if value (erase-all value))
  249.            (receive (node n-parent n-role)
  250.                     (->node (car exps) syntax shape)
  251.              (cond ((not (call-node? node))
  252.                     (loop (cdr exps) node top-call c-parent c-role))
  253.                    ((not top-call)
  254.                     (loop (cdr exps) nil node n-parent n-role))
  255.                    (else
  256.                     (let ((l-node (create-lambda-node
  257.                                    'b
  258.                                    (flist1 (create-variable 'ignore) '()))))
  259.                       (relate lambda-body l-node node)
  260.                       (relate c-role c-parent l-node)
  261.                       (loop (cdr exps) nil top-call n-parent n-role)))))))))
  262.            
  263. ;;; Create a call node to return the last expression in the block.
  264.  
  265. (define (finish-block value top-call c-parent c-role)
  266.   (let ((call (create-call-node '2 '0))
  267.         (value (if value value (create-primop-node primop/undefined))))
  268.     (relate (call-arg '1) call value)
  269.     (cond ((not top-call)
  270.            (return call call call-proc))
  271.           (else
  272.            (let ((l-node (create-lambda-node
  273.                           'b
  274.                           (flist1 (create-variable 'ignore) '()))))
  275.              (relate lambda-body l-node call)
  276.              (relate c-role c-parent l-node)
  277.              (return top-call call call-proc))))))
  278.                      
  279.  
  280.  
  281.  
  282.                             
  283.  
  284.