(let ((arg (car args))
(var (car vars)))
(cond ((leaf-refs var)
- (assert-continuation-type arg (leaf-type var)))
+ (assert-continuation-type arg (leaf-type var)
+ (lexenv-policy (node-lexenv call))))
(t
(flush-dest arg)
(setf (car args) nil)))))
(values))
;;; Attempt to convert a multiple-value call. The only interesting
-;;; case is a call to a function that Looks-Like-An-MV-Bind, has
+;;; case is a call to a function that LOOKS-LIKE-AN-MV-BIND, has
;;; exactly one reference and no XEP, and is called with one values
;;; continuation.
;;;
(assert-continuation-type
(first (basic-combination-args call))
(make-values-type :optional (mapcar #'leaf-type (lambda-vars ep))
- :rest *universal-type*))))
+ :rest *universal-type*)
+ (lexenv-policy (node-lexenv call)))))
(values))
;;; Attempt to convert a call to a lambda. If the number of args is
(flame (policy call (or (> speed inhibit-warnings)
(> space inhibit-warnings))))
(loser nil)
+ (allowp nil)
+ (allow-found nil)
(temps (make-gensym-list max))
(more-temps (make-gensym-list (length more))))
(collect ((ignores)
(let ((name (continuation-value cont))
(dummy (first temp))
(val (second temp)))
+ ;; FIXME: check whether KEY was supplied earlier
+ (when (and (eq name :allow-other-keys) (not allow-found))
+ (let ((val (second key)))
+ (cond ((constant-continuation-p val)
+ (setq allow-found t
+ allowp (continuation-value val)))
+ (t (when flame
+ (compiler-note "non-constant :ALLOW-OTHER-KEYS value"))
+ (setf (basic-combination-kind call) :error)
+ (return-from convert-more-call)))))
(dolist (var (key-vars)
(progn
(ignores dummy val)
- (setq loser name)))
+ (unless (eq name :allow-other-keys)
+ (setq loser name))))
(let ((info (lambda-var-arg-info var)))
(when (eq (arg-info-key info) name)
(ignores dummy)
(supplied (cons var val))
(return)))))))
- (when (and loser (not (optional-dispatch-allowp fun)))
+ (when (and loser (not (optional-dispatch-allowp fun)) (not allowp))
(compiler-warn "function called with unknown argument keyword ~S"
loser)
(setf (basic-combination-kind call) :error)
;; information.
(setf (tail-set-info (lambda-tail-set clambda)) nil))
-;;; Handle the environment semantics of LET conversion. We add CLAMBDA
-;;; and its LETs to LETs for the CALL's home function. We merge the
-;;; calls for CLAMBDA with the calls for the home function, removing
-;;; CLAMBDA in the process. We also merge the ENTRIES.
+;;; Handle the PHYSENV semantics of LET conversion. We add CLAMBDA and
+;;; its LETs to LETs for the CALL's home function. We merge the calls
+;;; for CLAMBDA with the calls for the home function, removing CLAMBDA
+;;; in the process. We also merge the ENTRIES.
;;;
;;; We also unlink the function head from the component head and set
;;; COMPONENT-REANALYZE to true to indicate that the DFO should be
(depart-from-tail-set clambda)
(let* ((home (node-home-lambda call))
- (home-env (lambda-physenv home)))
+ (home-physenv (lambda-physenv home)))
+
+ (aver (not (eq home clambda)))
;; CLAMBDA belongs to HOME now.
(push clambda (lambda-lets home))
(setf (lambda-home clambda) home)
- (setf (lambda-physenv clambda) home-env)
+ (setf (lambda-physenv clambda) home-physenv)
;; All of CLAMBDA's LETs belong to HOME now.
(let ((lets (lambda-lets clambda)))
(dolist (let lets)
- (setf (lambda-home let) home)
- (setf (lambda-physenv let) home-env))
+ (setf (lambda-home let) home)
+ (setf (lambda-physenv let) home-physenv))
(setf (lambda-lets home) (nconc lets (lambda-lets home))))
;; CLAMBDA no longer has an independent existence as an entity
;; which has LETs.
;; HOME no longer calls CLAMBDA, and owns all of CLAMBDA's old
;; DFO dependencies.
(setf (lambda-calls-or-closes home)
- (delete clambda
- (nunion (lambda-calls-or-closes clambda)
- (lambda-calls-or-closes home))))
+ (delete clambda
+ (nunion (lambda-calls-or-closes clambda)
+ (lambda-calls-or-closes home))))
;; CLAMBDA no longer has an independent existence as an entity
;; which calls things or has DFO dependencies.
(setf (lambda-calls-or-closes clambda) nil)
;; All of CLAMBDA's ENTRIES belong to HOME now.
(setf (lambda-entries home)
- (nconc (lambda-entries clambda)
- (lambda-entries home)))
+ (nconc (lambda-entries clambda)
+ (lambda-entries home)))
;; CLAMBDA no longer has an independent existence as an entity
;; with ENTRIES.
(setf (lambda-entries clambda) nil))
(cont (node-cont call))
(call-type (node-derived-type call)))
(when (eq (continuation-use cont) call)
- (assert-continuation-type cont (continuation-asserted-type result)))
+ (set-continuation-type-assertion
+ cont
+ (continuation-asserted-type result)
+ (continuation-type-to-check result)))
(unless (eq call-type *wild-type*)
(do-uses (use result)
(derive-node-type use call-type)))
(null (rest refs))
(member (functional-kind clambda) '(nil :assignment))
(not (functional-entry-fun clambda)))
- (let* ((ref-cont (node-cont (first refs)))
+ (let* ((ref (first refs))
+ (ref-cont (node-cont ref))
(dest (continuation-dest ref-cont)))
(when (and dest
(basic-combination-p dest)
(t
(reoptimize-continuation ref-cont)
nil)))
+ (when (eq clambda (node-home-lambda dest))
+ (delete-lambda clambda)
+ (return-from maybe-let-convert nil))
(unless (eq (functional-kind clambda) :assignment)
- (let-convert clambda dest))
+ (let-convert clambda dest))
(reoptimize-call dest)
(setf (functional-kind clambda)
(if (mv-combination-p dest) :mv-let :let))))
(declare (type clambda clambda))
(when (and (not (functional-kind clambda))
(not (functional-entry-fun clambda)))
- (let ((non-tail nil)
- (call-fun nil))
+ (let ((outside-non-tail-call nil)
+ (outside-call nil))
(when (and (dolist (ref (leaf-refs clambda) t)
(let ((dest (continuation-dest (node-cont ref))))
(when (or (not dest)
(return nil))
(let ((home (node-home-lambda ref)))
(unless (eq home clambda)
- (when call-fun
+ (when outside-call
(return nil))
- (setq call-fun home))
+ (setq outside-call dest))
(unless (node-tail-p dest)
- (when (or non-tail (eq home clambda))
+ (when (or outside-non-tail-call (eq home clambda))
(return nil))
- (setq non-tail dest)))))
+ (setq outside-non-tail-call dest)))))
(ok-initial-convert-p clambda))
- (setf (functional-kind clambda) :assignment)
- (let-convert clambda
- (or non-tail
- (continuation-dest
- (node-cont (first (leaf-refs clambda))))))
- (when non-tail
- (reoptimize-call non-tail))
- t))))
+ (cond (outside-call (setf (functional-kind clambda) :assignment)
+ (let-convert clambda outside-call)
+ (when outside-non-tail-call
+ (reoptimize-call outside-non-tail-call))
+ t)
+ (t (delete-lambda clambda)
+ nil))))))
projects / sbcl.git / blobdiff