(with-ir1-environment-from-node (lambda-bind (main-entry fun))
(let ((res (ir1-convert-lambda (make-xep-lambda-expression fun)
:debug-name (debug-namify
- "XEP for ~A"
+ "XEP for "
(leaf-debug-name fun)))))
(setf (functional-kind res) :external
(leaf-ever-used res) t
;;; do LET conversion here.
(defun locall-analyze-fun-1 (fun)
(declare (type functional fun))
- (let ((refs (leaf-refs fun))
- (first-time t))
+ (let ((refs (leaf-refs fun)))
(dolist (ref refs)
(let* ((lvar (node-lvar ref))
(dest (when lvar (lvar-dest lvar))))
- (cond ((and (basic-combination-p dest)
- (eq (basic-combination-fun dest) lvar)
- (eq (lvar-uses lvar) ref))
+ (unless (node-to-be-deleted-p ref)
+ (cond ((and (basic-combination-p dest)
+ (eq (basic-combination-fun dest) lvar)
+ (eq (lvar-uses lvar) ref))
- (convert-call-if-possible ref dest)
+ (convert-call-if-possible ref dest)
- (unless (eq (basic-combination-kind dest) :local)
- (reference-entry-point ref)))
- (t
- (reference-entry-point ref))))
- (setq first-time nil)))
+ (unless (eq (basic-combination-kind dest) :local)
+ (reference-entry-point ref)))
+ (t
+ (reference-entry-point ref)))))))
(values))
(return))
(let ((kind (functional-kind functional)))
(cond ((or (functional-somewhat-letlike-p functional)
- (eql kind :deleted))
+ (memq kind '(:deleted :zombie)))
(values)) ; nothing to do
((and (null (leaf-refs functional)) (eq kind nil)
(not (functional-entry-fun functional)))
(ir1-convert-lambda
(functional-inline-expansion original-functional)
:debug-name (debug-namify
- "local inline ~A"
+ "local inline "
(leaf-debug-name
original-functional)))))))
(cond (losing-local-functional
(original-fun (ref-leaf ref)))
(aver (functional-p original-fun))
(unless (or (member (basic-combination-kind call) '(:local :error))
- (block-delete-p block)
- (eq (functional-kind (block-home-lambda block)) :deleted)
+ (node-to-be-deleted-p call)
(member (functional-kind original-fun)
'(:toplevel-xep :deleted))
(not (or (eq (component-kind component) :initial)
(defun convert-mv-call (ref call fun)
(declare (type ref ref) (type mv-combination call) (type functional fun))
(when (and (looks-like-an-mv-bind fun)
- (not (functional-entry-fun fun))
(singleton-p (leaf-refs fun))
(singleton-p (basic-combination-args call)))
(let* ((*current-component* (node-component ref))
(ep (optional-dispatch-entry-point-fun
fun (optional-dispatch-max-args fun))))
- (aver (= (optional-dispatch-min-args fun) 0))
- (setf (basic-combination-kind call) :local)
- (pushnew ep (lambda-calls-or-closes (node-home-lambda call)))
- (merge-tail-sets call ep)
- (change-ref-leaf ref ep)
+ (when (null (leaf-refs ep))
+ (aver (= (optional-dispatch-min-args fun) 0))
+ (aver (not (functional-entry-fun fun)))
+ (setf (basic-combination-kind call) :local)
+ (pushnew ep (lambda-calls-or-closes (node-home-lambda call)))
+ (merge-tail-sets call ep)
+ (change-ref-leaf ref ep)
- (assert-lvar-type
- (first (basic-combination-args call))
- (make-short-values-type (mapcar #'leaf-type (lambda-vars ep)))
- (lexenv-policy (node-lexenv call)))))
+ (assert-lvar-type
+ (first (basic-combination-args call))
+ (make-short-values-type (mapcar #'leaf-type (lambda-vars ep)))
+ (lexenv-policy (node-lexenv call))))))
(values))
;;; Attempt to convert a call to a lambda. If the number of args is
(cond ((= n-call-args nargs)
(convert-call ref call fun))
(t
- ;; FIXME: ANSI requires in "3.2.5 Exceptional Situations in the
- ;; Compiler" that calling a function with "the wrong number of
- ;; arguments" be only a STYLE-ERROR. I think, though, that this
- ;; should only apply when the number of arguments is inferred
- ;; from a previous definition. If the number of arguments
- ;; is DECLAIMed, surely calling with the wrong number is a
- ;; real WARNING. As long as SBCL continues to use CMU CL's
- ;; non-ANSI DEFUN-is-a-DECLAIM policy, we're in violation here,
- ;; but as long as we continue to use that policy, that's the
- ;; not our biggest problem.:-| When we fix that policy, this
- ;; should come back into compliance. (So fix that policy!)
- ;; ..but..
- ;; FIXME, continued: Except that section "3.2.2.3 Semantic
- ;; Constraints" says that if it's within the same file, it's
- ;; wrong. And we're in locall.lisp here, so it's probably
- ;; (haven't checked this..) a call to something in the same
- ;; file. So maybe it deserves a full warning anyway.
- (compiler-warn
+ (warn
+ 'local-argument-mismatch
+ :format-control
"function called with ~R argument~:P, but wants exactly ~R"
- n-call-args nargs)
+ :format-arguments (list n-call-args nargs))
(setf (basic-combination-kind call) :error)))))
\f
;;;; &OPTIONAL, &MORE and &KEYWORD calls
(max-args (optional-dispatch-max-args fun))
(call-args (length (combination-args call))))
(cond ((< call-args min-args)
- ;; FIXME: See FIXME note at the previous
- ;; wrong-number-of-arguments warnings in this file.
- (compiler-warn
+ (warn
+ 'local-argument-mismatch
+ :format-control
"function called with ~R argument~:P, but wants at least ~R"
- call-args min-args)
+ :format-arguments (list call-args min-args))
(setf (basic-combination-kind call) :error))
((<= call-args max-args)
(convert-call ref call
((optional-dispatch-more-entry fun)
(convert-more-call ref call fun))
(t
- ;; FIXME: See FIXME note at the previous
- ;; wrong-number-of-arguments warnings in this file.
- (compiler-warn
+ (warn
+ 'local-argument-mismatch
+ :format-control
"function called with ~R argument~:P, but wants at most ~R"
- call-args max-args)
+ :format-arguments
+ (list call-args max-args))
(setf (basic-combination-kind call) :error))))
(values))
`(lambda ,vars
(declare (ignorable ,@ignores))
(%funcall ,entry ,@args))
- :debug-name (debug-namify "hairy function entry ~S"
+ :debug-name (debug-namify "hairy function entry "
(lvar-fun-name
(basic-combination-fun call)))))))
(convert-call ref call new-fun)
(progn
(ignores dummy val)
(unless (eq name :allow-other-keys)
- (setq loser name))))
+ (setq loser (list name)))))
(let ((info (lambda-var-arg-info var)))
(when (eq (arg-info-key info) name)
(ignores dummy)
(when (and loser (not (optional-dispatch-allowp fun)) (not allowp))
(compiler-warn "function called with unknown argument keyword ~S"
- loser)
+ (car loser))
(setf (basic-combination-kind call) :error)
(return-from convert-more-call)))
;;; new references to it.
(defun let-convert (fun call)
(declare (type clambda fun) (type basic-combination call))
- (let ((next-block (if (node-tail-p call)
- nil
- (insert-let-body fun call))))
+ (let* ((next-block (insert-let-body fun call))
+ (next-block (if (node-tail-p call)
+ nil
+ next-block)))
(move-return-stuff fun call next-block)
- (merge-lets fun call)))
+ (merge-lets fun call)
+ (setf (node-tail-p call) nil)
+ ;; If CALL has a derive type NIL, it means that "its return" is
+ ;; unreachable, but the next BIND is still reachable; in order to
+ ;; not confuse MAYBE-TERMINATE-BLOCK...
+ (setf (node-derived-type call) *wild-type*)))
;;; Reoptimize all of CALL's args and its result.
(defun reoptimize-call (call)
(when (and (basic-combination-p dest)
(eq (basic-combination-fun dest) ref-lvar)
(eq (basic-combination-kind dest) :local)
- (not (block-delete-p (node-block dest)))
- (neq (functional-kind (node-home-lambda dest))
- :deleted)
+ (not (node-to-be-deleted-p dest))
+ (not (block-delete-p (lambda-block clambda)))
(cond ((ok-initial-convert-p clambda) t)
(t
(reoptimize-lvar ref-lvar)
;;; tail-convert. The second is the value of M-C-T-A.
(defun maybe-convert-tail-local-call (call)
(declare (type combination call))
- (let ((return (lvar-dest (node-lvar call))))
+ (let ((return (lvar-dest (node-lvar call)))
+ (fun (combination-lambda call)))
(aver (return-p return))
(when (and (not (node-tail-p call)) ; otherwise already converted
;; this is a tail call
;; non-tail so that we can use known return inside the
;; component.
(not (eq (functional-kind (node-home-lambda call))
- :external)))
+ :external))
+ (not (block-delete-p (lambda-block fun))))
(node-ends-block call)
- (let ((block (node-block call))
- (fun (combination-lambda call)))
+ (let ((block (node-block call)))
(setf (node-tail-p call) t)
(unlink-blocks block (first (block-succ block)))
(link-blocks block (lambda-block fun))
(let ((outside-non-tail-call nil)
(outside-call nil))
(when (and (dolist (ref (leaf-refs clambda) t)
- (let ((dest (lvar-dest (node-lvar ref))))
+ (let ((dest (node-dest ref)))
(when (or (not dest)
(block-delete-p (node-block dest)))
(return nil))
projects / sbcl.git / blobdiff