/[cmucl]/src/compiler/ir1opt.lisp
ViewVC logotype

Diff of /src/compiler/ir1opt.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.65 by ram, Mon Oct 31 04:27:28 1994 UTC revision 1.65.2.8 by dtc, Tue Sep 26 16:41:20 2000 UTC
# Line 26  Line 26 
26  ;;;  ;;;
27  ;;;    Return true if the sole use of Cont is a reference to a constant leaf.  ;;;    Return true if the sole use of Cont is a reference to a constant leaf.
28  ;;;  ;;;
 (proclaim '(function constant-continuation-p (continuation) boolean))  
29  (defun constant-continuation-p (cont)  (defun constant-continuation-p (cont)
30      (declare (type continuation cont) (values boolean))
31    (let ((use (continuation-use cont)))    (let ((use (continuation-use cont)))
32      (and (ref-p use)      (and (ref-p use)
33           (constant-p (ref-leaf use)))))           (constant-p (ref-leaf use)))))
# Line 38  Line 38 
38  ;;;    Return the constant value for a continuation whose only use is a  ;;;    Return the constant value for a continuation whose only use is a
39  ;;; constant node.  ;;; constant node.
40  ;;;  ;;;
 (proclaim '(function continuation-value (continuation) t))  
41  (defun continuation-value (cont)  (defun continuation-value (cont)
42      (declare (type continuation cont))
43    (assert (constant-continuation-p cont))    (assert (constant-continuation-p cont))
44    (constant-value (ref-leaf (continuation-use cont))))    (constant-value (ref-leaf (continuation-use cont))))
45    
# Line 128  Line 128 
128  ;;;    Return the derived type for Cont's first value.  This is guaranteed not  ;;;    Return the derived type for Cont's first value.  This is guaranteed not
129  ;;; to be a Values or Function type.  ;;; to be a Values or Function type.
130  ;;;  ;;;
 (proclaim '(function continuation-type (continuation) ctype))  
131  (defun continuation-type (cont)  (defun continuation-type (cont)
132      (declare (type continuation cont) (values ctype))
133    (single-value-type (continuation-derived-type cont)))    (single-value-type (continuation-derived-type cont)))
134    
135    
# Line 200  Line 200 
200            (reoptimize-continuation (node-cont node))))))            (reoptimize-continuation (node-cont node))))))
201    (undefined-value))    (undefined-value))
202    
203  (declaim (start-block assert-continuation-type assert-call-type))  (declaim (start-block assert-continuation-type
204                          assert-continuation-optional-type assert-call-type))
205    
206  ;;; Assert-Continuation-Type  --  Interface  ;;; Assert-Continuation-Type  --  Interface
207  ;;;  ;;;
# Line 224  Line 225 
225    (undefined-value))    (undefined-value))
226    
227    
228    ;;; Assert-continuation-optional-type  --  Interface
229    ;;;
230    ;;;    Similar to Assert-Continuation-Type, but asserts that the type is
231    ;;; for an optional argument and that other arguments may be received.
232    ;;;
233    (defun assert-continuation-optional-type (cont type)
234      (declare (type continuation cont) (type ctype type))
235      (let ((opt-type (make-values-type :optional (list type)
236                                        :rest *universal-type*)))
237        (assert-continuation-type cont opt-type)))
238    
239    
240  ;;; Assert-Call-Type  --  Interface  ;;; Assert-Call-Type  --  Interface
241  ;;;  ;;;
242  ;;;    Assert that Call is to a function of the specified Type.  It is assumed  ;;;    Assert that Call is to a function of the specified Type.  It is assumed
# Line 236  Line 249 
249      (dolist (req (function-type-required type))      (dolist (req (function-type-required type))
250        (when (null args) (return-from assert-call-type))        (when (null args) (return-from assert-call-type))
251        (let ((arg (pop args)))        (let ((arg (pop args)))
252          (assert-continuation-type arg req)))          (assert-continuation-optional-type arg req)))
253      (dolist (opt (function-type-optional type))      (dolist (opt (function-type-optional type))
254        (when (null args) (return-from assert-call-type))        (when (null args) (return-from assert-call-type))
255        (let ((arg (pop args)))        (let ((arg (pop args)))
256          (assert-continuation-type arg opt)))          (assert-continuation-optional-type arg opt)))
257    
258      (let ((rest (function-type-rest type)))      (let ((rest (function-type-rest type)))
259        (when rest        (when rest
260          (dolist (arg args)          (dolist (arg args)
261            (assert-continuation-type arg rest))))            (assert-continuation-optional-type arg rest))))
262    
263      (dolist (key (function-type-keywords type))      (dolist (key (function-type-keywords type))
264        (let ((name (key-info-name key)))        (let ((name (key-info-name key)))
265          (do ((arg args (cddr arg)))          (do ((arg args (cddr arg)))
266              ((null arg))              ((null arg))
267            (when (eq (continuation-value (first arg)) name)            (when (eq (continuation-value (first arg)) name)
268              (assert-continuation-type              (assert-continuation-optional-type
269               (second arg) (key-info-type key)))))))               (second arg) (key-info-type key)))))))
270    (undefined-value))    (undefined-value))
271    
# Line 538  Line 551 
551                     (return-from find-result-type (undefined-value)))))                     (return-from find-result-type (undefined-value)))))
552                (t                (t
553                 (use-union (node-derived-type use)))))                 (use-union (node-derived-type use)))))
554        (let ((int (values-type-intersection        (let ((int (values-type-intersection (continuation-asserted-type result)
555                    (continuation-asserted-type result)                                             (use-union))))
                   (use-union))))  
556          (setf (return-result-type node) int))))          (setf (return-result-type node) int))))
557    (undefined-value))    (undefined-value))
558    
# Line 725  Line 737 
737  ;;;  ;;;
738  ;;;    Do IR1 optimizations on a Combination node.  ;;;    Do IR1 optimizations on a Combination node.
739  ;;;  ;;;
 (proclaim '(function ir1-optimize-combination (combination) void))  
740  (defun ir1-optimize-combination (node)  (defun ir1-optimize-combination (node)
741      (declare (type combination node))
742    (when (continuation-reoptimize (basic-combination-fun node))    (when (continuation-reoptimize (basic-combination-fun node))
743      (propagate-function-change node))      (propagate-function-change node))
744    (let ((args (basic-combination-args node))    (let ((args (basic-combination-args node))
# Line 884  Line 896 
896                nil))                nil))
897       (t       (t
898        (let* ((name (leaf-name leaf))        (let* ((name (leaf-name leaf))
899               (info (if (dylan-function-var-p leaf)               (info (info function info
900                         (dylan-function-var-function-info leaf)                           (if (slot-accessor-p leaf)
901                         (info function info                               (if (consp name)
902                               (if (slot-accessor-p leaf)                                   '%slot-setter
903                                   (if (consp name)                                   '%slot-accessor)
904                                       '%slot-setter                               name))))
                                      '%slot-accessor)  
                                  name)))))  
905          (if info          (if info
906              (values leaf (setf (basic-combination-kind call) info))              (values leaf (setf (basic-combination-kind call) info))
907              (values leaf nil)))))))              (values leaf nil)))))))
# Line 1040  Line 1050 
1050                        (record-optimization-failure node transform args))                        (record-optimization-failure node transform args))
1051                      (setf (gethash node table)                      (setf (gethash node table)
1052                            (remove transform (gethash node table) :key #'car)))                            (remove transform (gethash node table) :key #'car)))
1053                  t))))                  t)
1054                   (:delayed
1055                    (remhash node table)
1056                    nil))))
1057            ((and flame            ((and flame
1058                  (valid-function-use node type                  (valid-function-use node type
1059                                      :argument-test #'types-intersect                                      :argument-test #'types-intersect
# Line 1052  Line 1065 
1065    
1066  (declaim (end-block))  (declaim (end-block))
1067    
1068  ;;; GIVE-UP, ABORT-TRANSFORM  --  Interface  ;;; give-up, abort-transform  --  Interface
1069  ;;;  ;;;
1070  ;;;    Just throw the severity and args...  ;;;    Just throw the severity and args...
1071  ;;;  ;;;
 (proclaim '(function give-up (&rest t) nil))  
1072  (defun give-up (&rest args)  (defun give-up (&rest args)
1073    "This function is used to throw out of an IR1 transform, aborting this    "This function is used to throw out of an IR1 transform, aborting this
1074    attempt to transform the call, but admitting the possibility that this or    attempt to transform the call, but admitting the possibility that this or
1075    some other transform will later suceed.  If arguments are supplied, they are    some other transform will later suceed.  If arguments are supplied, they are
1076    format arguments for an efficiency note."    format arguments for an efficiency note."
1077      (values nil)
1078    (throw 'give-up (values :failure args)))    (throw 'give-up (values :failure args)))
1079  ;;;  ;;;
1080  (defun abort-transform (&rest args)  (defun abort-transform (&rest args)
# Line 1070  Line 1083 
1083    attempted."    attempted."
1084    (throw 'give-up (values :aborted args)))    (throw 'give-up (values :aborted args)))
1085    
1086    (defvar *delayed-transforms*)
1087    
1088    ;;; delay-transform  --  Interface
1089    ;;;
1090    (defun delay-transform (node &rest reasons)
1091      "This function is used to throw out of an IR1 transform, and delay the
1092      transform on the node until later. The reasons specifies when the transform
1093      will be later retried. The :optimize reason causes the transform to be
1094      delayed until after the current IR1 optimization pass. The :constraint
1095      reason causes the transform to be delayed until after constraint
1096      propagation."
1097      (let ((assoc (assoc node *delayed-transforms*)))
1098        (cond ((not assoc)
1099               (setf *delayed-transforms*
1100                     (acons node reasons *delayed-transforms*))
1101               (throw 'give-up :delayed))
1102              ((cdr assoc)
1103               (dolist (reason reasons)
1104                 (pushnew reason (cdr assoc)))
1105               (throw 'give-up :delayed)))))
1106    
1107    ;;; retry-delayed-transforms  --  Interface.
1108    ;;;
1109    ;;; Clear any delayed transform with no reasons - these should have been tried
1110    ;;; in the last pass. Then remove the reason from the delayed transform
1111    ;;; reasons, and if any become empty then set reoptimize flags for the
1112    ;;; node. Returns true if any transforms are to be retried.
1113    ;;;
1114    (defun retry-delayed-transforms (reason)
1115      (setf *delayed-transforms* (remove-if-not #'cdr *delayed-transforms*))
1116      (let ((reoptimize nil))
1117        (dolist (assoc *delayed-transforms*)
1118          (let ((reasons (remove reason (cdr assoc))))
1119            (setf (cdr assoc) reasons)
1120            (unless reasons
1121              (let ((node (car assoc)))
1122                (unless (node-deleted node)
1123                  (setf reoptimize t)
1124                  (setf (node-reoptimize node) t)
1125                  (let ((block (node-block node)))
1126                    (setf (block-reoptimize block) t)
1127                    (setf (component-reoptimize (block-component block)) t)))))))
1128        reoptimize))
1129    
1130    
1131  ;;; Transform-Call  --  Internal  ;;; Transform-Call  --  Internal
1132  ;;;  ;;;
# Line 1112  Line 1169 
1169        (cond        (cond
1170         ((not win)         ((not win)
1171          (setf (combination-kind call) :error))          (setf (combination-kind call) :error))
1172           ;; X Always transform the call below so that non-flushable
1173           ;; functions get flushed if the constant folding works.
1174           #+nil
1175         ((= (length values) 1)         ((= (length values) 1)
1176          (with-ir1-environment call          (with-ir1-environment call
1177            (when (producing-fasl-file)            (when (producing-fasl-file)
# Line 1235  Line 1295 
1295  ;;; -- either continuation has a funky TYPE-CHECK annotation.  ;;; -- either continuation has a funky TYPE-CHECK annotation.
1296  ;;; -- the continuations have incompatible assertions, so the new asserted type  ;;; -- the continuations have incompatible assertions, so the new asserted type
1297  ;;;    would be NIL.  ;;;    would be NIL.
1298    ;;; -- CONT's assertion is incompatbile with the proven type of ARG's, such as
1299    ;;;    when ARG returns multiple values and CONT has a single value assertion.
1300  ;;; -- the var's DEST has a different policy than the ARG's (think safety).  ;;; -- the var's DEST has a different policy than the ARG's (think safety).
1301  ;;;  ;;;
1302  ;;;    We change the Ref to be a reference to NIL with unused value, and let it  ;;;    We change the Ref to be a reference to NIL with unused value, and let it
# Line 1255  Line 1317 
1317                 (member (continuation-type-check arg) '(t nil))                 (member (continuation-type-check arg) '(t nil))
1318                 (member (continuation-type-check cont) '(t nil))                 (member (continuation-type-check cont) '(t nil))
1319                 (not (eq (values-type-intersection                 (not (eq (values-type-intersection
1320                           cont-atype                           cont-atype (continuation-asserted-type arg))
1321                           (continuation-asserted-type arg))                          *empty-type*))
1322                   (not (eq (values-type-intersection
1323                             cont-atype (continuation-proven-type arg))
1324                          *empty-type*))                          *empty-type*))
1325                 (eq (lexenv-cookie (node-lexenv dest))                 (eq (lexenv-cookie (node-lexenv dest))
1326                     (lexenv-cookie (node-lexenv (continuation-dest arg)))))                     (lexenv-cookie (node-lexenv (continuation-dest arg)))))
# Line 1346  Line 1410 
1410               (substitute-single-use-continuation arg var)))               (substitute-single-use-continuation arg var)))
1411         (t         (t
1412          (propagate-to-refs var (continuation-type arg))))))          (propagate-to-refs var (continuation-type arg))))))
1413    
1414    (when (every #'null (combination-args call))    (when (every #'null (combination-args call))
1415      (delete-let fun))      (delete-let fun))
1416    
# Line 1459  Line 1523 
1523    (undefined-value))    (undefined-value))
1524    
1525    
1526    ;;; Values-types-defaulted  --  Internal
1527    ;;;
1528    ;;;    Like values-types, but returns the types of the given number of
1529    ;;; arguments. If optional of rest values must be used then the union
1530    ;;; with the null type is computed in case of defaulting, and if no
1531    ;;; values are available then they are defaulted to the null type.
1532    ;;;
1533    (defun values-types-defaulted (type count)
1534      (declare (type ctype type) (type index count))
1535      (cond ((eq type *wild-type*)
1536             (let ((types nil))
1537               (dotimes (i count types)
1538                 (push *universal-type* types))))
1539            ((not (values-type-p type))
1540             (let ((types nil))
1541               (dotimes (i (1- count))
1542                 (push *null-type* types))
1543               (push type types)))
1544            (t
1545             (let ((required (args-type-required type))
1546                   (optional (args-type-optional type))
1547                   (keyp-allowp (or (args-type-keyp type) (args-type-allowp type)))
1548                   (rest (args-type-rest type)))
1549               (collect ((types))
1550                 (dotimes (i count)
1551                   (types (cond (required (single-value-type (pop required)))
1552                                (optional (values-type-union
1553                                           (single-value-type (pop optional))
1554                                           *null-type*))
1555                                (keyp-allowp *universal-type*)
1556                                (rest (values-type-union (single-value-type rest)
1557                                                         *null-type*))
1558                                (t *null-type*))))
1559                 (types))))))
1560    
1561    
1562  ;;; IR1-OPTIMIZE-MV-BIND  --  Internal  ;;; IR1-OPTIMIZE-MV-BIND  --  Internal
1563  ;;;  ;;;
1564  ;;;    Propagate derived type info from the values continuation to the vars.  ;;;    Propagate derived type info from the values continuation to the vars.
# Line 1467  Line 1567 
1567    (declare (type mv-combination node))    (declare (type mv-combination node))
1568    (let ((arg (first (basic-combination-args node)))    (let ((arg (first (basic-combination-args node)))
1569          (vars (lambda-vars (combination-lambda node))))          (vars (lambda-vars (combination-lambda node))))
1570      (multiple-value-bind (types nvals)      (let ((types (values-types-defaulted (continuation-derived-type arg)
1571                           (values-types (continuation-derived-type arg))                                           (length vars))))
1572        (unless (eq nvals :unknown)        (mapc #'(lambda (var type)
1573          (mapc #'(lambda (var type)                  (if (basic-var-sets var)
1574                    (if (basic-var-sets var)                      (propagate-from-sets var type)
1575                        (propagate-from-sets var type)                      (propagate-to-refs var type)))
1576                        (propagate-to-refs var type)))              vars types))
                 vars  
                 (append types  
                         (make-list (max (- (length vars) nvals) 0)  
                                    :initial-element *null-type*)))))  
1577    
1578      (setf (continuation-reoptimize arg) nil))      (setf (continuation-reoptimize arg) nil))
1579    (undefined-value))    (undefined-value))
# Line 1658  Line 1754 
1754  ;;;  ;;;
1755  ;;;    If VALUES appears in a non-MV context, then effectively convert it to a  ;;;    If VALUES appears in a non-MV context, then effectively convert it to a
1756  ;;; PROG1.  This allows the computation of the additional values to become dead  ;;; PROG1.  This allows the computation of the additional values to become dead
1757  ;;; code.  ;;; code.  Some attempt is made to correct the node derived type, setting it to
1758    ;;; the received single-value-type. The node continuation asserted type must
1759    ;;; also be adjusted, taking care when the continuation has multiple uses.
1760  ;;;  ;;;
1761  (deftransform values ((&rest vals) * * :node node)  (deftransform values ((&rest vals) * * :node node)
1762    (when (typep (continuation-dest (node-cont node))    (let ((cont (node-cont node)))
1763                 '(or creturn exit mv-combination))      (when (typep (continuation-dest cont) '(or creturn exit mv-combination))
1764      (give-up))        (give-up))
1765    (setf (node-derived-type node) *wild-type*)      (flet ((first-value-type (type)
1766    (if vals               (declare (type ctype type))
1767        (let ((dummies (loop repeat (1- (length vals))               (cond ((values-type-p type)
1768                         collect (gensym))))                      (let ((required (args-type-required type)))
1769          `(lambda (val ,@dummies)                        (if required
1770             (declare (ignore ,@dummies))                            (first required)
1771             val))                            (let ((otype (args-type-optional type)))
1772        'nil))                              (cond (otype (first otype))
1773                                      ((or (args-type-keyp type)
1774                                           (args-type-allowp type))
1775                                       *universal-type*)
1776                                      ((args-type-rest type))
1777                                      (t *null-type*))))))
1778                       ((eq type *wild-type*)
1779                        *universal-type*)
1780                       (t
1781                        type))))
1782          (cond ((= (length (find-uses cont)) 1)
1783                 (setf (node-derived-type node)
1784                       (single-value-type (node-derived-type node)))
1785                 (setf (continuation-asserted-type cont)
1786                       (first-value-type (continuation-asserted-type cont))))
1787                (t
1788                 (setf (node-derived-type node)
1789                       (single-value-type (node-derived-type node)))
1790                 (setf (continuation-asserted-type cont)
1791                       (values-type-union (continuation-asserted-type cont)
1792                                          (first-value-type
1793                                           (continuation-asserted-type cont)))))))
1794        (reoptimize-continuation cont)
1795        (if vals
1796            (let ((dummies (loop repeat (1- (length vals))
1797                                 collect (gensym))))
1798              `(lambda (val ,@dummies)
1799                 (declare (ignore ,@dummies))
1800                 val))
1801            'nil)))

Legend:
Removed from v.1.65  
changed lines
  Added in v.1.65.2.8

  ViewVC Help
Powered by ViewVC 1.1.5