Skip to content
Snippets Groups Projects
Commit 38ca88d0 authored by dtc's avatar dtc
Browse files

o Skip substitute-single-use-continuation if CONT's assertion is

  incompatbile with the proven type of ARG, such as when ARG
  returns multiple values and CONT has a single value assertion.

o After propagate-let-args, only delete the let when none of
  the variables are set, otherwise an unreferenced variable that is set
  can end up without a home which would be unexpected by later stages
  of the compiler.

o Correct and enhance the values deftransform to adjust the node continuation
  asserted type which may otherwise be inconsistent with the new single value
  type, and set the node derived type to the received single-value-type.
parent 4990759a
No related branches found
No related tags found
No related merge requests found
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1opt.lisp,v 1.67 1999/02/25 13:03:05 pw Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1opt.lisp,v 1.68 2000/07/06 04:41:18 dtc Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -1236,6 +1236,8 @@ ...@@ -1236,6 +1236,8 @@
;;; -- either continuation has a funky TYPE-CHECK annotation. ;;; -- either continuation has a funky TYPE-CHECK annotation.
;;; -- the continuations have incompatible assertions, so the new asserted type ;;; -- the continuations have incompatible assertions, so the new asserted type
;;; would be NIL. ;;; would be NIL.
;;; -- CONT's assertion is incompatbile with the proven type of ARG's, such as
;;; when ARG returns multiple values and CONT has a single value assertion.
;;; -- 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).
;;; ;;;
;;; 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
...@@ -1256,8 +1258,10 @@ ...@@ -1256,8 +1258,10 @@
(member (continuation-type-check arg) '(t nil)) (member (continuation-type-check arg) '(t nil))
(member (continuation-type-check cont) '(t nil)) (member (continuation-type-check cont) '(t nil))
(not (eq (values-type-intersection (not (eq (values-type-intersection
cont-atype cont-atype (continuation-asserted-type arg))
(continuation-asserted-type arg)) *empty-type*))
(not (eq (values-type-intersection
cont-atype (continuation-proven-type arg))
*empty-type*)) *empty-type*))
(eq (lexenv-cookie (node-lexenv dest)) (eq (lexenv-cookie (node-lexenv dest))
(lexenv-cookie (node-lexenv (continuation-dest arg))))) (lexenv-cookie (node-lexenv (continuation-dest arg)))))
...@@ -1308,8 +1312,8 @@ ...@@ -1308,8 +1312,8 @@
;;; 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
;;; been compiled, and thus can't be retroactively modified. ;;; been compiled, and thus can't be retroactively modified.
;;; ;;;
;;; 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
;;; done, then we delete the let. ;;; we are done, then we delete the let.
;;; ;;;
;;; Note that we are responsible for clearing the Continuation-Reoptimize ;;; Note that we are responsible for clearing the Continuation-Reoptimize
;;; flags. ;;; flags.
...@@ -1348,7 +1352,8 @@ ...@@ -1348,7 +1352,8 @@
(t (t
(propagate-to-refs var (continuation-type arg)))))) (propagate-to-refs var (continuation-type arg))))))
(when (every #'null (combination-args call)) (when (and (every #'null (combination-args call))
(notany #'lambda-var-sets (lambda-vars fun)))
(delete-let fun)) (delete-let fun))
(undefined-value)) (undefined-value))
...@@ -1659,17 +1664,48 @@ ...@@ -1659,17 +1664,48 @@
;;; ;;;
;;; 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
;;; PROG1. This allows the computation of the additional values to become dead ;;; PROG1. This allows the computation of the additional values to become dead
;;; code. ;;; code. Some attempt is made to correct the node derived type, setting it to
;;; the received single-value-type. The node continuation asserted type must
;;; also be adjusted, taking care when the continuation has multiple uses.
;;; ;;;
(deftransform values ((&rest vals) * * :node node) (deftransform values ((&rest vals) * * :node node)
(when (typep (continuation-dest (node-cont node)) (let ((cont (node-cont node)))
'(or creturn exit mv-combination)) (when (typep (continuation-dest cont) '(or creturn exit mv-combination))
(give-up)) (give-up))
(setf (node-derived-type node) *wild-type*) (flet ((first-value-type (type)
(if vals (declare (type ctype type))
(let ((dummies (loop repeat (1- (length vals)) (cond ((values-type-p type)
collect (gensym)))) (let ((required (args-type-required type)))
`(lambda (val ,@dummies) (if required
(declare (ignore ,@dummies)) (first required)
val)) (let ((otype (args-type-optional type)))
'nil)) (cond (otype (first otype))
((or (args-type-keyp type)
(args-type-allowp type))
*universal-type*)
((args-type-rest type))
(t *null-type*))))))
((eq type *wild-type*)
*universal-type*)
(t
type))))
(cond ((= (length (find-uses cont)) 1)
(setf (node-derived-type node)
(single-value-type (node-derived-type node)))
(setf (continuation-asserted-type cont)
(first-value-type (continuation-asserted-type cont))))
(t
(setf (node-derived-type node)
(single-value-type (node-derived-type node)))
(setf (continuation-asserted-type cont)
(values-type-union (continuation-asserted-type cont)
(first-value-type
(continuation-asserted-type cont)))))))
(reoptimize-continuation cont)
(if vals
(let ((dummies (loop repeat (1- (length vals))
collect (gensym))))
`(lambda (val ,@dummies)
(declare (ignore ,@dummies))
val))
'nil)))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment