home *** CD-ROM | disk | FTP | other *** search
/ Frozen Fish 1: Amiga / FrozenFish-Apr94.iso / bbs / alib / d5xx / d556 / scheme2c.lha / Scheme2C / Scheme-src.lzh / scsc / transform.sc < prev   
Text File  |  1991-10-11  |  16KB  |  411 lines
  1. ;;; Following the expansion of the program, program optimization via
  2. ;;; transformation is done by this module.  Boolean expressions are "short-
  3. ;;; circuited, and some applications of lambda expressions are rearranged.  For
  4. ;;; more information on these transformations, consult section 3.4 of "ORBIT:
  5. ;;; An Optimizing Compiler for Scheme", 1986 ACM Compiler Conference.
  6. ;;;
  7.  
  8. ;*              Copyright 1989 Digital Equipment Corporation
  9. ;*                         All Rights Reserved
  10. ;*
  11. ;* Permission to use, copy, and modify this software and its documentation is
  12. ;* hereby granted only under the following terms and conditions.  Both the
  13. ;* above copyright notice and this permission notice must appear in all copies
  14. ;* of the software, derivative works or modified versions, and any portions
  15. ;* thereof, and both notices must appear in supporting documentation.
  16. ;*
  17. ;* Users of this software agree to the terms and conditions set forth herein,
  18. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  19. ;* right and license under any changes, enhancements or extensions made to the
  20. ;* core functions of the software, including but not limited to those affording
  21. ;* compatibility with other hardware or software environments, but excluding
  22. ;* applications which incorporate this software.  Users further agree to use
  23. ;* their best efforts to return to Digital any such changes, enhancements or
  24. ;* extensions that they make and inform Digital of noteworthy uses of this
  25. ;* software.  Correspondence should be provided to Digital at:
  26. ;* 
  27. ;*                       Director of Licensing
  28. ;*                       Western Research Laboratory
  29. ;*                       Digital Equipment Corporation
  30. ;*                       100 Hamilton Avenue
  31. ;*                       Palo Alto, California  94301  
  32. ;* 
  33. ;* This software may be distributed (but not offered for sale or transferred
  34. ;* for compensation) to third parties, provided such third parties agree to
  35. ;* abide by the terms and conditions of this notice.  
  36. ;* 
  37. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  38. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  39. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  40. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  41. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  42. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  43. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  44. ;* SOFTWARE.
  45.  
  46. (module transform)
  47.  
  48. ;;; External and in-line declarations.
  49.  
  50. (include "plist.sch")
  51. (include "expform.sch")
  52. (include "lambdaexp.sch")
  53. (include "miscexp.sch")
  54.  
  55. ;;; Each form is transformed by calling the TRANSFORM function.  The value
  56. ;;; returned is the new form.
  57.  
  58. (define  TRANSFORM-STACK '())
  59.  
  60. (define (TRANSFORM exp)
  61.     (let ((was transform-stack))
  62.      (set! transform-stack (cons exp transform-stack))
  63.      (let ((result (transformx exp)))
  64.           (set! transform-stack was)
  65.           result)))
  66.  
  67. (define (TRANSFORMX exp)
  68.     (cond (($call? exp)
  69.        (set-$call-func! exp (transform ($call-func exp)))
  70.        (set-$call-argl! exp (map transform ($call-argl exp)))
  71.        (if ($lambda? ($call-func exp)) (transform-call-lambda exp) exp))
  72.       (($lambda? exp)
  73.        (let ((old-current-lambda-id current-lambda-id))
  74.         (set! current-lambda-id ($lambda-id exp))
  75.         (set-$lambda-body! exp (map transform ($lambda-body exp)))
  76.         (set! current-lambda-id old-current-lambda-id)
  77.         exp))
  78.       (($if? exp)
  79.        (or (transform-if1 exp)
  80.            (begin (set-$if-test! exp (transform ($if-test exp)))
  81.               (set-$if-true! exp (transform ($if-true exp)))
  82.               (set-$if-false! exp (transform ($if-false exp)))
  83.               (transform-if2 exp))))
  84.       (($define? exp)
  85.        (set-$define-exp! exp (transform ($define-exp exp)))
  86.        exp)
  87.       (($set? exp)
  88.        (set-$set-exp! exp (transform ($set-exp exp)))
  89.        exp)
  90.       (else exp)))
  91.  
  92. ;;; When a $IF is detected, the following function checks for possible
  93. ;;; transformations on the whole expression.  If they can be made, then the
  94. ;;; resulting expression will be transformed and then returned.  If no such
  95. ;;; transformations can be done, then #F will be returned.
  96.  
  97. (define (TRANSFORM-IF1 exp)
  98.     (let ((test ($if-test exp))
  99.       (ift  ($if-true exp))
  100.       (iff  ($if-false exp)))
  101.      (set! transform-stack (cons (list 'if1 exp) transform-stack)) ;;; ***
  102.      (cond ((and ($call? test) ($lambda? ($call-func test)))
  103.         ; (if (let ((...))...a) b c) => (let ((...))...(if a b c))
  104.         (log-before exp)
  105.         (let ((last (last-pair ($lambda-body ($call-func test)))))
  106.              (set-car! last `($if ,(car last) ,ift ,iff))
  107.              (transform (log-after test))))
  108.            ((and ($if? test) (eq? ($if-true test) true-alpha)
  109.              (eq? ($if-false test) false-alpha))
  110.         ; (if (if a #t #f) b c) => (if a b c)
  111.         (log-before exp)
  112.         (set-$if-test! exp ($if-test test))
  113.         (transform (log-after exp)))
  114.            ((and ($if? test) (eq? ($if-true test) false-alpha)
  115.              (eq? ($if-false test) true-alpha))
  116.         ; (if (if a #f #t) b c) => (if a c b)
  117.         (log-before exp)
  118.         (set-$if-test! exp ($if-test test))
  119.         (set-$if-true! exp iff)
  120.         (set-$if-false! exp ift)
  121.         (transform (log-after exp)))
  122.            (($if? test)
  123.         ; (if (if a b c) d e) => (if a (if b d e) (if c d e))
  124.         ;                     => ((lambda (x y) (if a
  125.         ;                        (if b (x) (y))
  126.         ;                        (if c (x) (y))))
  127.         ;              (lambda () d) (lambda () e))
  128.         (log-before exp)
  129.         (let* ((lxy   (lambda-exp '(lambda (x y)) '()))
  130.                (lxyid ($lambda-id lxy))
  131.                (x     (car (lambda-reqvars lxyid)))
  132.                (y     (cadr (lambda-reqvars lxyid)))
  133.                (ld    (lambda-exp '(lambda ()) '()))
  134.                (le    (lambda-exp '(lambda ()) '())))
  135.               (set-$lambda-body! ld (list ift))
  136.               (set-$lambda-body! le (list iff))
  137.                       (set-$lambda-body! lxy
  138.                           `(($if ,($if-test test)
  139.                                 ($if ,($if-true test)
  140.                                      ($call () ,x)
  141.                      ($call () ,y))
  142.                                 ($if ,($if-false test)
  143.                                      ($call () ,x)
  144.                                      ($call () ,y)))))
  145.               (name-a-lambda x ld)
  146.               (name-a-lambda y le)
  147.               (transform (log-after `($call () ,lxy ,ld ,le)))))
  148.            ((and (symbol? test) (eq? (id-type test) 'boolean)
  149.              (eq? ift test))
  150.         ; (if a a b) => (if a #t y) when a is a boolean result
  151.         (log-before exp)
  152.         (set-$if-true! exp true-alpha)
  153.         (transform (log-after exp)))
  154.            ((and (symbol? test) (eq? (id-type test) 'boolean)
  155.              (eq? iff test))
  156.         ; (if a b a) => (if a b #f) when a is a boolean result
  157.         (log-before exp)
  158.         (set-$if-false! exp false-alpha)
  159.         (transform (log-after exp)))
  160.            ((and (eq? ($lap-type ($call-func test)) 'boolean)
  161.              (or (and (eq? ift true-alpha) (eq? iff false-alpha))
  162.              (and (eq? ift false-alpha) (eq? iff true-alpha))))
  163.         ; (if (lap-boolean) #t #f) => (lap-boolean)
  164.         ; (if (lap-boolean) #f #t) => (not (lap-boolean))
  165.         (log-before exp)
  166.         (if (eq? iff true-alpha)
  167.             (let ((lap ($call-func test)))
  168.                  (set-$lap-body! lap
  169.                  `((boolean (not ,(cadar ($lap-body lap))))))))
  170.         (transform (log-after test)))
  171.            (else #f))))
  172.  
  173. ;;; Simplifications on a transformed if form are done by the following
  174. ;;; function.  The result will be the final transformed expression.
  175.  
  176. (define (TRANSFORM-IF2 exp)
  177.     (let ((test ($if-test exp))
  178.       (ift  ($if-true exp))
  179.       (iff  ($if-false exp)))
  180.      (set! transform-stack (cons (list 'if2 exp) transform-stack)) ;;; ***
  181.      (cond ((not ($if? exp)) exp)
  182.            ((and (symbol? test) (eq? (id-use test) 'constant))
  183.         ; test is a constant, so evaluate at compile time.
  184.         (log-before exp)
  185.         (transform-if2 (log-after (if (id-value test) ift iff))))
  186.            ((or (eq? test true-alpha) (eq? test false-alpha))
  187.         ; test is "#t" or "#f" whose values are known.
  188.         (log-before exp)
  189.         (transform-if2 (log-after (if (eq? test true-alpha) ift iff))))
  190.            ((and (symbol? test) ($if? ift) (eq? ($if-test ift) test))
  191.         ; (if a (if a b c) d) => (if a b d)
  192.         (log-before exp)
  193.         (set-$if-true! exp ($if-true ift))
  194.         (transform-if2 (log-after exp)))
  195.            ((and (symbol? test) ($if? iff) (eq? ($if-test iff) test))
  196.         ; (if a b (if a c d)) => (if a b d)
  197.         (log-before exp)
  198.         (set-$if-false! exp ($if-false iff))
  199.         (transform-if2 (log-after exp)))
  200.            (else exp))))
  201.  
  202. ;;; When a transformation is going to be made, the following routine is called
  203. ;;; to log the result.
  204.  
  205. (define (LOG-BEFORE exp)
  206.     (if (log? 'transform)
  207.     (begin (pretty-print-$tree exp sc-icode)
  208.            (format sc-icode " => ~%"))))
  209.  
  210. ;;; Once a transformation has been made, the result is logged by the following
  211. ;;; function.
  212.  
  213. (define (LOG-AFTER exp)
  214.     (if (log? 'transform)
  215.     (begin (pretty-print-$tree exp sc-icode)
  216.            (format sc-icode "~%~%")))
  217.     exp)
  218.  
  219. ;;; When a LAMBDA expression is apply'ed, some of the lambda bindings may be
  220. ;;; eliminated by using the value being bound instead.
  221.  
  222. (define (TRANSFORM-CALL-LAMBDA exp)
  223.     (let* ((lid     ($lambda-id ($call-func exp)))
  224.        (alist   (transform-lambda-bind (lambda-reqvars lid)
  225.             ($call-argl exp)))
  226.        (vars    (map (lambda (var-value) (car var-value)) alist))
  227.        (values  (map (lambda (var-value) (cadr var-value)) alist))
  228.        (body    ($lambda-body ($call-func exp)))
  229.        (redo    #f)
  230.        (newvars '())
  231.        (newargl '())
  232.        (sublis  '()))
  233.       (set! transform-stack (cons (list 'tcl exp) transform-stack)) ;;; ***
  234.           (for-each (lambda (var-val)
  235.                             (let ((id (car var-val)))
  236.                                  (set-id-refs! id 0)
  237.                                  (set-id-calls! id 0)))
  238.               alist)
  239.       (if vars 
  240.           (for-each (lambda (exp) (count-lambda-var-uses vars exp)) body))
  241.       (for-each
  242.           (lambda (var)
  243.               (let* ((value (car values))
  244.                  (old-new (transform-lambda-var var value body)))
  245.                (cond ((eq? old-new 'no-value)
  246.                   (set! value old-new))
  247.                  ((eq? old-new 'no-change))
  248.                  ((eq? old-new 'boolean)
  249.                   (set! redo #t))
  250.                  ((eq? (car old-new) 'both)
  251.                   (set! value (cadr old-new))
  252.                   (set! sublis (cons (cddr old-new) sublis)))
  253.                  (else
  254.                   (set! sublis (cons old-new sublis))
  255.                   (set! var '())))
  256.                (if var
  257.                    (begin (set! newvars (cons var newvars))
  258.                       (set! newargl (cons value newargl))))
  259.                (set! values (cdr values))))
  260.           vars)
  261.       (if sublis (set! body (transform-var-to-value lid body sublis)))
  262.       (cond ((and (null? newvars) (= (length body) 1))
  263.          (if (log? 'transform)
  264.              (format sc-icode "Lambda ~A collapsed~%" lid))
  265.          (set-lambda-generate! lid 'inline)
  266.          (set! exp (car body)))
  267.         (else
  268.          (set-lambda-reqvars! lid newvars)
  269.          (set-$call-argl! exp newargl)
  270.          exp))
  271.       (if (or sublis redo) (transform exp) exp)))
  272.  
  273. ;;; Build an a-list of the lambda variables and their initial bindings.
  274.            
  275. (define (TRANSFORM-LAMBDA-BIND vars values)
  276.     (cond ((null? vars)
  277.        '())
  278.       ((pair? vars)
  279.        (cons (list (car vars) (car values))
  280.          (transform-lambda-bind (cdr vars) (cdr values))))))
  281.  
  282. ;;; Count the variable uses for a list of variables in an expression.  The
  283. ;;; counts maintained are ID-REFS and ID-CALLS. 
  284.  
  285. (define (COUNT-LAMBDA-VAR-USES vars exp)
  286.     (cond ((symbol? exp)
  287.        (if (memq exp vars) (set-id-refs! exp (+ 1 (id-refs exp)))))
  288.       (($define? exp)
  289.        (count-lambda-var-uses vars ($define-exp exp)))
  290.       (($call? exp)
  291.        (let ((func ($call-func exp)))
  292.         (for-each (lambda (a) (count-lambda-var-uses vars a))
  293.             ($call-argl exp))
  294.         (cond (($lambda? func)
  295.                (count-lambda-var-uses vars ($call-func exp)))
  296.               ((memq func vars)
  297.                (set-id-calls! func (+ 1 (id-calls func)))))))
  298.       (($set? exp)
  299.        (count-lambda-var-uses vars ($set-exp exp)))
  300.       (($lambda? exp)
  301.        (for-each (lambda (e) (count-lambda-var-uses vars e))
  302.            ($lambda-body exp)))
  303.       (($if? exp)
  304.        (count-lambda-var-uses vars ($if-test exp))
  305.        (count-lambda-var-uses vars ($if-true exp))
  306.        (count-lambda-var-uses vars ($if-false exp)))))
  307.  
  308. ;;; Once the usage counts have been obtained, the following function is called
  309. ;;; to decide whether substitution is in order.  If so, then it will return
  310. ;;; either "no-value" which indicates that the value is not needed, or a list
  311. ;;; of old and new values to be substitued for in the expression, or
  312. ;;; "no-change" indicating that nothing is to be changed.
  313.  
  314. (define (TRANSFORM-LAMBDA-VAR var value exp)
  315.     (let ((refs      (id-refs var))
  316.       (calls  (id-calls var))
  317.       (body      ($lambda-body value))
  318.       (memvarlist (lambda (var symbols)
  319.               (do ((symbols symbols (cdr symbols))
  320.                    (found #f (or found (eq? (car symbols)
  321.                              var))))
  322.                   ((or (not symbols)
  323.                    (not (symbol? (car symbols))))
  324.                    (and found (null? symbols)))))))
  325.      (cond ((or (id-set! var) (id-display var))
  326.         ; If the lambda var is set or heap allocated, then it is best
  327.         ; left alone.
  328.         'no-change)
  329.            ((and ($lambda? value) (= calls 1) (zero? refs))
  330.         ; A lambda expression which is called once should be moved to
  331.         ; the point of call.
  332.         (log-transform var " replaced by lambda " ($lambda-id value))
  333.         (list var value))
  334.            ((and body (zero? refs) (= 1 (length body)) (symbol? (car body))
  335.              (not (id-display (car body))))
  336.         ; A function with no arguments which returns the value of a
  337.         ; symbol which is not heap allocated can have all calls to it
  338.         ; replaced with the actual symbol.
  339.         (log-transform `($call () ,var) " replaced by " (car body))
  340.         (list `($call () ,var) (car body)))
  341.            ((and (symbol? value)
  342.              (or (eq? value true-alpha)
  343.              (eq? value false-alpha)
  344.              (eq? (id-use value) 'constant)
  345.              (and (eq? (id-use value) 'lexical)
  346.                   (not (id-display value))
  347.                   (not (id-set! value)))))
  348.         ; A constant or a lexical variable which is not set and not
  349.         ; closed may be substituted for.
  350.         (log-transform var " replaced by " value)
  351.         (list var value))
  352.            ((and ($if? (car exp)) (= refs 1) (zero? calls)
  353.              (or (eq? ($if-test (car exp)) var)
  354.              (memvarlist var ($call-argl ($if-test (car exp))))))
  355.         ; An expression which is then used as the test in an initial IF
  356.         ; can be substituted for.  The test is either the variable, or
  357.         ; a variable to a function which is the test which only has
  358.         ; variables as arguments.
  359.         (log-transform var " replaced by " value)
  360.         (list var value))
  361.            ((and ($call? (car exp)) (= refs 1) (zero? calls)
  362.              (memvarlist var ($call-argl (car exp))))
  363.         ; An expression which is used once as an argument to an inital
  364.         ; function may be substituted for if the arguments to the
  365.         ; function are all symbols.
  366.         (log-transform var " replaced by " value)
  367.         (list var value))
  368.            ((and ($call? value) ($lap? ($call-func value))
  369.              (not (id-type var)) 
  370.              (pair? (car (last-pair ($lap-body ($call-func value)))))
  371.              (eq? (caar (last-pair ($lap-body ($call-func value))))
  372.               'boolean))
  373.         ; A variable which is bound to a logical boolean can have
  374.         ; it's type noted.
  375.         (set-id-type! var 'boolean)
  376.         'boolean)
  377.            (else 'no-change))))
  378.  
  379. ;;; Transformations done when lambda expressions are apply'ed are logged by the
  380. ;;; following function.
  381.  
  382. (define (LOG-TRANSFORM . exp)
  383.     (if (log?  'transform)
  384.         (begin (for-each (lambda (e) (format sc-icode "~A" e)) exp)
  385.            (newline sc-icode))))
  386.  
  387. ;;; Once the transformations have been figured out, the actual substitutions
  388. ;;; can be made.  Note the one special case where a lambda expression replaces
  389. ;;; its variable in a call.  This will require that TRANSFORM-CALL-LAMBDA be
  390. ;;; recursively invoked as more transformations may be possible.
  391.  
  392. (define (TRANSFORM-VAR-TO-VALUE lid exp sublis)
  393.     (let ((old-new (assoc exp sublis)))
  394.      (cond (old-new
  395.                (transform-var-to-value lid (cadr old-new) sublis))
  396.            (($call? exp)
  397.         (let* ((old ($call-func exp))
  398.                (new (transform-var-to-value lid old sublis)))
  399.               (set-$call-func! exp new)
  400.               (set-$call-argl! exp
  401.               (transform-var-to-value lid ($call-argl exp) sublis))
  402.               (if (or (eq? old new) (not ($lambda? new)))
  403.               exp
  404.               (transform-call-lambda exp))))
  405.            ((and (pair? exp) (not ($lap? exp)))
  406.         (if ($lambda? exp) (set! lid ($lambda-id exp)))
  407.         (set-car! exp (transform-var-to-value lid (car exp) sublis))
  408.         (set-cdr! exp (transform-var-to-value lid (cdr exp) sublis))
  409.         exp)
  410.            (else exp))))
  411.