X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran-lambda.lisp;h=f1570193a0f5eb2a395b55801eaeca640f6a2b66;hb=99f12b8ef75252c8d2d52705b53f2a8f9227443a;hp=f424f51372be7d2dcde3f81320ac3df88685ccf7;hpb=bc382783a653d8051718b9712c8c873eea2c8bbf;p=sbcl.git diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp index f424f51..f157019 100644 --- a/src/compiler/ir1tran-lambda.lisp +++ b/src/compiler/ir1tran-lambda.lisp @@ -773,6 +773,7 @@ (declare (type optional-dispatch res) (list default-vars default-vals entry-vars entry-vals vars body aux-vars aux-vals)) + (aver (or debug-name (neq '.anonymous. source-name))) (cond ((not vars) (if (optional-dispatch-keyp res) ;; Handle &KEY with no keys... @@ -858,12 +859,11 @@ ;;; call IR1-CONVERT-HAIRY-ARGS to do the work. When it is done, we ;;; figure out the MIN-ARGS and MAX-ARGS. (defun ir1-convert-hairy-lambda (body vars keyp allowp aux-vars aux-vals - &key - post-binding-lexenv - (source-name '.anonymous.) - (debug-name - (debug-name '&optional-dispatch vars))) + &key post-binding-lexenv + (source-name '.anonymous.) + debug-name) (declare (list body vars aux-vars aux-vals)) + (aver (or debug-name (neq '.anonymous. source-name))) (let ((res (make-optional-dispatch :arglist vars :allowp allowp :keyp keyp @@ -899,16 +899,19 @@ (compiler-error "The lambda expression has a missing or non-list lambda list:~% ~S" form)) - + (unless (or debug-name (neq '.anonymous. source-name)) + (setf debug-name (name-lambdalike form))) (multiple-value-bind (vars keyp allow-other-keys aux-vars aux-vals) (make-lambda-vars (cadr form)) (multiple-value-bind (forms decls) (parse-body (cddr form)) (binding* (((*lexenv* result-type post-binding-lexenv) (process-decls decls (append aux-vars vars) nil :binding-form-p t)) - (forms (if (and maybe-add-debug-catch - *allow-instrumenting* - (policy *lexenv* (>= insert-debug-catch 2))) + (debug-catch-p (and maybe-add-debug-catch + *allow-instrumenting* + (policy *lexenv* + (>= insert-debug-catch 2)))) + (forms (if debug-catch-p (wrap-forms-in-debug-catch forms) forms)) (forms (if (eq result-type *wild-type*) @@ -929,9 +932,23 @@ :debug-name debug-name)))) (setf (functional-inline-expansion res) form) (setf (functional-arg-documentation res) (cadr form)) + (when (boundp '*lambda-conversions*) + ;; KLUDGE: Not counting TL-XEPs is a lie, of course, but + ;; keeps things less confusing to users of TIME, where this + ;; count gets used. + (unless (and (consp debug-name) (eq 'tl-xep (car debug-name))) + (incf *lambda-conversions*))) res)))) (defun wrap-forms-in-debug-catch (forms) + #!+unwind-to-frame-and-call-vop + `((multiple-value-prog1 + (progn + ,@forms) + ;; Just ensure that there won't be any tail-calls, IR2 magic will + ;; handle the rest. + (values))) + #!-unwind-to-frame-and-call-vop `( ;; Normally, we'll return from this block with the below RETURN-FROM. (block return-value-tag @@ -960,6 +977,8 @@ &key (source-name '.anonymous.) debug-name) + (when (and (not debug-name) (eq '.anonymous. source-name)) + (setf debug-name (name-lambdalike thing))) (ecase (car thing) ((lambda) (ir1-convert-lambda thing @@ -974,7 +993,7 @@ ((named-lambda) (let ((name (cadr thing)) (lambda-expression `(lambda ,@(cddr thing)))) - (if (legal-fun-name-p name) + (if (and name (legal-fun-name-p name)) (let ((defined-fun-res (get-defined-fun name)) (res (ir1-convert-lambda lambda-expression :maybe-add-debug-catch t @@ -989,7 +1008,8 @@ res) (ir1-convert-lambda lambda-expression :maybe-add-debug-catch t - :debug-name name)))) + :debug-name + (or name (name-lambdalike thing)))))) ((lambda-with-lexenv) (ir1-convert-inline-lambda thing :source-name source-name @@ -1006,27 +1026,32 @@ (source-name '.anonymous.) debug-name system-lambda) + (when (and (not debug-name) (eq '.anonymous. source-name)) + (setf debug-name (name-lambdalike fun))) (destructuring-bind (decls macros symbol-macros &rest body) - (if (eq (car fun) 'lambda-with-lexenv) - (cdr fun) - `(() () () . ,(cdr fun))) - (let ((*lexenv* (make-lexenv - :default (process-decls decls nil nil - :lexenv (make-null-lexenv)) - :vars (copy-list symbol-macros) - :funs (mapcar (lambda (x) - `(,(car x) . - (macro . ,(coerce (cdr x) 'function)))) - macros) - ;; Inherit MUFFLE-CONDITIONS from the call-site lexenv - ;; rather than the definition-site lexenv, since it seems - ;; like a much more common case. - :handled-conditions (lexenv-handled-conditions *lexenv*) - :policy (lexenv-policy *lexenv*))) - (*allow-instrumenting* (and (not system-lambda) *allow-instrumenting*))) - (ir1-convert-lambda `(lambda ,@body) - :source-name source-name - :debug-name debug-name)))) + (if (eq (car fun) 'lambda-with-lexenv) + (cdr fun) + `(() () () . ,(cdr fun))) + (let* ((*lexenv* (make-lexenv + :default (process-decls decls nil nil + :lexenv (make-null-lexenv)) + :vars (copy-list symbol-macros) + :funs (mapcar (lambda (x) + `(,(car x) . + (macro . ,(coerce (cdr x) 'function)))) + macros) + ;; Inherit MUFFLE-CONDITIONS from the call-site lexenv + ;; rather than the definition-site lexenv, since it seems + ;; like a much more common case. + :handled-conditions (lexenv-handled-conditions *lexenv*) + :policy (lexenv-policy *lexenv*))) + (*allow-instrumenting* (and (not system-lambda) + *allow-instrumenting*)) + (clambda (ir1-convert-lambda `(lambda ,@body) + :source-name source-name + :debug-name debug-name))) + (setf (functional-inline-expanded clambda) t) + clambda))) ;;; Get a DEFINED-FUN object for a function we are about to define. If ;;; the function has been forward referenced, then substitute for the