home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / front_end / simplifiers.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  20.6 KB  |  518 lines
  1. (herald (front_end simplifiers)
  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. ;;; Procedures to simplify calls to various primops
  28.  
  29. (define (simplify-undefined-effect node)
  30.   (cond ((fx= (call-exits node) 1)
  31.          (set (call-exits node) 0)
  32.          (erase-all (detach ((call-arg 1) node)))
  33.          (relate-new-call-args node (map detach (cdr (call-args node))))
  34.          t)
  35.         (else 
  36.          nil)))
  37.  
  38. ;;; (<location> . <args>)
  39. ;;; => (CONTENTS-LOCATION <location> . <args>)
  40. ;;; Get (CAR X) to actually return a value.
  41.  
  42. (define (simplify-location node)
  43.   (let* ((args (map detach (call-proc+args node)))
  44.          (new-call (create-call-node (fx+ 1 (length args)) 1)))
  45.     (relate call-proc new-call (create-primop-node primop/contents-location))
  46.     (let ((loc (car args)))
  47.       (set (car args) (cadr args))
  48.       (set (cadr args) loc))
  49.     (relate-call-args new-call args)
  50.     (replace node new-call)
  51.     t))
  52.  
  53. ;;;                       SETTER
  54. ;;;============================================================================
  55.  
  56. ;;; If setter is called on an object, see if it has a SETTER method, otherwise
  57. ;;; try to integrate it.  If it integrates, remove the call from the tree and
  58. ;;; simplify all the calls to the setter method (see SIMPLIFY-LOCATION-SET).
  59.  
  60. (define (simplify-setter node)
  61.   (cond ((known-object-definition ((call-arg 2) node))
  62.          => (lambda (def)
  63.               (simplify-operation-dispatch node (definition-value def) def)))
  64.         ((not (integrate-setter? (call-proc node)))
  65.          nil)
  66.         (else
  67.          (let ((p (known-primop ((call-arg 2) node))))
  68.            (mark-reference-used ((call-arg 2) node))
  69.            (mark-reference-used (call-proc node))
  70.            (walk-refs-safely (lambda (ref)
  71.                                (primop.simplify-setter p (node-parent ref)))
  72.                              (car (lambda-variables ((call-arg 1) node))))
  73.            (replace node (detach (lambda-body ((call-arg 1) node))))
  74.            t))))
  75.  
  76. ;;; SETTER should be integrated at NODE if it is called on a known primop and
  77. ;;; the result is only called.
  78.  
  79. (define (integrate-setter? node)
  80.   (and (eq? (node-role node) call-proc)
  81.        (destructure (((#f cont arg . rest)
  82.                       (call-proc+args (node-parent node))))
  83.          (let ((p (known-primop arg)))
  84.            (and (null? rest)
  85.                 p
  86.                 (primop.settable? p)
  87.                 (lambda-node? cont)   ;;; should do nargs check on lambda here
  88.                 (all-refs-are-calls? (car (lambda-variables cont))))))))
  89.  
  90. ;;; ((SETTER <location primop>) @<args> <value>)
  91. ;;;  =>
  92. ;;; (PRIMOP/SET-LOCATION <cont> <location primop> <value> . <args>)
  93.  
  94. (define (simplify-location-set location call nargs)     ; needs arg checking
  95.   (ignore nargs)
  96.   (let ((args (reverse! (map detach (cdr (call-args call)))))
  97.         (new (create-call-node (fx+ 2 (length (call-args call))) 1)))
  98.     (relate call-proc new (create-primop-node primop/set-location))
  99.     (relate-call-args new
  100.                       `(,(detach ((call-arg 1) call))
  101.                         ,(create-primop-node location)
  102.                         ,(car args)
  103.                         . ,(reverse! (cdr args))))
  104.       (replace call new)))
  105.  
  106. ;;;                   Multiple Value Returns
  107. ;;;============================================================================
  108.  
  109. ;;; RETURN (what used to be VALUES)
  110. ;;;
  111. ;;; (return cont a b c)
  112. ;;;    ==>  (cont a b c)
  113.  
  114. (define (simplify-values node)
  115.   (let ((cont (any-known-type ((call-arg 1) node))))
  116.     (cond ((or (not cont)
  117.                (and (callable-type? cont)
  118.                     (arg-check-of-return-type cont node)))
  119.            (let ((args (map detach (call-args node))))
  120.              (set (call-exits node) 0)
  121.              (replace-call-args node (cdr args))
  122.              (replace (call-proc node) (car args))
  123.              t))
  124.           ((not (callable-type? cont))
  125.            (bug '"contination to VALUES is not callable ~S" node))
  126.           (else
  127.            (fix-call-to-values node cont)))))
  128.  
  129. ;;; RECEIVE is syntax that expands into a call to RECEIVE-VALUES
  130. ;;;
  131. ;;; (RECEIVE <args> <form> . <body>)
  132. ;;; => (RECEIVE-VALUES (LAMBDA <args> . <body>) (LAMBDA () <form>))
  133. ;;;
  134. ;;; After CPS conversion RECEIVE-VALUES can often be removed completely.
  135. ;;;
  136. ;;; (RECEIVE-VALUES <cont> (LAMBDA <c . rest> . <body>) <sender>)
  137. ;;; => (<sender> (LAMBDA <rest>
  138. ;;;                ((LAMBDA (<c>) . <body>)
  139. ;;;                 <cont>)))
  140. ;;; If the receiver is an object instead of a lambda its procedure's variable
  141. ;;; is used for <c>.
  142.  
  143. ;;; This checks the node tree and replaces SENDER with its procedure if it is
  144. ;;; an object.
  145.  
  146. (define (simplify-receive-values node)
  147.   (destructure (((cont receiver sender) (call-args node)))
  148.     (let ((sender (maybe-replace-object-with-proc sender)))
  149.       (cond ((or (fxn= '3 (length (call-args node)))
  150.                  (not (check-receiver? receiver))
  151.                  (not (check-sender? sender)))
  152.              (not (node-simplified? node)))        ;SENDER may have changed
  153.             (else
  154.              (really-simplify-receive-values node cont receiver sender))))))
  155.  
  156. ;;; The receiver must be a lambda or an object and have a continuation variable.
  157.  
  158. (define (check-receiver? receiver)
  159.   (or (and (lambda-node? receiver)
  160.            (variable? (lambda-cont-var receiver)))
  161.       (and (object-node? receiver)
  162.            (and (lambda-node? (object-proc receiver))
  163.                 (variable? (lambda-cont-var (object-proc receiver)))))))
  164.  
  165. ;;; The sender must be a lambda with only a continuation variable.
  166.  
  167. (define (check-sender? sender)
  168.   (and (lambda-node? sender)
  169.        (variable? (lambda-cont-var sender))
  170.        (not (lambda-rest-var sender))
  171.        (null? (cdr (lambda-variables sender)))))
  172.  
  173. ;;; Make the change.  RECEIVER's continuation variable must be excised from
  174. ;;; its variable list so that it can be bound by a separate lambda.
  175.  
  176. (define (really-simplify-receive-values node cont receiver sender)
  177.   (let* ((r-proc (if (object-node? receiver)
  178.                      (object-proc receiver)
  179.                      receiver))
  180.          (c-var (lambda-cont-var r-proc))
  181.          (r-body (detach (lambda-body r-proc))))
  182.     (set (cdr (lambda-rest+variables r-proc))
  183.          (cdr (lambda-variables r-proc)))
  184.     (check-receive-calls (lambda-cont-var sender)
  185.                          (get-node-definition-type r-proc))
  186.     (walk (lambda (v)
  187.             (if (variable? v)
  188.                 (modify (variable-number v)
  189.                         (lambda (n) (fx- n 1)))))
  190.           (lambda-variables r-proc))
  191.     (let-nodes ((new-call ((! (detach sender)) 1 (! (detach receiver))))
  192.                 (l1 (#f (c c-var)) r-body)
  193.                 (new-r-body ((! l1) 1 (! (detach cont)))))
  194.       (relate lambda-body r-proc new-r-body)
  195.       (set (node-simplified? receiver) nil) ;receiver has a new body 
  196.       (replace node new-call)
  197.       t)))
  198.  
  199. ;;; Check the number of arguments to the receive so that appropriate error
  200. ;;; messages can be issued if necessary.
  201.  
  202. (define (check-receive-calls var type)
  203.   (walk-refs-safely (lambda (r)
  204.                       (if (and (eq? (node-role r) call-proc)
  205.                                (not (arg-check-of-type type (node-parent r))))
  206.                           (fix-call-to-receive-values (node-parent r) type)))
  207.                     var))
  208.  
  209. ;;;                Predicates and Conditionals
  210. ;;;============================================================================
  211.  
  212. ;;; (<type>? cont x) =>
  213. ;;; (primop/conditional (lambda () (cont #t))
  214. ;;;                     (lambda () (cont #f))
  215. ;;;                     primop/test
  216. ;;;                     <type>?
  217. ;;;                     x)
  218.  
  219. (define (presimplify-predicate node)
  220.   (really-presimplify-predicate node ((call-arg 2) node)))
  221.  
  222. (define (presimplify-no-argument-predicate node)
  223.   (really-presimplify-predicate node (create-literal-node '#f)))
  224.  
  225. (define (really-presimplify-predicate call arg)
  226.   (let ((pred (call-proc call))
  227.         (cont ((call-arg 1) call)))
  228.     (let ((primop (if (primop-node? pred)
  229.                       pred
  230.                       (create-primop-node (known-primop pred))))
  231.           (test (create-primop-node primop/test)))
  232.       (construct-conditional call test cont primop arg)
  233.       (if (reference-node? pred) (erase pred))
  234.       t)))
  235.  
  236. ;;; (<cond> cont arg1 arg2) =>
  237. ;;; (primop/conditional (lambda () (cont #t))
  238. ;;;                     (lambda () (cont #f))
  239. ;;;                      <cond> arg1 arg2)
  240. ;;; where <cond> is one of PRIMOP/TEST, EQ?, FX<, etc.
  241.  
  242. (define (presimplify-to-conditional node)
  243.   (destructure (((pred cont arg1 arg2) (call-proc+args node)))
  244.     (construct-conditional node pred cont arg1 arg2)))
  245.  
  246. (define (construct-conditional node pred cont arg1 arg2)
  247.   (let ((primop (if (primop-node? pred)
  248.                     pred
  249.                     (create-primop-node (known-primop pred)))))
  250.     (walk detach (call-proc+args node))
  251.     (if (reference-node? pred) (erase pred))
  252.     (let-nodes ((c1 ((^ l1) 1 cont))
  253.                  (l1 (#f v1)
  254.                      (($ primop/conditional) 2 (^ l2) (^ l3) primop arg1 arg2))
  255.                    (l2 (#f) ((* v1) 0 ''#t))
  256.                    (l3 (#f) ((* v1) 0 ''#f)))
  257.       (replace node c1))))
  258.  
  259. ;;; (PRIMOP/CONDITIONAL <exit1> <exit2> PRIMOP/TEST PRIMOP/TRUE? #F)
  260. ;;; => <exit2>
  261. ;;;
  262. ;;; (PRIMOP/CONDITIONAL <exit1> <exit2> PRIMOP/TEST PRIMOP/TRUE? not-#F)
  263. ;;; => <exit1>
  264. ;;;
  265. ;;; *VALUE-TABLE* contains values known from tests that occur above this
  266. ;;; one in the tree.
  267.  
  268. (define (simplify-test node)
  269.   (destructure (((exit-1 exit-2 #f test val) (call-args node)))
  270.     (cond ((not (primop-ref? test primop/true?))
  271.            nil)
  272.           ((and (reference-node? val)
  273.                 (table-entry *value-table* (reference-variable val)))
  274.            =>(lambda (value)
  275.                (if (eq? value 'true)
  276.                    (replace-test node exit-1)
  277.                    (replace-test node exit-2))
  278.                t))
  279.           ((not (literal-node? val))
  280.            nil)
  281.           ((eq? '#f (primop-value val))
  282.            (replace-test node exit-2)
  283.            t)
  284.           (else
  285.            (replace-test node exit-1)
  286.            t))))
  287.  
  288. (define (replace-test call-node new-node)
  289.   (let ((new-call (create-call-node 1 0)))
  290.     (detach new-node)
  291.     (relate call-proc new-call new-node)
  292.     (replace call-node new-call)))
  293.  
  294. ;;;                     Creating Primops
  295. ;;;============================================================================
  296.  
  297. ;;; Just replace the call with the primop.
  298.  
  299. (define (simplify-*primop primop call)
  300.   (ignore primop)
  301.   (replace-call-with-new-primop call (primop-value ((call-arg 2) call)))
  302.   t)
  303.  
  304. ;;; CALL is a call node whose procedure is PRIMOP.  This checks to see that
  305. ;;; there are the right number of arguments and that they are all literals.
  306. ;;; If so, the values are attached the primop and the call is replaced by the
  307. ;;; new primop.
  308.  
  309. (define (simplify-parameterized-primop primop call)
  310.   (cond ((or (fxn= (length (primop.formals primop)) ; Could be improper?
  311.                    (fx+ -1 (length (call-args call))))
  312.              (not (every? literal-node? (cdr (call-args call)))))
  313.          nil)
  314.         (else
  315.          (let ((args (map literal-value (cdr (call-args call)))))
  316.            (replace-call-with-new-primop call (construct-primop primop args))
  317.            t))))
  318.  
  319. ;;; Structure accessors cannot be plain parameterized primops as the STYPE
  320. ;;; will not be a literal node.
  321.  
  322. (define (simplify-parameterized-structure-accessor primop call)
  323.   (destructure (((cont stype offset slot) (call-args call)))
  324.     (cond ((or (fxn= 4 (length (call-args call)))
  325.                (not (reference-node? stype))
  326.                (not (literal-node? offset))
  327.                (not (literal-node? slot)))
  328.            nil)
  329.           (else
  330.            (let ((new-primop (construct-primop primop
  331.                                                `(,(literal-value offset)))))
  332.              (add-call-value-to-definition call new-primop t)
  333.              (replace (call-proc call)
  334.                       (create-reference-node
  335.                        (get-system-variable 'stype-selector)))
  336.              (walk detach (call-args call))
  337.              (erase offset)
  338.              (relate-new-call-args call (list cont stype slot))
  339.              t)))))
  340.  
  341. ;;; This does two things.  CALL is replace by the node-tree for the closed
  342. ;;; compiled form for PRIMOP.  The PRIMOP becomes the value of any locale
  343. ;;; variables which are defined to be the value of CALL.
  344.  
  345. (define (replace-call-with-new-primop call primop)
  346.   (let ((thunk-node (subexpression->code-tree (primop.make-closed primop))))
  347.     (add-call-value-to-definition call primop nil)
  348.     (replace (call-proc call) thunk-node)
  349.     (walk (lambda (n) (erase (detach n)))
  350.           (cdr (call-args call)))
  351.     (relate-new-call-args call (list (detach ((call-arg 1) call)))))
  352.   (return))
  353.  
  354. ;;; Try to find if the value of CALL is used as the value of any locale
  355. ;;; variable.  This works for (DEFINE FOO (PRIMOP ...)) and not for anything
  356. ;;; much more complicated.  If it cannot find a place to put the value a
  357. ;;; warning is issued.
  358.  
  359. (define (add-call-value-to-definition call primop parameterized?)
  360.   (let ((cont ((call-arg 1) call)))
  361.     (cond ((or (not (lambda-node? cont))
  362.                (fxn= 1 (length (lambda-variables cont))))
  363.            (dropped-primop-warning call primop parameterized?))
  364.           (else
  365.            (iterate loop ((refs (variable-refs (car (lambda-variables cont))))
  366.                           (hit? nil))
  367.              (cond ((null? refs)
  368.                     (cond ((not hit?)
  369.                            (dropped-primop-warning call primop parameterized?))
  370.                           ((primop.variant-id primop)
  371.                            (add-new-primop *shape* primop))))
  372.                    ((add-primop-to-definition (car refs) primop)
  373.                     (loop (cdr refs) t))
  374.                    (else
  375.                     (loop (cdr refs) hit?)))))))
  376.   (return))
  377.  
  378. ;;; See if REF is part of (DEFINE FOO <REF>).  If it is, the value of FOO is
  379. ;;; declared to be PRIMOP.
  380. ;;; Why is NODE created before the COND??
  381.  
  382. (define (add-primop-to-definition ref primop)
  383.   (let ((parent (node-parent ref))
  384.         (node (create-primop-node primop)))
  385.     (cond ((or (not (call-arg? (node-role ref)))
  386.                (not (variable-definition? parent)))
  387.            (erase node)
  388.            nil)
  389.           (else
  390.            (let ((defined-var (reference-variable ((call-arg 2) parent))))
  391.              (and defined-var
  392.                   (real-add-definition-value defined-var node)))))))
  393.  
  394. (define (dropped-primop-warning call primop parameterized?)
  395.   (user-message 'warning
  396.                 (if parameterized?
  397.                     "parameterized primop ~S not added to support"
  398.                     "primop ~S not added to support")
  399.                 nil
  400.                 primop))
  401.  
  402. ;;;          closed compiled definitions for primops
  403. ;;;============================================================================
  404. ;;;   Wrap a LAMBDA with the necessary ENFORCEs around primop P.  (ENFORCE
  405. ;;; used to be called PROCLAIM).  There are three procedures, one for normal
  406. ;;; primops, one for predicates, and one for conditionals.
  407.  
  408. (define (make-closed-primop p)
  409.   (let ((type (primop.type p nil)))
  410.     (cond ((not (proc-type? type))
  411.            primop/undefined-effect)
  412.           ((proc-type-n-ary? type)
  413.            (bug "cannot make a closed compiled for n-ary primop ~S" p))
  414.           (else
  415.            (receive (vars proclaims)
  416.                     (make-proclaims (cddr (vector->list (proc-type-args type))))
  417.              `(,syntax/lambda ,vars
  418.                  ((,syntax/lambda ,vars (,p . ,vars))
  419.                   . ,proclaims)))))))
  420.  
  421. (define (make-closed-predicate p)
  422.   (receive (names proclaims)
  423.            (make-proclaims (cddr (vector->list
  424.                                   (proc-type-args (primop.type p nil)))))
  425.     (let ((vars (map create-variable names)))
  426.      (let-nodes ((node (#f k (v0 (car vars)))
  427.                    (($ p) 1 (* k) (* v0))))
  428.        (presimplify-predicate (lambda-body node))
  429.        `(,syntax/lambda ,names
  430.            (,node . ,proclaims))))))
  431.  
  432. (define (make-closed-conditional p)
  433.   (receive (names proclaims)
  434.            (make-proclaims (cddr (vector->list
  435.                                   (proc-type-args (primop.type p nil)))))
  436.     (let ((vars (map create-variable names)))
  437.       (let-nodes ((node (#f k (v0 (car vars)) (v1 (cadr vars)))
  438.                     (($ p) 1 (* k) (* v0) (* v1))))
  439.         (presimplify-to-conditional (lambda-body node))
  440.         `(,syntax/lambda ,names
  441.             (,node . ,proclaims))))))
  442.  
  443. ;;; Make PROCLAIM forms for TYPES.
  444.  
  445. (define (make-proclaims types)
  446.   (iterate loop ((types types) (vars '()) (procs '()))
  447.     (cond ((null? types)
  448.            (return (reverse! vars) (reverse! procs)))
  449.           ((type-top? (car types))
  450.            (let ((var (generate-symbol 't)))
  451.              (loop (cdr types) (cons var vars) (cons var procs))))
  452.           ((type-predicate (car types))
  453.            => (lambda (predicate)
  454.                 (let ((var (generate-symbol 't)))
  455.                   (loop (cdr types)
  456.                         (cons var vars)
  457.                         (cons `(enforce ,predicate ,var) procs)))))
  458.           (else
  459.            (bug "there is no predicate for ~S" (car types))))))
  460.  
  461.  
  462. (lset *n-ary->binary-arg-limit* '2)   ; Limit code explosion
  463.  
  464. (define (n-ary->binary call proc)
  465.   (let ((args (cdr (call-args call)))
  466.         (var (get-system-variable proc)))
  467.     (cond ((or (null? args) (null? (cdr args)))
  468.            (bug "not enough arguments in ~S for N-ARY->BINARY" call))
  469.           ((null? (cddr args))
  470.            (replace (call-proc call) (create-reference-node var))
  471.            '#t)
  472.           ((fx< *n-ary->binary-arg-limit* (length args))
  473.            '#f)
  474.           (else
  475.            (let ((top (node-parent call))
  476.                  (cont (detach ((call-arg 1) call))))
  477.              (iterate loop ((args args) (cont cont))
  478.                (cond ((null? (cddr args))
  479.                       (let-nodes ((c1 ((* var) 1 cont
  480.                                        (! (detach (car args)))
  481.                                        (! (detach (cadr args))))))
  482.                         (replace call c1))
  483.                       '#t)
  484.                      (else
  485.                       (let-nodes ((l1 (#f v) ((* var) 1 cont 
  486.                                               (! (detach (car args)))
  487.                                               (* v))))
  488.                         (loop (cdr args) l1))))))))))
  489.  
  490. (define (presimplify-to-funny-conditional node count)
  491.   (destructure (((pred cont arg1 arg2) (call-proc+args node)))
  492.     (construct-funny-conditional node pred cont arg1 arg2 count)))
  493.  
  494. (define (construct-funny-conditional node pred cont arg1 arg2 count)
  495.   (let ((primop (if (primop-node? pred)
  496.                     pred
  497.                     (create-primop-node (known-primop pred)))))
  498.     (walk detach (call-proc+args node))
  499.     (if (reference-node? pred) (erase pred))
  500.     (let-nodes ((c1 ((^ l1) 1 cont))
  501.                  (l1 (#f v1)
  502.                      (($ primop/conditional) 2
  503.                       (! (construct-conditional-cont count v1 '#t))
  504.                       (! (construct-conditional-cont count v1 '#f))
  505.                       primop arg1 arg2)))
  506.       (replace node c1))))
  507.  
  508. (define (construct-conditional-cont arg-count var value)
  509.   (let* ((vars (make-vars arg-count))
  510.          (args (map create-reference-node vars)))
  511.     (let-nodes ((l1 (#f . vars) ((* var) 0 'value . args)))
  512.       l1)))
  513.  
  514. (define (make-vars count)
  515.   (do ((i 0 (fx+ i 1))
  516.        (v '() (cons (create-variable 'v) v)))
  517.       ((fx>= i count) v)))
  518.