/[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.2.2 by pw, Tue May 23 16:37:11 2000 UTC revision 1.65.2.3 by dtc, Thu Jul 6 06:58:15 2000 UTC
# Line 1236  Line 1236 
1236  ;;; -- either continuation has a funky TYPE-CHECK annotation.  ;;; -- either continuation has a funky TYPE-CHECK annotation.
1237  ;;; -- the continuations have incompatible assertions, so the new asserted type  ;;; -- the continuations have incompatible assertions, so the new asserted type
1238  ;;;    would be NIL.  ;;;    would be NIL.
1239    ;;; -- CONT's assertion is incompatbile with the proven type of ARG's, such as
1240    ;;;    when ARG returns multiple values and CONT has a single value assertion.
1241  ;;; -- 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).
1242  ;;;  ;;;
1243  ;;;    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 1256  Line 1258 
1258                 (member (continuation-type-check arg) '(t nil))                 (member (continuation-type-check arg) '(t nil))
1259                 (member (continuation-type-check cont) '(t nil))                 (member (continuation-type-check cont) '(t nil))
1260                 (not (eq (values-type-intersection                 (not (eq (values-type-intersection
1261                           cont-atype                           cont-atype (continuation-asserted-type arg))
1262                           (continuation-asserted-type arg))                          *empty-type*))
1263                   (not (eq (values-type-intersection
1264                             cont-atype (continuation-proven-type arg))
1265                          *empty-type*))                          *empty-type*))
1266                 (eq (lexenv-cookie (node-lexenv dest))                 (eq (lexenv-cookie (node-lexenv dest))
1267                     (lexenv-cookie (node-lexenv (continuation-dest arg)))))                     (lexenv-cookie (node-lexenv (continuation-dest arg)))))
# Line 1308  Line 1312 
1312  ;;; over top-level lambda vars.  In such cases, the references may have already  ;;; over top-level lambda vars.  In such cases, the references may have already
1313  ;;; been compiled, and thus can't be retroactively modified.  ;;; been compiled, and thus can't be retroactively modified.
1314  ;;;  ;;;
1315  ;;;    If all of the variables are deleted (have no references) when we are  ;;;    If all of the variables are deleted (have no references or sets) when
1316  ;;; done, then we delete the let.  ;;; we are done, then we delete the let.
1317  ;;;  ;;;
1318  ;;;    Note that we are responsible for clearing the Continuation-Reoptimize  ;;;    Note that we are responsible for clearing the Continuation-Reoptimize
1319  ;;; flags.  ;;; flags.
# Line 1348  Line 1352 
1352         (t         (t
1353          (propagate-to-refs var (continuation-type arg))))))          (propagate-to-refs var (continuation-type arg))))))
1354    
1355    (when (every #'null (combination-args call))    (when (and (every #'null (combination-args call))
1356                 (notany #'lambda-var-sets (lambda-vars fun)))
1357      (delete-let fun))      (delete-let fun))
1358    
1359    (undefined-value))    (undefined-value))
# Line 1659  Line 1664 
1664  ;;;  ;;;
1665  ;;;    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
1666  ;;; PROG1.  This allows the computation of the additional values to become dead  ;;; PROG1.  This allows the computation of the additional values to become dead
1667  ;;; code.  ;;; code.  Some attempt is made to correct the node derived type, setting it to
1668    ;;; the received single-value-type. The node continuation asserted type must
1669    ;;; also be adjusted, taking care when the continuation has multiple uses.
1670  ;;;  ;;;
1671  (deftransform values ((&rest vals) * * :node node)  (deftransform values ((&rest vals) * * :node node)
1672    (when (typep (continuation-dest (node-cont node))    (let ((cont (node-cont node)))
1673                 '(or creturn exit mv-combination))      (when (typep (continuation-dest cont) '(or creturn exit mv-combination))
1674      (give-up))        (give-up))
1675    (setf (node-derived-type node) *wild-type*)      (flet ((first-value-type (type)
1676    (if vals               (declare (type ctype type))
1677        (let ((dummies (loop repeat (1- (length vals))               (cond ((values-type-p type)
1678                         collect (gensym))))                      (let ((required (args-type-required type)))
1679          `(lambda (val ,@dummies)                        (if required
1680             (declare (ignore ,@dummies))                            (first required)
1681             val))                            (let ((otype (args-type-optional type)))
1682        'nil))                              (cond (otype (first otype))
1683                                      ((or (args-type-keyp type)
1684                                           (args-type-allowp type))
1685                                       *universal-type*)
1686                                      ((args-type-rest type))
1687                                      (t *null-type*))))))
1688                       ((eq type *wild-type*)
1689                        *universal-type*)
1690                       (t
1691                        type))))
1692          (cond ((= (length (find-uses cont)) 1)
1693                 (setf (node-derived-type node)
1694                       (single-value-type (node-derived-type node)))
1695                 (setf (continuation-asserted-type cont)
1696                       (first-value-type (continuation-asserted-type cont))))
1697                (t
1698                 (setf (node-derived-type node)
1699                       (single-value-type (node-derived-type node)))
1700                 (setf (continuation-asserted-type cont)
1701                       (values-type-union (continuation-asserted-type cont)
1702                                          (first-value-type
1703                                           (continuation-asserted-type cont)))))))
1704        (reoptimize-continuation cont)
1705        (if vals
1706            (let ((dummies (loop repeat (1- (length vals))
1707                                 collect (gensym))))
1708              `(lambda (val ,@dummies)
1709                 (declare (ignore ,@dummies))
1710                 val))
1711            'nil)))

Legend:
Removed from v.1.65.2.2  
changed lines
  Added in v.1.65.2.3

  ViewVC Help
Powered by ViewVC 1.1.5