From 1a6def3955b715472eb2c75b15660912b9f90173 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Tue, 6 Nov 2001 22:21:54 +0000 Subject: [PATCH] 0.pre7.86.flaky7: (This version dies early in cross-compilation with an assertion failure, perhaps because PRE-PHYSENV-ANALYZE-TOPLEVEL isn't being called on the right stuff.) tried to straighten out function names and debug names, splitting LEAF-NAME into LEAF-SOURCE-NAME and LEAF-DEBUG-NAME and making both SOURCE-NAME and DEBUG-NAME read-only.. ..IR1-CONVERT-LAMBDA gets both :SOURCE-NAME and :DEBUG-NAME keyword arguments, and then IR1-CONVERT-LAMBDA-BODY and IR1-CONVERT-HAIRY-LAMBDA and IR1-CONVERT-INLINE-LAMBDA do too ..defined DEBUG-NAMIFY to support this ..deleted no-longer-used COMPILE-FIX-FUN-NAME (and made mental note that it's probably the reason that old COMPILE got function debug name right even though %COMPILE doesn't) removed no-longer-used PRIMITIVE-TRANSLATOR stuff noticed that LAMBDA-VARS is read-only --- src/code/early-extensions.lisp | 4 +- src/code/ntrace.lisp | 16 +- src/compiler/checkgen.lisp | 6 +- src/compiler/copyprop.lisp | 8 +- src/compiler/ctype.lisp | 8 +- src/compiler/debug-dump.lisp | 18 +- src/compiler/debug.lisp | 17 +- src/compiler/entry.lisp | 14 +- src/compiler/generic/target-core.lisp | 3 +- src/compiler/gtn.lisp | 3 +- src/compiler/ir1-translators.lisp | 102 ++++++---- src/compiler/ir1final.lisp | 54 ++--- src/compiler/ir1opt.lisp | 51 +++-- src/compiler/ir1report.lisp | 32 ++- src/compiler/ir1tran.lisp | 359 +++++++++++++++++++-------------- src/compiler/ir1util.lisp | 34 ++-- src/compiler/ir2tran.lisp | 17 +- src/compiler/locall.lisp | 15 +- src/compiler/ltn.lisp | 18 +- src/compiler/macros.lisp | 17 -- src/compiler/main.lisp | 20 +- src/compiler/node.lisp | 139 ++++++++++--- src/compiler/physenvanal.lisp | 12 +- src/compiler/represent.lisp | 2 +- src/compiler/seqtran.lisp | 3 +- src/compiler/target-main.lisp | 17 -- src/compiler/tn.lisp | 10 +- src/compiler/typetran.lisp | 2 +- src/pcl/dfun.lisp | 6 +- version.lisp-expr | 2 +- 30 files changed, 597 insertions(+), 412 deletions(-) diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 3888697..eb21f3a 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -200,7 +200,7 @@ ;;; the function is made the new value for the collection. As a ;;; totally magical special-case, FUNCTION may be COLLECT, which tells ;;; us to build a list in forward order; this is the default. If an -;;; INITIAL-VALUE is supplied for Collect, the stuff will be RPLACD'd +;;; INITIAL-VALUE is supplied for COLLECT, the stuff will be RPLACD'd ;;; onto the end. Note that FUNCTION may be anything that can appear ;;; in the functional position, including macros and lambdas. (defmacro collect (collections &body body) @@ -208,7 +208,7 @@ (binds ())) (dolist (spec collections) (unless (proper-list-of-length-p spec 1 3) - (error "malformed collection specifier: ~S." spec)) + (error "malformed collection specifier: ~S" spec)) (let* ((name (first spec)) (default (second spec)) (kind (or (third spec) 'collect)) diff --git a/src/code/ntrace.lisp b/src/code/ntrace.lisp index da078f2..cdf1660 100644 --- a/src/code/ntrace.lisp +++ b/src/code/ntrace.lisp @@ -188,7 +188,7 @@ *trace-indentation-step*) depth))) -;;; Return true if one of the Names appears on the stack below Frame. +;;; Return true if any of the NAMES appears on the stack below FRAME. (defun trace-wherein-p (frame names) (do ((frame (sb-di:frame-down frame) (sb-di:frame-down frame))) ((not frame) nil) @@ -197,14 +197,14 @@ :test #'equal) (return t)))) -;;; Handle print and print-after options. +;;; Handle PRINT and PRINT-AFTER options. (defun trace-print (frame forms) (dolist (ele forms) (fresh-line) (print-trace-indentation) (format t "~S = ~S" (car ele) (funcall (cdr ele) frame)))) -;;; Test a break option, and break if true. +;;; Test a BREAK option, and break if true. (defun trace-maybe-break (info break where frame) (when (and break (funcall (cdr break) frame)) (sb-di:flush-frames-above frame) @@ -213,9 +213,9 @@ where (trace-info-what info))))) -;;; This function discards any invalid cookies on our simulated stack. -;;; Encapsulated entries are always valid, since we bind -;;; *TRACED-ENTRIES* in the encapsulation. +;;; Discard any invalid cookies on our simulated stack. Encapsulated +;;; entries are always valid, since we bind *TRACED-ENTRIES* in the +;;; encapsulation. (defun discard-invalid-entries (frame) (loop (when (or (null *traced-entries*) @@ -302,8 +302,8 @@ frame))))) ;;; This function is called by the trace encapsulation. It calls the -;;; breakpoint hook functions with NIL for the breakpoint and cookie, which -;;; we have cleverly contrived to work for our hook functions. +;;; breakpoint hook functions with NIL for the breakpoint and cookie, +;;; which we have cleverly contrived to work for our hook functions. (defun trace-call (info) (multiple-value-bind (start cookie) (trace-start-breakpoint-fun info) (let ((frame (sb-di:frame-down (sb-di:top-frame)))) diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp index 6f0dad4..0b6b128 100644 --- a/src/compiler/checkgen.lisp +++ b/src/compiler/checkgen.lisp @@ -263,7 +263,8 @@ (declare (type continuation cont)) (let ((dest (continuation-dest cont))) (cond ((eq (continuation-type-check cont) :error) - (if (and (combination-p dest) (eq (combination-kind dest) :error)) + (if (and (combination-p dest) + (eq (combination-kind dest) :error)) nil t)) ((or (not dest) @@ -416,7 +417,8 @@ (format nil "~:[A possible~;The~] binding of ~S" (and (continuation-use cont) (eq (functional-kind lambda) :let)) - (leaf-name (elt (lambda-vars lambda) pos))))))) + (leaf-source-name (elt (lambda-vars lambda) + pos))))))) (cond ((eq dtype *empty-type*)) ((and (ref-p node) (constant-p (ref-leaf node))) (compiler-warning "~:[This~;~:*~A~] is not a ~<~%~9T~:;~S:~>~% ~S" diff --git a/src/compiler/copyprop.lisp b/src/compiler/copyprop.lisp index f7062ca..4977d1c 100644 --- a/src/compiler/copyprop.lisp +++ b/src/compiler/copyprop.lisp @@ -55,8 +55,8 @@ ;;; The TN must be a :NORMAL TN. Other TNs might have hidden ;;; references or be otherwise bizarre. ;;; -;;; A TN is also inelegible if it has interned name, policy is such -;;; that we would dump it in the debug vars, and speed is not 3. +;;; A TN is also inelegible if we want to preserve it to facilitate +;;; debugging. ;;; ;;; The SCs of the TN's primitive types is a subset of the SCs of the ;;; copied TN. Moves between TNs of different primitive type SCs may @@ -83,8 +83,10 @@ (primitive-type-scs (tn-primitive-type arg-tn))) (let ((leaf (tn-leaf tn))) + ;; Do we not care about preserving this this + ;; TN for debugging? (or (not leaf) - (not (symbol-package (leaf-name leaf))) + (not (symbol-package (leaf-debug-name leaf))) (policy (vop-node vop) (or (= speed 3) (< debug 2))))) arg-tn))))))) diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp index 37907bb..a7ebd89 100644 --- a/src/compiler/ctype.lisp +++ b/src/compiler/ctype.lisp @@ -552,8 +552,8 @@ ((eq int *empty-type*) (note-lossage "Definition's declared type for variable ~A:~% ~S~@ - conflicts with this type from ~A:~% ~S" - (leaf-name var) (type-specifier vtype) + conflicts with this type from ~A:~% ~S" + (leaf-debug-name var) (type-specifier vtype) where (type-specifier type)) (return-from try-type-intersections (values nil nil))) (t @@ -753,7 +753,9 @@ "Assignment to argument: ~S~% ~ prevents use of assertion from function ~ type ~A:~% ~S~%" - (leaf-name var) where (type-specifier type)))) + (leaf-debug-name var) + where + (type-specifier type)))) (t (setf (leaf-type var) type) (dolist (ref (leaf-refs var)) diff --git a/src/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp index 7e6b4a0..a63d179 100644 --- a/src/compiler/debug-dump.lisp +++ b/src/compiler/debug-dump.lisp @@ -316,7 +316,7 @@ (defun dump-1-variable (fun var tn id minimal buffer) (declare (type lambda-var var) (type (or tn null) tn) (type index id) (type clambda fun)) - (let* ((name (leaf-name var)) + (let* ((name (leaf-debug-name var)) (save-tn (and tn (tn-save-tn tn))) (kind (and tn (tn-kind tn))) (flags 0)) @@ -350,14 +350,14 @@ ;;; Return a vector suitable for use as the DEBUG-FUN-VARIABLES ;;; of FUN. LEVEL is the current DEBUG-INFO quality. VAR-LOCS is a -;;; hashtable in which we enter the translation from LAMBDA-VARS to +;;; hash table in which we enter the translation from LAMBDA-VARS to ;;; the relative position of that variable's location in the resulting ;;; vector. (defun compute-variables (fun level var-locs) (declare (type clambda fun) (type hash-table var-locs)) (collect ((vars)) (labels ((frob-leaf (leaf tn gensym-p) - (let ((name (leaf-name leaf))) + (let ((name (leaf-debug-name leaf))) (when (and name (leaf-refs leaf) (tn-offset tn) (or gensym-p (symbol-package name))) (vars (cons leaf tn))))) @@ -377,7 +377,7 @@ (let ((sorted (sort (vars) #'string< :key #'(lambda (x) - (symbol-name (leaf-name (car x)))))) + (symbol-name (leaf-debug-name (car x)))))) (prev-name nil) (id 0) (i 0) @@ -386,7 +386,7 @@ (type index id i)) (dolist (x sorted) (let* ((var (car x)) - (name (symbol-name (leaf-name var)))) + (name (symbol-name (leaf-debug-name var)))) (cond ((and prev-name (string= prev-name name)) (incf id)) (t @@ -476,13 +476,7 @@ (main-p (and dispatch (eq fun (optional-dispatch-main-entry dispatch))))) (make-compiled-debug-fun - :name (cond ((leaf-name fun)) - ((let ((ef (functional-entry-function fun))) - (and ef (leaf-name ef)))) - ((and main-p (leaf-name dispatch))) - (t - (component-name - (block-component (node-block (lambda-bind fun)))))) + :name (leaf-debug-name fun) :kind (if main-p nil (functional-kind fun)) :return-pc (tn-sc-offset (ir2-physenv-return-pc 2env)) :old-fp (tn-sc-offset (ir2-physenv-old-fp 2env)) diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp index 6bfdce6..a1075e3 100644 --- a/src/compiler/debug.lisp +++ b/src/compiler/debug.lisp @@ -908,19 +908,12 @@ (defun print-leaf (leaf &optional (stream *standard-output*)) (declare (type leaf leaf) (type stream stream)) (etypecase leaf - (lambda-var (prin1 (leaf-name leaf) stream)) + (lambda-var (prin1 (leaf-debug-name leaf) stream)) (constant (format stream "'~S" (constant-value leaf))) (global-var - (format stream "~S {~A}" (leaf-name leaf) (global-var-kind leaf))) - (clambda - (format stream "lambda ~S ~S" (leaf-name leaf) - (mapcar #'leaf-name (lambda-vars leaf)))) - (optional-dispatch - (format stream "optional-dispatch ~S" (leaf-name leaf))) + (format stream "~S {~A}" (leaf-debug-name leaf) (global-var-kind leaf))) (functional - (aver (eq (functional-kind leaf) :toplevel-xep)) - (format stream "TL-XEP ~S" - (entry-info-name (leaf-info leaf)))))) + (format stream "~S ~S" (type-of leaf) (functional-debug-name leaf))))) ;;; Attempt to find a block given some thing that has to do with it. (declaim (ftype (function (t) cblock) block-or-lose)) @@ -945,8 +938,8 @@ (format t " c~D" (cont-num cont)) (values)) -;;; Print out the nodes in Block in a format oriented toward representing -;;; what the code does. +;;; Print out the nodes in BLOCK in a format oriented toward +;;; representing what the code does. (defun print-nodes (block) (setq block (block-or-lose block)) (format t "~%block start c~D" (cont-num (block-start block))) diff --git a/src/compiler/entry.lisp b/src/compiler/entry.lisp index bdb48e1..5c56812 100644 --- a/src/compiler/entry.lisp +++ b/src/compiler/entry.lisp @@ -59,9 +59,7 @@ (not (null (physenv-closure (lambda-physenv fun))))) (setf (entry-info-offset info) (gen-label)) (setf (entry-info-name info) - (let ((name (leaf-name internal-fun))) - (or name - (component-name (block-component (node-block bind)))))) + (leaf-debug-name internal-fun)) (when (policy bind (>= debug 1)) (setf (entry-info-arguments info) (make-arg-names internal-fun)) (setf (entry-info-type info) (type-specifier (leaf-type internal-fun))))) @@ -90,10 +88,12 @@ (:external (unless (lambda-has-external-references-p lambda) (let* ((ef (functional-entry-function lambda)) - (new (make-functional :kind :toplevel-xep - :info (leaf-info lambda) - :name (leaf-name ef) - :lexenv (make-null-lexenv))) + (new (make-functional + :kind :toplevel-xep + :info (leaf-info lambda) + :%source-name (functional-%source-name ef) + :%debug-name (functional-%debug-name ef) + :lexenv (make-null-lexenv))) (closure (physenv-closure (lambda-physenv (main-entry ef))))) (dolist (ref (leaf-refs lambda)) diff --git a/src/compiler/generic/target-core.lisp b/src/compiler/generic/target-core.lisp index 1f2b4b1..0ef862b 100644 --- a/src/compiler/generic/target-core.lisp +++ b/src/compiler/generic/target-core.lisp @@ -82,7 +82,8 @@ (push info (core-object-debug-info object)) (setf (%code-debug-info code-obj) info)) - (setf (code-header-ref code-obj sb!vm:code-trace-table-offset-slot) length) + (setf (code-header-ref code-obj sb!vm:code-trace-table-offset-slot) + length) (copy-to-system-area trace-table (* sb!vm:vector-data-offset sb!vm:n-word-bits) fill-ptr diff --git a/src/compiler/gtn.lisp b/src/compiler/gtn.lisp index b954bb7..400ee93 100644 --- a/src/compiler/gtn.lisp +++ b/src/compiler/gtn.lisp @@ -141,7 +141,8 @@ "Return value count mismatch prevents known return ~ from these functions:~ ~{~% ~A~}" - (remove nil (mapcar #'leaf-name funs))))) + (mapcar #'leaf-source-name + (remove-if-not #'leaf-has-source-name-p funs))))) (let ((ret (lambda-return fun))) (when ret (let ((rtype (return-result-type ret))) diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 7124cad..e9910b5 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -323,13 +323,12 @@ (compiler-error "Lisp error during evaluation of info args:~%~A" condition)))) -;;; If there is a primitive translator, then we expand the call. -;;; Otherwise, we convert to the %%PRIMITIVE funny function. The first -;;; argument is the template, the second is a list of the results of -;;; any codegen-info args, and the remaining arguments are the runtime +;;; Convert to the %%PRIMITIVE funny function. The first argument is +;;; the template, the second is a list of the results of any +;;; codegen-info args, and the remaining arguments are the runtime ;;; arguments. ;;; -;;; We do a bunch of error checking now so that we don't bomb out with +;;; We do various error checking now so that we don't bomb out with ;;; a fatal error during IR2 conversion. ;;; ;;; KLUDGE: It's confusing having multiple names floating around for @@ -341,11 +340,10 @@ ;;; FIXME: Look at doing this ^, it doesn't look too hard actually. (def-ir1-translator %primitive ((name &rest args) start cont) (unless (symbolp name) - (compiler-error "The primitive name ~S is not a symbol." name)) - + (compiler-error "internal error: Primitive name ~S is not a symbol." name)) (let* ((template (or (gethash name *backend-template-names*) (compiler-error - "The primitive name ~A is not defined." + "internal error: Primitive name ~A is not defined." name))) (required (length (template-arg-types template))) (info (template-info-arg-count template)) @@ -353,13 +351,15 @@ (nargs (length args))) (if (template-more-args-type template) (when (< nargs min) - (compiler-error "Primitive ~A was called with ~R argument~:P, ~ + (compiler-error "internal error: Primitive ~A was called ~ + with ~R argument~:P, ~ but wants at least ~R." name nargs min)) (unless (= nargs min) - (compiler-error "Primitive ~A was called with ~R argument~:P, ~ + (compiler-error "internal error: Primitive ~A was called ~ + with ~R argument~:P, ~ but wants exactly ~R." name nargs @@ -397,13 +397,19 @@ (if (consp thing) (case (car thing) ((lambda) - (reference-leaf start cont (ir1-convert-lambda thing))) + (reference-leaf start + cont + (ir1-convert-lambda thing + :debug-name (debug-namify + "#'~S" thing)))) ((setf) (let ((var (find-lexically-apparent-function thing "as the argument to FUNCTION"))) (reference-leaf start cont var))) ((instance-lambda) - (let ((res (ir1-convert-lambda `(lambda ,@(cdr thing))))) + (let ((res (ir1-convert-lambda `(lambda ,@(cdr thing)) + :debug-name (debug-namify "#'~S" + thing)))) (setf (getf (functional-plist res) :fin-function) t) (reference-leaf start cont res))) (t @@ -501,7 +507,8 @@ (multiple-value-bind (vars values) (extract-let-variables bindings 'let) (let* ((*lexenv* (process-decls decls vars nil cont)) (fun-cont (make-continuation)) - (fun (ir1-convert-lambda-body forms vars))) + (fun (ir1-convert-lambda-body + forms vars :debug-name (debug-namify "LET ~S" bindings)))) (reference-leaf start fun-cont fun) (ir1-convert-combination-args fun-cont cont values))))) @@ -575,19 +582,16 @@ (multiple-value-bind (names defs) (extract-flet-variables definitions 'flet) (let* ((fvars (mapcar (lambda (n d) - (ir1-convert-lambda d n)) + (ir1-convert-lambda d + :source-name n + :debug-name (debug-namify + "FLET ~S" n))) names defs)) (*lexenv* (make-lexenv :default (process-decls decls nil fvars cont) :functions (pairlis names fvars)))) (ir1-convert-progn-body start cont forms))))) -;;; For LABELS, we have to create dummy function vars and add them to -;;; the function namespace while converting the functions. We then -;;; modify all the references to these leaves so that they point to -;;; the real functional leaves. We also backpatch the FENV so that if -;;; the lexical environment is used for inline expansion we will get -;;; the right functions. (def-ir1-translator labels ((definitions &body body) start cont) #!+sb-doc "LABELS ({(Name Lambda-List Declaration* Form*)}*) Declaration* Body-Form* @@ -597,36 +601,56 @@ (multiple-value-bind (forms decls) (sb!sys:parse-body body nil) (multiple-value-bind (names defs) (extract-flet-variables definitions 'labels) - (let* ((new-fenv (loop for name in names - collect (cons name (make-functional :name name)))) + (let* (;; dummy LABELS function vars, to be used during + ;; conversion of real LABELS functions + (placeholder-funs (mapcar (lambda (name) + (make-functional + :%source-name name + :%debug-name (debug-namify + "LABELS placeholder ~S" + name))) + names)) + (placeholder-fenv (pairlis names placeholder-funs)) + ;; the real LABELS functions, compiled in a LEXENV which + ;; includes the dummy LABELS functions (real-funs - (let ((*lexenv* (make-lexenv :functions new-fenv))) + (let ((*lexenv* (make-lexenv :functions placeholder-fenv))) (mapcar (lambda (n d) - (ir1-convert-lambda d n)) + (ir1-convert-lambda d + :source-name n + :debug-name (debug-namify + "LABELS ~S" n))) names defs)))) - (loop for real in real-funs and env in new-fenv do - (let ((dum (cdr env))) - (substitute-leaf real dum) - (setf (cdr env) real))) + ;; Modify all the references to the dummy function leaves so + ;; that they point to the real function leaves. + (loop for real-fun in real-funs and envpair in placeholder-fenv do + (let ((placeholder-fun (cdr envpair))) + (substitute-leaf real-fun placeholder-fun) + (setf (cdr envpair) real-fun))) + ;; Voila. (let ((*lexenv* (make-lexenv :default (process-decls decls nil real-funs cont) - :functions (pairlis names real-funs)))) + ;; Use a proper FENV here (not the + ;; placeholder used earlier) so that if the + ;; lexical environment is used for inline + ;; expansion we'll get the right functions. + :functions (pairlis names real-funs)))) (ir1-convert-progn-body start cont forms)))))) -;;;; THE +;;;; the THE special operator, and friends ;;; Do stuff to recognize a THE or VALUES declaration. CONT is the ;;; continuation that the assertion applies to, TYPE is the type -;;; specifier and Lexenv is the current lexical environment. NAME is +;;; specifier and LEXENV is the current lexical environment. NAME is ;;; the name of the declaration we are doing, for use in error ;;; messages. ;;; ;;; This is somewhat involved, since a type assertion may only be made ;;; on a continuation, not on a node. We can't just set the ;;; continuation asserted type and let it go at that, since there may -;;; be parallel THE's for the same continuation, i.e.: +;;; be parallel THE's for the same continuation, i.e. ;;; (if ... ;;; (the foo ...) ;;; (the bar ...)) @@ -1017,9 +1041,9 @@ (info :function :macro-function name) (coerce def 'function)) (let* ((*current-path* (revert-source-path 'defmacro)) - (fun (ir1-convert-lambda def name))) - (setf (leaf-name fun) - (concatenate 'string "DEFMACRO " (symbol-name name))) + (fun (ir1-convert-lambda def + :debug-name (debug-namify "DEFMACRO ~S" + name)))) (setf (functional-arg-documentation fun) (eval lambda-list)) (ir1-convert start cont `(%%defmacro ',name ,fun ,doc))) @@ -1058,10 +1082,10 @@ (coerce def 'function)) (let* ((*current-path* (revert-source-path 'define-compiler-macro)) - (fun (ir1-convert-lambda def name))) - (setf (leaf-name fun) - (let ((*print-case* :upcase)) - (format nil "DEFINE-COMPILER-MACRO ~S" name))) + (fun (ir1-convert-lambda def + :debug-name (debug-namify + "DEFINE-COMPILER-MACRO ~S" + name)))) (setf (functional-arg-documentation fun) (eval lambda-list)) (ir1-convert start cont `(%%define-compiler-macro ',name ,fun ,doc))) diff --git a/src/compiler/ir1final.lisp b/src/compiler/ir1final.lisp index c894154..175d73a 100644 --- a/src/compiler/ir1final.lisp +++ b/src/compiler/ir1final.lisp @@ -57,36 +57,36 @@ ;;; possibility that new references might be converted to it. (defun finalize-xep-definition (fun) (let* ((leaf (functional-entry-function fun)) - (name (leaf-name leaf)) (defined-ftype (definition-type leaf))) (setf (leaf-type leaf) defined-ftype) - (when (legal-fun-name-p name) - (let* ((where (info :function :where-from name)) - (*compiler-error-context* (lambda-bind (main-entry leaf))) - (global-def (gethash name *free-functions*)) - (global-p (defined-fun-p global-def))) - (note-name-defined name :function) - (when global-p - (remhash name *free-functions*)) - (ecase where - (:assumed - (let ((approx-type (info :function :assumed-type name))) - (when (and approx-type (fun-type-p defined-ftype)) - (valid-approximate-type approx-type defined-ftype)) - (setf (info :function :type name) defined-ftype) - (setf (info :function :assumed-type name) nil)) - (setf (info :function :where-from name) :defined)) - (:declared - (let ((declared-ftype (info :function :type name))) - (unless (defined-ftype-matches-declared-ftype-p - defined-ftype declared-ftype) - (note-lossage "~@" - (type-specifier declared-ftype) - (type-specifier defined-ftype))))) - (:defined - (when global-p - (setf (info :function :type name) defined-ftype))))))) + (type-specifier declared-ftype) + (type-specifier defined-ftype))))) + (:defined + (when global-p + (setf (info :function :type source-name) defined-ftype)))))))) (values)) ;;; Find all calls in COMPONENT to assumed functions and update the diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 63c475e..c7b26e3 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -687,8 +687,8 @@ ;; cross-compiler doesn't know how to evaluate it. #+sb-xc-host (let* ((ref (continuation-use (combination-fun node))) - (fun (leaf-name (ref-leaf ref)))) - (fboundp fun))) + (fun-name (leaf-source-name (ref-leaf ref)))) + (fboundp fun-name))) (constant-fold-call node) (return-from ir1-optimize-combination))) @@ -800,6 +800,10 @@ (:inline t) (:no-chance nil) ((nil :maybe-inline) (policy call (zerop space)))) + ;; FIXME: In sbcl-0.pre7.87, it looks as though we'll + ;; get here when LEAF is a GLOBAL-VAR (not a DEFINED-FUN) + ;; whenever (ZEROP SPACE), in which case we'll die with + ;; a type error when we try to access LEAF as a DEFINED-FUN. (defined-fun-inline-expansion leaf) (let ((fun (defined-fun-functional leaf))) (or (not fun) @@ -821,10 +825,10 @@ (values (ref-leaf (continuation-use (basic-combination-fun call))) nil)) (t - (let* ((name (leaf-name leaf)) + (let* ((name (leaf-source-name leaf)) (info (info :function :info (if (slot-accessor-p leaf) - (if (consp name) + (if (consp source-name) ; i.e. if SETF function '%slot-setter '%slot-accessor) name)))) @@ -875,7 +879,7 @@ (values nil nil)))) ;;; This is called by IR1-OPTIMIZE when the function for a call has -;;; changed. If the call is local, we try to let-convert it, and +;;; changed. If the call is local, we try to LET-convert it, and ;;; derive the result type. If it is a :FULL call, we validate it ;;; against the type, which recognizes known calls, does inline ;;; expansion, etc. If a call to a predicate in a non-conditional @@ -900,19 +904,30 @@ (continuation-use (basic-combination-fun call)) call)) ((not leaf)) - ((or (info :function :source-transform (leaf-name leaf)) + ((or (info :function :source-transform (leaf-source-name leaf)) (and info (ir1-attributep (function-info-attributes info) predicate) (let ((dest (continuation-dest (node-cont call)))) (and dest (not (if-p dest)))))) - (let ((name (leaf-name leaf))) - (when (symbolp name) - (let ((dums (make-gensym-list (length - (combination-args call))))) - (transform-call call - `(lambda ,dums - (,name ,@dums)))))))))))) + (when (and (leaf-has-source-name-p leaf) + ;; FIXME: This SYMBOLP is part of a literal + ;; translation of a test in the old CMU CL + ;; source, and it's not quite clear what + ;; the old source meant. Did it mean "has a + ;; valid name"? Or did it mean "is an + ;; ordinary function name, not a SETF + ;; function"? Either way, the old CMU CL + ;; code probably didn't deal with SETF + ;; functions correctly, and neither does + ;; this new SBCL code, and that should be fixed. + (symbolp (leaf-source-name leaf))) + (let ((dummies (make-gensym-list (length + (combination-args call))))) + (transform-call call + `(lambda ,dummies + (,(leaf-source-name leaf) + ,@dummies))))))))))) (values)) ;;;; known function optimization @@ -1069,7 +1084,9 @@ (defun transform-call (node res) (declare (type combination node) (list res)) (with-ir1-environment node - (let ((new-fun (ir1-convert-inline-lambda res)) + (let ((new-fun (ir1-convert-inline-lambda + res + :debug-name "")) (ref (continuation-use (combination-fun node)))) (change-ref-leaf ref new-fun) (setf (combination-kind node) :full) @@ -1079,7 +1096,7 @@ ;;; Replace a call to a foldable function of constant arguments with ;;; the result of evaluating the form. We insert the resulting ;;; constant node after the call, stealing the call's continuation. We -;;; give the call a continuation with no Dest, which should cause it +;;; give the call a continuation with no DEST, which should cause it ;;; and its arguments to go away. If there is an error during the ;;; evaluation, we give a warning and leave the call alone, making the ;;; call a :ERROR call. @@ -1090,10 +1107,10 @@ (declare (type combination call)) (let* ((args (mapcar #'continuation-value (combination-args call))) (ref (continuation-use (combination-fun call))) - (fun (leaf-name (ref-leaf ref)))) + (fun-name (leaf-source-name (ref-leaf ref)))) (multiple-value-bind (values win) - (careful-call fun args call "constant folding") + (careful-call fun-name args call "constant folding") (if (not win) (setf (combination-kind call) :error) (let ((dummies (make-gensym-list (length args)))) diff --git a/src/compiler/ir1report.lisp b/src/compiler/ir1report.lisp index 93190eb..e40948d 100644 --- a/src/compiler/ir1report.lisp +++ b/src/compiler/ir1report.lisp @@ -178,13 +178,31 @@ ;;; Convert a source form to a string, suitably formatted for use in ;;; compiler warnings. (defun stringify-form (form &optional (pretty t)) - (let ((*print-level* *compiler-error-print-level*) - (*print-length* *compiler-error-print-length*) - (*print-lines* *compiler-error-print-lines*) - (*print-pretty* pretty)) - (if pretty - (format nil "~<~@; ~S~:>" (list form)) - (prin1-to-string form)))) + (with-standard-io-syntax + (let ((*print-readably* nil) + (*print-pretty* pretty) + (*print-level* *compiler-error-print-level*) + (*print-length* *compiler-error-print-length*) + (*print-lines* *compiler-error-print-lines*)) + (if pretty + (format nil "~<~@; ~S~:>" (list form)) + (prin1-to-string form))))) + +;;; shorthand for creating debug names from source names or other +;;; stems, e.g. +;;; (DEBUG-NAMIFY "FLET ~S" SOURCE-NAME) +;;; (DEBUG-NAMIFY "top level form ~S" FORM) +;;; +;;; FIXME: This function seems to have a lot in common with +;;; STRINGIFY-FORM, and perhaps there's some way to merge the two +;;; functions. +(defun debug-namify (format-string &rest format-arguments) + (with-standard-io-syntax + (let ((*print-readably* nil) + (*package* *cl-package*) + (*print-length* 3) + (*print-level* 2)) + (apply #'format nil format-string format-arguments)))) ;;; Return a COMPILER-ERROR-CONTEXT structure describing the current ;;; error context, or NIL if we can't figure anything out. ARGS is a diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index abe4d20..5b025c6 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -68,7 +68,7 @@ #-sb-xc-host (not (fboundp name))) (note-undefined-reference name :function)) (make-global-var :kind :global-function - :name name + :%source-name name :type (if (or *derive-function-types* (eq where :declared)) (info :function :type name) @@ -90,7 +90,7 @@ (unless slot (error "can't find slot ~S" type)) (make-slot-accessor - :name name + :%source-name name :type (specifier-type (if (listp name) `(function (,slot-type ,type) ,slot-type) @@ -124,7 +124,7 @@ (setf (gethash name *free-functions*) (if (or expansion inlinep) (make-defined-fun - :name name + :%source-name name :inline-expansion expansion :inlinep inlinep :where-from (info :function :where-from name) @@ -167,12 +167,12 @@ (:constant (let ((value (info :variable :constant-value name))) (make-constant :value value - :name name + :%source-name name :type (ctype-of value) :where-from where-from))) (t (make-global-var :kind kind - :name name + :%source-name name :type type :where-from where-from))))))) @@ -343,11 +343,12 @@ (setf (component-name component) "initial component") (setf (component-kind component) :initial) (let* ((forms (if for-value `(,form) `(,form nil))) - (res (ir1-convert-lambda-body forms ()))) - (setf (leaf-name res) "top level form") ; FIXME: would be nice to have form index in name here, or some other info to aid in BACKTRACE - (setf (functional-entry-function res) res) - (setf (functional-arg-documentation res) ()) - (setf (functional-kind res) :toplevel) + (res (ir1-convert-lambda-body + forms () + :debug-name (debug-namify "top level form ~S" form)))) + (setf (functional-entry-function res) res + (functional-arg-documentation res) () + (functional-kind res) :toplevel) res))) ;;; *CURRENT-FORM-NUMBER* is used in FIND-SOURCE-PATHS to compute the @@ -435,32 +436,37 @@ (reference-leaf start cont form)) (t (reference-constant start cont form))) - (let ((fun (car form))) - (cond - ((symbolp fun) - (let ((lexical-def (lexenv-find fun functions))) - (typecase lexical-def - (null (ir1-convert-global-functoid start cont form)) - (functional - (ir1-convert-local-combination start - cont - form - lexical-def)) - (global-var - (ir1-convert-srctran start cont lexical-def form)) + (let ((opname (car form))) + (cond ((symbolp opname) + (let ((lexical-def (lexenv-find opname functions))) + (typecase lexical-def + (null (ir1-convert-global-functoid start cont form)) + (functional + (ir1-convert-local-combination start + cont + form + lexical-def)) + (global-var + (ir1-convert-srctran start cont lexical-def form)) + (t + (aver (and (consp lexical-def) + (eq (car lexical-def) 'macro))) + (ir1-convert start cont + (careful-expand-macro (cdr lexical-def) + form)))))) + ((or (atom opname) (not (eq (car opname) 'lambda))) + (compiler-error "illegal function call")) (t - (aver (and (consp lexical-def) - (eq (car lexical-def) 'macro))) - (ir1-convert start cont - (careful-expand-macro (cdr lexical-def) - form)))))) - ((or (atom fun) (not (eq (car fun) 'lambda))) - (compiler-error "illegal function call")) - (t - (ir1-convert-combination start - cont - form - (ir1-convert-lambda fun)))))))) + ;; implicitly #'(LAMBDA ..) because the LAMBDA + ;; expression is the CAR of an executed form + (ir1-convert-combination start + cont + form + (ir1-convert-lambda + opname + :debug-name (debug-namify + "LAMBDA CAR ~S" + opname))))))))) (values)) ;; Generate a reference to a manifest constant, creating a new leaf @@ -471,8 +477,7 @@ (declare (type continuation start cont) (inline find-constant)) (ir1-error-bailout - (start cont value - '(error "attempt to reference undumpable constant")) + (start cont value '(error "attempt to reference undumpable constant")) (when (producing-fasl-file) (maybe-emit-make-load-forms value)) (let* ((leaf (find-constant value)) @@ -482,7 +487,7 @@ (use-continuation res cont))) (values))) -;;; Add Fun to the COMPONENT-REANALYZE-FUNCTIONS. Fun is returned. +;;; Add FUN to the COMPONENT-REANALYZE-FUNCTIONS. FUN is returned. (defun maybe-reanalyze-function (fun) (declare (type functional fun)) (when (typep fun '(or optional-dispatch clambda)) @@ -673,8 +678,9 @@ ;;;; converting combinations -;;; Convert a function call where the function (Fun) is a Leaf. We -;;; return the Combination node so that we can poke at it if we want to. +;;; Convert a function call where the function (i.e. the FUN argument) +;;; is a LEAF. We return the COMBINATION node so that we can poke at +;;; it if we want to. (declaim (ftype (function (continuation continuation list leaf) combination) ir1-convert-combination)) (defun ir1-convert-combination (start cont form fun) @@ -682,10 +688,11 @@ (reference-leaf start fun-cont fun) (ir1-convert-combination-args fun-cont cont (cdr form)))) -;;; Convert the arguments to a call and make the Combination node. Fun-Cont -;;; is the continuation which yields the function to call. Form is the source -;;; for the call. Args is the list of arguments for the call, which defaults -;;; to the cdr of source. We return the Combination node. +;;; Convert the arguments to a call and make the COMBINATION node. +;;; FUN-CONT is the continuation which yields the function to call. +;;; FORM is the source for the call. ARGS is the list of arguments for +;;; the call, which defaults to the cdr of source. We return the +;;; COMBINATION node. (defun ir1-convert-combination-args (fun-cont cont args) (declare (type continuation fun-cont cont) (list args)) (let ((node (make-combination fun-cont))) @@ -715,7 +722,9 @@ (defined-fun-inlinep var)))) (if (eq inlinep :notinline) (ir1-convert-combination start cont form var) - (let ((transform (info :function :source-transform (leaf-name var)))) + (let ((transform (info :function + :source-transform + (leaf-source-name var)))) (if transform (multiple-value-bind (result pass) (funcall transform form) (if pass @@ -731,7 +740,7 @@ ;;; IR1-CONVERT-COMBINATION-CHECKING-TYPE. (defun ir1-convert-maybe-predicate (start cont form var) (declare (type continuation start cont) (list form) (type global-var var)) - (let ((info (info :function :info (leaf-name var)))) + (let ((info (info :function :info (leaf-source-name var)))) (if (and info (ir1-attributep (function-info-attributes info) predicate) (not (if-p (continuation-dest cont)))) @@ -761,7 +770,6 @@ (setf (continuation-%derived-type fun-cont) type) (setf (continuation-reoptimize fun-cont) nil) (setf (continuation-%type-check fun-cont) nil))) - (values)) ;;; Convert a call to a local function. If the function has already @@ -776,9 +784,9 @@ ;;;; PROCESS-DECLS -;;; Given a list of Lambda-Var structures and a variable name, return -;;; the structure for that name, or NIL if it isn't found. We return -;;; the *last* variable with that name, since LET* bindings may be +;;; Given a list of LAMBDA-VARs and a variable name, return the +;;; LAMBDA-VAR for that name, or NIL if it isn't found. We return the +;;; *last* variable with that name, since LET* bindings may be ;;; duplicated, and declarations always apply to the last. (declaim (ftype (function (list symbol) (or lambda-var list)) find-in-bindings)) @@ -786,13 +794,13 @@ (let ((found nil)) (dolist (var vars) (cond ((leaf-p var) - (when (eq (leaf-name var) name) + (when (eq (leaf-source-name var) name) (setq found var)) (let ((info (lambda-var-arg-info var))) (when info (let ((supplied-p (arg-info-supplied-p info))) (when (and supplied-p - (eq (leaf-name supplied-p) name)) + (eq (leaf-source-name supplied-p) name)) (setq found supplied-p)))))) ((and (consp var) (eq (car var) name)) (setf found (cdr var))))) @@ -855,7 +863,9 @@ (let ((type (specifier-type spec))) (collect ((res nil cons)) (dolist (name names) - (let ((found (find name fvars :key #'leaf-name :test #'equal))) + (let ((found (find name fvars + :key #'leaf-source-name + :test #'equal))) (cond (found (setf (leaf-type found) type) @@ -904,7 +914,7 @@ (defun make-new-inlinep (var inlinep) (declare (type global-var var) (type inlinep inlinep)) (let ((res (make-defined-fun - :name (leaf-name var) + :%source-name (leaf-source-name var) :where-from (leaf-where-from var) :type (leaf-type var) :inlinep inlinep))) @@ -921,7 +931,9 @@ (let ((sense (cdr (assoc (first spec) *inlinep-translations* :test #'eq))) (new-fenv ())) (dolist (name (rest spec)) - (let ((fvar (find name fvars :key #'leaf-name :test #'equal))) + (let ((fvar (find name fvars + :key #'leaf-source-name + :test #'equal))) (if fvar (setf (functional-inlinep fvar) sense) (let ((found @@ -949,7 +961,7 @@ (unless (eq wot 'function) (compiler-error "The function or variable name ~S is unrecognizable." name)) - (find fn-name fvars :key #'leaf-name :test #'equal)) + (find fn-name fvars :key #'leaf-source-name :test #'equal)) (find-in-bindings vars name))) ;;; Process an ignore/ignorable declaration, checking for various losing @@ -1069,7 +1081,7 @@ found)) (t (make-global-var :kind :special - :name name + :%source-name name :where-from :declared)))) ;;;; LAMBDA hackery @@ -1097,13 +1109,13 @@ name)) (cond ((eq kind :special) (let ((specvar (find-free-variable name))) - (make-lambda-var :name name + (make-lambda-var :%source-name name :type (leaf-type specvar) :where-from (leaf-where-from specvar) :specvar specvar))) (t (note-lexical-binding name) - (make-lambda-var :name name))))) + (make-lambda-var :%source-name name))))) ;;; Make the default keyword for a &KEY arg, checking that the keyword ;;; isn't already used by one of the VARS. We also check that the @@ -1267,7 +1279,10 @@ (fun (ir1-convert-lambda-body body (list (first aux-vars)) :aux-vars (rest aux-vars) - :aux-vals (rest aux-vals)))) + :aux-vals (rest aux-vals) + :debug-name (debug-namify + "&AUX bindings ~S" + aux-vars)))) (reference-leaf start fun-cont fun) (ir1-convert-combination-args fun-cont cont (list (first aux-vals))))) @@ -1322,12 +1337,31 @@ ;;; AUX-VARS is a list of VAR structures for variables that are to be ;;; sequentially bound. Each AUX-VAL is a form that is to be evaluated ;;; to get the initial value for the corresponding AUX-VAR. -(defun ir1-convert-lambda-body (body vars &key aux-vars aux-vals result) +(defun ir1-convert-lambda-body (body + vars + &key + aux-vars + aux-vals + result + (source-name '.anonymous.) + debug-name) (declare (list body vars aux-vars aux-vals) (type (or continuation null) result)) (let* ((bind (make-bind)) - (lambda (make-lambda :vars vars :bind bind)) + (lambda (make-lambda :vars vars + :bind bind + :%source-name source-name + :%debug-name debug-name)) (result (or result (make-continuation)))) + + ;; This function should fail internal assertions if we didn't set + ;; up a valid debug name above. + ;; + ;; (In SBCL we try to make everything have a debug name, since we + ;; lack the omniscient perspective the original implementors used + ;; to decide which things didn't need one.) + (functional-debug-name lambda) + (setf (lambda-home lambda) lambda) (collect ((svars) (new-venv nil cons)) @@ -1340,10 +1374,10 @@ (let ((specvar (lambda-var-specvar var))) (cond (specvar (svars var) - (new-venv (cons (leaf-name specvar) specvar))) + (new-venv (cons (leaf-source-name specvar) specvar))) (t - (note-lexical-binding (leaf-name var)) - (new-venv (cons (leaf-name var) var)))))) + (note-lexical-binding (leaf-source-name var)) + (new-venv (cons (leaf-source-name var) var)))))) (let ((*lexenv* (make-lexenv :variables (new-venv) :lambda lambda @@ -1390,18 +1424,18 @@ (let* ((fvars (reverse vars)) (arg-vars (mapcar (lambda (var) (unless (lambda-var-specvar var) - (note-lexical-binding (leaf-name var))) + (note-lexical-binding (leaf-source-name var))) (make-lambda-var - :name (leaf-name var) + :%source-name (leaf-source-name var) :type (leaf-type var) :where-from (leaf-where-from var) :specvar (lambda-var-specvar var))) fvars)) - (fun - (ir1-convert-lambda-body `((%funcall ,fun - ,@(reverse vals) - ,@defaults)) - arg-vars))) + (fun (ir1-convert-lambda-body `((%funcall ,fun + ,@(reverse vals) + ,@defaults)) + arg-vars + :debug-name "&OPTIONAL processor"))) (mapc (lambda (var arg-var) (when (cdr (leaf-refs arg-var)) (setf (leaf-ever-used var) t))) @@ -1423,14 +1457,14 @@ aux-vars aux-vals) (type (or continuation null) cont)) (let* ((arg (first vars)) - (arg-name (leaf-name arg)) + (arg-name (leaf-source-name arg)) (info (lambda-var-arg-info arg)) (supplied-p (arg-info-supplied-p info)) (ep (if supplied-p (ir1-convert-hairy-args res (list* supplied-p arg default-vars) - (list* (leaf-name supplied-p) arg-name default-vals) + (list* (leaf-source-name supplied-p) arg-name default-vals) (cons arg entry-vars) (list* t arg-name entry-vals) (rest vars) t body aux-vars aux-vals cont) @@ -1479,14 +1513,14 @@ (body)) (dolist (var (reverse entry-vars)) - (arg-vars (make-lambda-var :name (leaf-name var) + (arg-vars (make-lambda-var :%source-name (leaf-source-name var) :type (leaf-type var) :where-from (leaf-where-from var)))) (let* ((n-context (gensym "N-CONTEXT-")) - (context-temp (make-lambda-var :name n-context)) + (context-temp (make-lambda-var :%source-name n-context)) (n-count (gensym "N-COUNT-")) - (count-temp (make-lambda-var :name n-count + (count-temp (make-lambda-var :%source-name n-count :type (specifier-type 'index)))) (arg-vars context-temp count-temp) @@ -1560,7 +1594,8 @@ ,@(body) (%funcall ,(optional-dispatch-main-entry res) . ,(arg-vals)))) ; FIXME: What is the '.'? ,@? - (arg-vars)))) + (arg-vars) + :debug-name (debug-namify "~S processing" '&more)))) (setf (optional-dispatch-more-entry res) ep)))) (values)) @@ -1609,10 +1644,10 @@ (supplied-p (arg-info-supplied-p info)) (n-val (make-symbol (format nil "~A-DEFAULTING-TEMP" - (leaf-name key)))) + (leaf-source-name key)))) (key-type (leaf-type key)) (val-temp (make-lambda-var - :name n-val + :%source-name n-val :type (if hairy-default (type-union key-type (specifier-type 'null)) key-type)))) @@ -1620,7 +1655,8 @@ (bind-vars key) (cond ((or hairy-default supplied-p) (let* ((n-supplied (gensym "N-SUPPLIED-")) - (supplied-temp (make-lambda-var :name n-supplied))) + (supplied-temp (make-lambda-var + :%source-name n-supplied))) (unless supplied-p (setf (arg-info-supplied-p info) supplied-temp)) (when hairy-default @@ -1643,7 +1679,8 @@ body (main-vars) :aux-vars (append (bind-vars) aux-vars) :aux-vals (append (bind-vals) aux-vals) - :result cont)) + :result cont + :debug-name (debug-namify "~S processor" '&more))) (last-entry (convert-optional-entry main-entry default-vars (main-vals) ()))) (setf (optional-dispatch-main-entry res) main-entry) @@ -1688,77 +1725,86 @@ ;;; When we run into a &REST or &KEY arg, we punt out to ;;; IR1-CONVERT-MORE, which finishes for us in this case. (defun ir1-convert-hairy-args (res default-vars default-vals - entry-vars entry-vals - vars supplied-p-p body aux-vars - aux-vals cont) + entry-vars entry-vals + vars supplied-p-p body aux-vars + aux-vals cont) (declare (type optional-dispatch res) - (list default-vars default-vals entry-vars entry-vals vars body - aux-vars aux-vals) - (type (or continuation null) cont)) + (list default-vars default-vals entry-vars entry-vals vars body + aux-vars aux-vals) + (type (or continuation null) cont)) (cond ((not vars) - (if (optional-dispatch-keyp res) - ;; Handle &KEY with no keys... - (ir1-convert-more res default-vars default-vals - entry-vars entry-vals - nil nil nil vars supplied-p-p body aux-vars - aux-vals cont) - (let ((fun (ir1-convert-lambda-body body (reverse default-vars) - :aux-vars aux-vars - :aux-vals aux-vals - :result cont))) - (setf (optional-dispatch-main-entry res) fun) - (push (if supplied-p-p - (convert-optional-entry fun entry-vars entry-vals ()) - fun) - (optional-dispatch-entry-points res)) - fun))) - ((not (lambda-var-arg-info (first vars))) - (let* ((arg (first vars)) - (nvars (cons arg default-vars)) - (nvals (cons (leaf-name arg) default-vals))) - (ir1-convert-hairy-args res nvars nvals nvars nvals - (rest vars) nil body aux-vars aux-vals - cont))) - (t - (let* ((arg (first vars)) - (info (lambda-var-arg-info arg)) - (kind (arg-info-kind info))) - (ecase kind - (:optional - (let ((ep (generate-optional-default-entry - res default-vars default-vals - entry-vars entry-vals vars supplied-p-p body - aux-vars aux-vals cont))) - (push (if supplied-p-p - (convert-optional-entry ep entry-vars entry-vals ()) - ep) - (optional-dispatch-entry-points res)) - ep)) - (:rest - (ir1-convert-more res default-vars default-vals - entry-vars entry-vals - arg nil nil (rest vars) supplied-p-p body - aux-vars aux-vals cont)) - (:more-context - (ir1-convert-more res default-vars default-vals - entry-vars entry-vals - nil arg (second vars) (cddr vars) supplied-p-p - body aux-vars aux-vals cont)) - (:keyword - (ir1-convert-more res default-vars default-vals - entry-vars entry-vals - nil nil nil vars supplied-p-p body aux-vars - aux-vals cont))))))) + (if (optional-dispatch-keyp res) + ;; Handle &KEY with no keys... + (ir1-convert-more res default-vars default-vals + entry-vars entry-vals + nil nil nil vars supplied-p-p body aux-vars + aux-vals cont) + (let ((fun (ir1-convert-lambda-body + body (reverse default-vars) + :aux-vars aux-vars + :aux-vals aux-vals + :result cont + :debug-name "hairy arg processor"))) + (setf (optional-dispatch-main-entry res) fun) + (push (if supplied-p-p + (convert-optional-entry fun entry-vars entry-vals ()) + fun) + (optional-dispatch-entry-points res)) + fun))) + ((not (lambda-var-arg-info (first vars))) + (let* ((arg (first vars)) + (nvars (cons arg default-vars)) + (nvals (cons (leaf-source-name arg) default-vals))) + (ir1-convert-hairy-args res nvars nvals nvars nvals + (rest vars) nil body aux-vars aux-vals + cont))) + (t + (let* ((arg (first vars)) + (info (lambda-var-arg-info arg)) + (kind (arg-info-kind info))) + (ecase kind + (:optional + (let ((ep (generate-optional-default-entry + res default-vars default-vals + entry-vars entry-vals vars supplied-p-p body + aux-vars aux-vals cont))) + (push (if supplied-p-p + (convert-optional-entry ep entry-vars entry-vals ()) + ep) + (optional-dispatch-entry-points res)) + ep)) + (:rest + (ir1-convert-more res default-vars default-vals + entry-vars entry-vals + arg nil nil (rest vars) supplied-p-p body + aux-vars aux-vals cont)) + (:more-context + (ir1-convert-more res default-vars default-vals + entry-vars entry-vals + nil arg (second vars) (cddr vars) supplied-p-p + body aux-vars aux-vals cont)) + (:keyword + (ir1-convert-more res default-vars default-vals + entry-vars entry-vals + nil nil nil vars supplied-p-p body aux-vars + aux-vals cont))))))) ;;; This function deals with the case where we have to make an ;;; OPTIONAL-DISPATCH to represent a LAMBDA. We cons up the result and ;;; 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 cont) +(defun ir1-convert-hairy-lambda (body vars keyp allowp aux-vars aux-vals cont + &key + (source-name '.anonymous.) + (debug-name (debug-namify + "OPTIONAL-DISPATCH ~S" + vars))) (declare (list body vars aux-vars aux-vals) (type continuation cont)) (let ((res (make-optional-dispatch :arglist vars :allowp allowp - :keyp keyp)) + :keyp keyp + :%source-name source-name + :%debug-name debug-name)) (min (or (position-if #'lambda-var-arg-info vars) (length vars)))) (push res (component-new-functions *current-component*)) (ir1-convert-hairy-args res () () () () vars nil body aux-vars aux-vals @@ -1779,7 +1825,7 @@ res)) ;;; Convert a LAMBDA form into a LAMBDA leaf or an OPTIONAL-DISPATCH leaf. -(defun ir1-convert-lambda (form &optional name) +(defun ir1-convert-lambda (form &key (source-name '.anonymous.) debug-name) (unless (consp form) (compiler-error "A ~S was found when expecting a lambda expression:~% ~S" (type-of form) @@ -1804,14 +1850,17 @@ (res (if (or (find-if #'lambda-var-arg-info vars) keyp) (ir1-convert-hairy-lambda forms vars keyp allow-other-keys - aux-vars aux-vals cont) + aux-vars aux-vals cont + :source-name source-name + :debug-name debug-name) (ir1-convert-lambda-body forms vars :aux-vars aux-vars :aux-vals aux-vals - :result cont)))) + :result cont + :source-name source-name + :debug-name debug-name)))) (setf (functional-inline-expansion res) form) (setf (functional-arg-documentation res) (cadr form)) - (setf (leaf-name res) name) res)))) ;;;; defining global functions @@ -1820,7 +1869,9 @@ ;;; current compilation policy. Note that FUN may be a ;;; LAMBDA-WITH-LEXENV, so we may have to augment the environment to ;;; reflect the state at the definition site. -(defun ir1-convert-inline-lambda (fun &optional name) +(defun ir1-convert-inline-lambda (fun &key + (source-name '.anonymous.) + debug-name) (destructuring-bind (decls macros symbol-macros &rest body) (if (eq (car fun) 'lambda-with-lexenv) (cdr fun) @@ -1836,7 +1887,9 @@ (macro . ,(coerce (cdr x) 'function)))) macros) :policy (lexenv-policy *lexenv*)))) - (ir1-convert-lambda `(lambda ,@body) name)))) + (ir1-convert-lambda `(lambda ,@body) + :source-name source-name + :debug-name debug-name)))) ;;; Get a DEFINED-FUN object for a function we are about to ;;; define. If the function has been forward referenced, then @@ -1849,7 +1902,7 @@ (aver (not (info :function :inlinep name))) (let* ((where-from (leaf-where-from found)) (res (make-defined-fun - :name name + :%source-name name :where-from (if (eq where-from :declared) :declared :defined) :type (leaf-type found)))) @@ -1871,7 +1924,7 @@ (defun assert-new-definition (var fun) (let ((type (leaf-type var)) (for-real (eq (leaf-where-from var) :declared)) - (info (info :function :info (leaf-name var)))) + (info (info :function :info (leaf-source-name var)))) (assert-definition-type fun type ;; KLUDGE: Common Lisp is such a dynamic language that in general @@ -1909,8 +1962,8 @@ (let ((var-expansion (defined-fun-inline-expansion var))) (unless (eq (defined-fun-inlinep var) :inline) (setf (defined-fun-inline-expansion var) nil)) - (let* ((name (leaf-name var)) - (fun (funcall converter lambda name)) + (let* ((name (leaf-source-name var)) + (fun (funcall converter lambda :source-name name)) (function-info (info :function :info name))) (setf (functional-inlinep fun) (defined-fun-inlinep var)) (assert-new-definition var fun) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index cffa2e6..4c5d3a3 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -603,7 +603,7 @@ (unless (leaf-ever-used leaf) (let ((*compiler-error-context* bind)) (compiler-note "deleting unused function~:[.~;~:*~% ~S~]" - (leaf-name leaf)))) + (leaf-debug-name leaf)))) (unlink-blocks (component-head component) bind-block) (when return (unlink-blocks (node-block return) (component-tail component))) @@ -884,7 +884,7 @@ ;; ANSI section "3.2.5 Exceptional Situations in the Compiler" ;; requires this to be a STYLE-WARNING. (compiler-style-warning "The variable ~S is defined but never used." - (leaf-name var))) + (leaf-debug-name var))) (setf (leaf-ever-used var) t)))) (values)) @@ -1111,7 +1111,7 @@ ;;;; leaf hackery -;;; Change the Leaf that a Ref refers to. +;;; Change the LEAF that a REF refers to. (defun change-ref-leaf (ref leaf) (declare (type ref ref) (type leaf leaf)) (unless (eq (ref-leaf ref) leaf) @@ -1144,19 +1144,21 @@ ;;; Return a LEAF which represents the specified constant object. If ;;; the object is not in *CONSTANTS*, then we create a new constant ;;; LEAF and enter it. -#!-sb-fluid (declaim (maybe-inline find-constant)) (defun find-constant (object) - (if (typep object '(or symbol number character instance)) - (or (gethash object *constants*) - (setf (gethash object *constants*) - (make-constant :value object - :name nil - :type (ctype-of object) - :where-from :defined))) - (make-constant :value object - :name nil - :type (ctype-of object) - :where-from :defined))) + (if (typep object + ;; FIXME: What is the significance of this test? ("things + ;; that are worth uniquifying"?) + '(or symbol number character instance)) + (or (gethash object *constants*) + (setf (gethash object *constants*) + (make-constant :value object + :%source-name '.anonymous. + :type (ctype-of object) + :where-from :defined))) + (make-constant :value object + :%source-name '.anonymous. + :type (ctype-of object) + :where-from :defined))) ;;; If there is a non-local exit noted in ENTRY's environment that ;;; exits to CONT in that entry, then return it, otherwise return NIL. @@ -1216,7 +1218,7 @@ (or (not (defined-fun-p leaf)) (not (eq (defined-fun-inlinep leaf) :notinline)) notinline-ok)) - (leaf-name leaf) + (leaf-source-name leaf) nil)) nil))) diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index ca759f4..2ad7d66 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -109,7 +109,6 @@ (declare (type ref node) (type ir2-block block)) (let* ((cont (node-cont node)) (leaf (ref-leaf node)) - (name (leaf-name leaf)) (locs (continuation-result-tns cont (list (primitive-type (leaf-type leaf))))) (res (first locs))) @@ -122,14 +121,16 @@ (constant (if (legal-immediate-constant-p leaf) (emit-move node block (constant-tn leaf) res) - (let ((name-tn (emit-constant name))) + (let* ((name (leaf-source-name leaf)) + (name-tn (emit-constant name))) (if (policy node (zerop safety)) (vop fast-symbol-value node block name-tn res) (vop symbol-value node block name-tn res))))) (functional (ir2-convert-closure node block leaf res)) (global-var - (let ((unsafe (policy node (zerop safety)))) + (let ((unsafe (policy node (zerop safety))) + (name (leaf-source-name leaf))) (ecase (global-var-kind leaf) ((:special :global) (aver (symbolp name)) @@ -207,8 +208,8 @@ (global-var (ecase (global-var-kind leaf) ((:special :global) - (aver (symbolp (leaf-name leaf))) - (vop set node block (emit-constant (leaf-name leaf)) val))))) + (aver (symbolp (leaf-source-name leaf))) + (vop set node block (emit-constant (leaf-source-name leaf)) val))))) (when locs (emit-move node block val (first locs)) (move-continuation-result node block locs cont))) @@ -1261,7 +1262,7 @@ ;;; This is trivial, given our assumption of a shallow-binding ;;; implementation. (defoptimizer (%special-bind ir2-convert) ((var value) node block) - (let ((name (leaf-name (continuation-value var)))) + (let ((name (leaf-source-name (continuation-value var)))) (vop bind node block (continuation-tn node block value) (emit-constant name)))) (defoptimizer (%special-unbind ir2-convert) ((var) node block) @@ -1561,7 +1562,9 @@ (eq (basic-combination-kind last) :full)) (let* ((fun (basic-combination-fun last)) (use (continuation-use fun)) - (name (and (ref-p use) (leaf-name (ref-leaf use))))) + (name (and (ref-p use) + (leaf-has-source-name-p (ref-leaf use)) + (leaf-source-name (ref-leaf use))))) (unless (or (node-tail-p last) (info :function :info name) (policy last (zerop safety))) diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index 716afa1..54d944d 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -179,7 +179,10 @@ (declare (type functional fun)) (aver (not (functional-entry-function fun))) (with-ir1-environment (lambda-bind (main-entry fun)) - (let ((res (ir1-convert-lambda (make-xep-lambda fun)))) + (let ((res (ir1-convert-lambda (make-xep-lambda fun) + :debug-name (debug-namify + "XEP for ~A" + (leaf-debug-name fun))))) (setf (functional-kind res) :external (leaf-ever-used res) t (functional-entry-function res) fun @@ -313,7 +316,7 @@ (res (catch 'local-call-lossage (prog1 (ir1-convert-lambda (functional-inline-expansion - fun)) + :source-name fun)) (setq won t))))) (cond (won (change-ref-leaf ref res) @@ -321,9 +324,9 @@ (t (let ((*compiler-error-context* call)) (compiler-note "couldn't inline expand because expansion ~ - calls this let-converted local function:~ + calls this LET-converted local function:~ ~% ~S" - (leaf-name res))) + (leaf-debug-name res))) fun)))) fun)) @@ -448,7 +451,7 @@ call-args nargs) (setf (basic-combination-kind call) :error))))) -;;;; optional, more and keyword calls +;;;; &OPTIONAL, &MORE and &KEYWORD calls ;;; This is similar to CONVERT-LAMBDA-CALL, but deals with ;;; OPTIONAL-DISPATCHes. If only fixed args are supplied, then convert @@ -912,7 +915,7 @@ ;;; minimizes the likelyhood that we well let-convert a function which ;;; may have references added due to later local inline expansion (defun ok-initial-convert-p (fun) - (not (and (leaf-name fun) + (not (and (leaf-has-source-name-p fun) (eq (component-kind (block-component (node-block (lambda-bind fun)))) diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp index 2f06e0d..66d201d 100644 --- a/src/compiler/ltn.lisp +++ b/src/compiler/ltn.lisp @@ -78,7 +78,7 @@ ;;; values cannot, since we must preserve EQLness. (defun legal-immediate-constant-p (leaf) (declare (type constant leaf)) - (or (null (leaf-name leaf)) + (or (not (leaf-has-source-name-p leaf)) (typecase (constant-value leaf) ((or number character) t) (symbol (symbol-package (constant-value leaf))) @@ -895,14 +895,14 @@ ;; to implement an out-of-line version in terms of inline ;; transforms or VOPs or whatever. (unless template - (when (and (eq (continuation-fun-name (combination-fun call)) - (leaf-name - (physenv-function - (node-physenv call)))) - (let ((info (basic-combination-kind call))) - (not (or (function-info-ir2-convert info) - (ir1-attributep (function-info-attributes info) - recursive))))) + (when (let ((funleaf (physenv-function (node-physenv call)))) + (and (leaf-has-source-name-p funleaf) + (eq (continuation-fun-name (combination-fun call)) + (leaf-source-name funleaf)) + (let ((info (basic-combination-kind call))) + (not (or (function-info-ir2-convert info) + (ir1-attributep (function-info-attributes info) + recursive)))))) (let ((*compiler-error-context* call)) (compiler-warning "~@" diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index f560f9c..54c4073 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -124,23 +124,6 @@ ,@decls ,body)) (setf (info :function :source-transform ',name) #',fn-name))))) - -;;; Define a function that converts a use of (%PRIMITIVE NAME ..) -;;; into Lisp code. LAMBDA-LIST is a DEFMACRO-style lambda list. -(defmacro def-primitive-translator (name lambda-list &body body) - (let ((fn-name (symbolicate "PRIMITIVE-TRANSLATE-" name)) - (n-form (gensym)) - (n-env (gensym))) - (multiple-value-bind (body decls) - (parse-defmacro lambda-list n-form body name "%primitive" - :environment n-env - :error-fun 'convert-condition-into-compiler-error) - `(progn - (defun ,fn-name (,n-form) - (let ((,n-env *lexenv*)) - ,@decls - ,body)) - (setf (gethash ',name *primitive-translators*) ',fn-name))))) ;;;; boolean attribute utilities ;;;; diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 0d127ee..d17c7dc 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -860,9 +860,13 @@ (format nil "~S initial component" name)) (setf (component-kind component) :initial) (let* ((locall-fun (ir1-convert-lambda definition - (let ((*package* *keyword-package*)) - (format nil "locall ~S" name)))) - (fun (ir1-convert-lambda (make-xep-lambda locall-fun) name))) + :debug-name (debug-namify + "top level locall ~S" + name))) + (fun (ir1-convert-lambda (make-xep-lambda locall-fun) + :source-name (or name '.anonymous.) + :debug-name (or name "top level form")))) + (/show "in MAKE-FUNCTIONAL-FROM-TOP-LEVEL-LAMBDA" locall-fun fun component) (setf (functional-entry-function fun) locall-fun (functional-kind fun) :external (functional-has-external-references-p fun) t) @@ -888,12 +892,14 @@ ;; nice default for things where we don't have a ;; real source path (as in e.g. inside CL:COMPILE). '(original-source-start 0 0))) + (/show "entering %COMPILE" lambda-expression name) (unless (or (null name) (legal-fun-name-p name)) (error "not a legal function name: ~S" name)) (let* ((*lexenv* (make-lexenv :policy *policy*)) (fun (make-functional-from-toplevel-lambda lambda-expression :name name :path path))) + (/show fun) ;; FIXME: The compile-it code from here on is sort of a ;; twisted version of the code in COMPILE-TOPLEVEL. It'd be @@ -907,11 +913,13 @@ (multiple-value-bind (components-from-dfo top-components hairy-top) (find-initial-dfo (list fun)) + (/show components-from-dfo top-components hairy-top) (let ((*all-components* (append components-from-dfo top-components))) (mapc #'preallocate-physenvs-for-toplevelish-lambdas (append hairy-top top-components)) (dolist (component-from-dfo components-from-dfo) + (/show component-from-dfo (component-lambdas component-from-dfo)) (compile-component component-from-dfo) (replace-toplevel-xeps component-from-dfo))) @@ -926,7 +934,8 @@ (aver found-p) result)) (mapc #'clear-ir1-info components-from-dfo) - (clear-stuff))))) + (clear-stuff) + (/show "returning from %COMPILE"))))) (defun process-toplevel-cold-fset (name lambda-expression path) (unless (producing-fasl-file) @@ -1123,7 +1132,6 @@ (with-ir1-namespace (let* ((*lexenv* (make-null-lexenv)) (lambda (ir1-toplevel form *current-path* for-value))) - (setf (leaf-name lambda) name) (compile-toplevel (list lambda) t) lambda))) @@ -1137,7 +1145,7 @@ (let* ((lambda (car lambdas)) (component (block-component (node-block (lambda-bind lambda))))) (when (eql (component-kind component) :toplevel) - (setf (component-name component) (leaf-name lambda)) + (setf (component-name component) (leaf-debug-name lambda)) (compile-component component) (clear-ir1-info component)))) diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index 50c5598..ddde59e 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -582,17 +582,25 @@ ;;; hacking the flow graph. (def!struct (leaf (:make-load-form-fun ignore-it) (:constructor nil)) - ;; some name for this leaf. The exact significance of the name - ;; depends on what kind of leaf it is. In a LAMBDA-VAR or - ;; GLOBAL-VAR, this is the symbol name of the variable. In a - ;; functional that is from a DEFUN, this is the defined name. In - ;; other functionals, this is a descriptive string. + ;; (For public access to this slot, use LEAF-SOURCE-NAME.) ;; - ;; KLUDGE: Note that at least for LAMBDA-VARs, this is important not - ;; just for debugging but for ordinary compilation as well. In - ;; particular, in RECOGNIZE-KNOWN-CALL function calls are compiled - ;; differently based on the LEAF-NAME. - (name nil :type t) + ;; the name of LEAF as it appears in the source, e.g. 'FOO or '(SETF + ;; FOO) or 'N or '*Z*, or the special .ANONYMOUS. value if there's + ;; no name for this thing in the source (as can happen for + ;; FUNCTIONALs, e.g. for anonymous LAMBDAs or for functions for + ;; top-level forms; and can also happen for anonymous constants) or + ;; perhaps also if the match between the name and the thing is + ;; skewed enough (e.g. for macro functions or method functions) that + ;; we don't want to have that name affect compilation + ;; + ;; The value of this slot in can affect ordinary runtime behavior, + ;; e.g. of special variables and known functions, not just debugging. + ;; + ;; See also the LEAF-DEBUG-NAME function and the + ;; FUNCTIONAL-%DEBUG-NAME slot. + (%source-name (missing-arg) + :type (or symbol (and cons (satisfies legal-fun-name-p))) + :read-only t) ;; the type which values of this leaf must have (type *universal-type* :type ctype) ;; where the TYPE information came from: @@ -612,6 +620,28 @@ ;; some kind of info used by the back end (info nil)) +;;; LEAF name operations +;;; +;;; KLUDGE: wants CLOS.. +(defun leaf-has-source-name-p (leaf) + (not (eq (leaf-%source-name leaf) + '.anonymous.))) +(defun leaf-source-name (leaf) + (aver (leaf-has-source-name-p leaf)) + (leaf-%source-name leaf)) +(defun leaf-debug-name (leaf) + (if (functional-p leaf) + ;; FUNCTIONALs have additional %DEBUG-NAME behavior. + (functional-debug-name leaf) + ;; Other objects just use their source name. + ;; + ;; (As of sbcl-0.pre7.85, there are a few non-FUNCTIONAL + ;; anonymous objects, (anonymous constants..) and those would + ;; fail here if we ever tried to get debug names from them, but + ;; it looks as though it's never interesting to get debug names + ;; from them, so it's moot. -- WHN) + (leaf-source-name leaf))) + ;;; The CONSTANT structure is used to represent known constant values. ;;; If NAME is not null, then it is the name of the named constant ;;; which this leaf corresponds to, otherwise this is an anonymous @@ -620,12 +650,13 @@ ;; the value of the constant (value nil :type t)) (defprinter (constant :identity t) - (name :test name) + (%source-name :test %source-name) value) ;;; The BASIC-VAR structure represents information common to all ;;; variables which don't correspond to known local functions. -(def!struct (basic-var (:include leaf) (:constructor nil)) +(def!struct (basic-var (:include leaf) + (:constructor nil)) ;; Lists of the set nodes for this variable. (sets () :type list)) @@ -637,7 +668,7 @@ (kind (missing-arg) :type (member :special :global-function :global))) (defprinter (global-var :identity t) - name + %source-name (type :test (not (eq type *universal-type*))) (where-from :test (not (eq where-from :assumed))) kind) @@ -653,7 +684,7 @@ ;; The slot description of the slot. (slot (missing-arg))) (defprinter (slot-accessor :identity t) - name + %source-name for slot) @@ -675,7 +706,7 @@ ;; LET-converted. Null if we haven't converted the expansion yet. (functional nil :type (or functional null))) (defprinter (defined-fun :identity t) - name + %source-name inlinep (functional :test functional)) @@ -685,8 +716,50 @@ ;;; We don't normally manipulate function types for defined functions, ;;; but if someone wants to know, an approximation is there. (def!struct (functional (:include leaf + (%source-name '.anonymous.) (where-from :defined) (type (specifier-type 'function)))) + ;; (For public access to this slot, use LEAF-DEBUG-NAME.) + ;; + ;; the name of FUNCTIONAL for debugging purposes, or NIL if we + ;; should just let the SOURCE-NAME fall through + ;; + ;; Unlike the SOURCE-NAME slot, this slot's value should never + ;; affect ordinary code behavior, only debugging/diagnostic behavior. + ;; + ;; The value of this slot can be anything, except that it shouldn't + ;; be a legal function name, since otherwise debugging gets + ;; confusing. (If a legal function name is a good name for the + ;; function, it should be in %SOURCE-NAME, and then we shouldn't + ;; need a %DEBUG-NAME.) In SBCL as of 0.pre7.87, it's always a + ;; string unless it's NIL, since that's how CMU CL represented debug + ;; names. However, eventually I (WHN) think it we should start using + ;; list values instead, since they have much nicer print properties + ;; (abbreviation, skipping package prefixes when unneeded, and + ;; renaming package prefixes when we do things like renaming SB!EXT + ;; to SB-EXT). + ;; + ;; E.g. for the function which implements (DEFUN FOO ...), we could + ;; have + ;; %SOURCE-NAME=FOO + ;; %DEBUG-NAME=NIL + ;; for the function which implements the top level form + ;; (IN-PACKAGE :FOO) we could have + ;; %SOURCE-NAME=NIL + ;; %DEBUG-NAME="top level form (IN-PACKAGE :FOO)" + ;; for the function which implements FOO in + ;; (DEFUN BAR (...) (FLET ((FOO (...) ...)) ...)) + ;; we could have + ;; %SOURCE-NAME=FOO + ;; %DEBUG-NAME="FLET FOO in BAR" + ;; and for the function which implements FOO in + ;; (DEFMACRO FOO (...) ...) + ;; we could have + ;; %SOURCE-NAME=FOO (or maybe .ANONYMOUS.?) + ;; %DEBUG-NAME="DEFMACRO FOO" + (%debug-name nil + :type (or null (not (satisfies legal-fun-name-p))) + :read-only t) ;; some information about how this function is used. These values ;; are meaningful: ;; @@ -781,7 +854,23 @@ ;; various rare miscellaneous info that drives code generation & stuff (plist () :type list)) (defprinter (functional :identity t) - name) + %source-name + %debug-name) + +;;; FUNCTIONAL name operations +(defun functional-debug-name (functional) + ;; FUNCTIONAL-%DEBUG-NAME takes precedence over FUNCTIONAL-SOURCE-NAME + ;; here because we want different debug names for the functions in + ;; DEFUN FOO and FLET FOO even though they have the same source name. + (or (functional-%debug-name functional) + ;; Note that this will cause an error if the function is + ;; anonymous. In SBCL (as opposed to CMU CL) we make all + ;; FUNCTIONALs have debug names. The CMU CL code didn't bother + ;; in many FUNCTIONALs, especially those which were likely to be + ;; optimized away before the user saw them. However, getting + ;; that right requires a global understanding of the code, + ;; which seems bad, so we just require names for everything. + (leaf-source-name functional))) ;;; The CLAMBDA only deals with required lexical arguments. Special, ;;; optional, keyword and rest arguments are handled by transforming @@ -791,8 +880,8 @@ (:predicate lambda-p) (:constructor make-lambda) (:copier copy-lambda)) - ;; list of LAMBDA-VAR descriptors for args - (vars nil :type list) + ;; list of LAMBDA-VAR descriptors for arguments + (vars nil :type list :read-only t) ;; If this function was ever a :OPTIONAL function (an entry-point ;; for an OPTIONAL-DISPATCH), then this is that OPTIONAL-DISPATCH. ;; The optional dispatch will be :DELETED if this function is no @@ -846,10 +935,11 @@ ;; in effect. (call-lexenv nil :type (or lexenv null))) (defprinter (clambda :conc-name lambda- :identity t) - name + %source-name + %debug-name (type :test (not (eq type *universal-type*))) (where-from :test (not (eq where-from :assumed))) - (vars :prin1 (mapcar #'leaf-name vars))) + (vars :prin1 (mapcar #'leaf-source-name vars))) ;;; The OPTIONAL-DISPATCH leaf is used to represent hairy lambdas. It ;;; is a FUNCTIONAL, like LAMBDA. Each legal number of arguments has a @@ -905,7 +995,8 @@ ;; know what they are doing. (main-entry nil :type (or clambda null))) (defprinter (optional-dispatch :identity t) - name + %source-name + %debug-name (type :test (not (eq type *universal-type*))) (where-from :test (not (eq where-from :assumed))) arglist @@ -937,8 +1028,8 @@ ;; original Lisp code. This is set to NIL in &KEY arguments that are ;; defaulted using the SUPPLIED-P arg. (default nil :type t) - ;; the actual key for a &KEY argument. Note that in ANSI CL this is not - ;; necessarily a keyword: (DEFUN FOO (&KEY ((BAR BAR))) ..). + ;; the actual key for a &KEY argument. Note that in ANSI CL this is + ;; not necessarily a keyword: (DEFUN FOO (&KEY ((BAR BAR))) ...). (key nil :type symbol)) (defprinter (arg-info :identity t) (specialp :test specialp) @@ -982,7 +1073,7 @@ ;; good subject for flow analysis. (constraints nil :type (or sset null))) (defprinter (lambda-var :identity t) - name + %source-name (type :test (not (eq type *universal-type*))) (where-from :test (not (eq where-from :assumed))) (ignorep :test ignorep) diff --git a/src/compiler/physenvanal.lisp b/src/compiler/physenvanal.lisp index 99f9644..0d16dbf 100644 --- a/src/compiler/physenvanal.lisp +++ b/src/compiler/physenvanal.lisp @@ -97,9 +97,12 @@ ;;; mysterious reason here) it's important to set up bottomed-out-here ;;; environments before anything else. -- WHN 2001-09-30 (defun preallocate-physenvs-for-toplevelish-lambdas (component) + (/show "entering PREALLOCATE-PHYSENVS-FOR-TOPLEVELISH-LAMDBAS" component) (dolist (clambda (component-lambdas component)) + (/show clambda (lambda-vars clambda) (lambda-toplevelish-p clambda)) (when (lambda-toplevelish-p clambda) (compute-closure clambda))) + (/show "leaving PREALLOCATE-PHYSENVS-FOR-TOPLEVELISH-LAMDBAS" component) (values)) ;;; If CLAMBDA has a PHYSENV , return it, otherwise assign an empty one. @@ -131,17 +134,16 @@ (let ((old (lambda-physenv (lambda-home fun)))) (cond (old (setf (physenv-closure old) - (delete-if #'(lambda (x) - (and (lambda-var-p x) - (null (leaf-refs x)))) + (delete-if (lambda (x) + (and (lambda-var-p x) + (null (leaf-refs x)))) (physenv-closure old))) (flet ((clear (fun) (dolist (var (lambda-vars fun)) (unless (lambda-var-sets var) (setf (lambda-var-indirect var) nil))))) (clear fun) - (dolist (let (lambda-lets fun)) - (clear let)))) + (map nil #'clear (lambda-lets fun)))) (t (get-lambda-physenv fun)))) (values)) diff --git a/src/compiler/represent.lisp b/src/compiler/represent.lisp index 66fd31b..fb87aa5 100644 --- a/src/compiler/represent.lisp +++ b/src/compiler/represent.lisp @@ -336,7 +336,7 @@ (let* ((actual (if (eq (tn-kind tn) :alias) (tn-save-tn tn) tn)) (reads (tn-reads tn)) (leaf (tn-leaf actual))) - (cond ((lambda-var-p leaf) (leaf-name leaf)) + (cond ((lambda-var-p leaf) (leaf-source-name leaf)) ((and (not arg-p) reads (return-p (vop-node (tn-ref-vop reads)))) "") diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index dfc86a2..8282341 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -324,7 +324,8 @@ (let ((leaf (ref-leaf use))) (and (global-var-p leaf) (eq (global-var-kind leaf) :global-function) - (not (null (member (leaf-name leaf) names :test #'equal)))))))) + (not (null (member (leaf-source-name leaf) names + :test #'equal)))))))) ;;; If CONT is a constant continuation, the return the constant value. ;;; If it is null, then return default, otherwise quietly give up the diff --git a/src/compiler/target-main.lisp b/src/compiler/target-main.lisp index 14df897..f9b6c70 100644 --- a/src/compiler/target-main.lisp +++ b/src/compiler/target-main.lisp @@ -27,23 +27,6 @@ (error "can't find a definition for ~S" definition-designator)) definition))) -;;; Find the function that is being compiled by COMPILE and bash its -;;; name to NAME. We also substitute for any references to name so -;;; that recursive calls will be compiled direct. LAMBDA is the -;;; top level lambda for the compilation. A REF for the real function -;;; is the only thing in the top level lambda other than the bind and -;;; return, so it isn't too hard to find. -(defun compile-fix-fun-name (lambda name) - (declare (type clambda lambda) (type (or symbol cons) name)) - (when name - (let ((fun (ref-leaf - (continuation-next - (node-cont (lambda-bind lambda)))))) - (setf (leaf-name fun) name) - (let ((old (gethash name *free-functions*))) - (when old (substitute-leaf fun old))) - name))) - ;;; Handle the nontrivial case of CL:COMPILE. (defun actually-compile (name definition) (with-compilation-values diff --git a/src/compiler/tn.lisp b/src/compiler/tn.lisp index 3409a63..4132092 100644 --- a/src/compiler/tn.lisp +++ b/src/compiler/tn.lisp @@ -179,8 +179,8 @@ tn) ;;; Create a constant TN. The implementation dependent -;;; Immediate-Constant-SC function is used to determine whether the constant -;;; has an immediate representation. +;;; IMMEDIATE-CONSTANT-SC function is used to determine whether the +;;; constant has an immediate representation. (defun make-constant-tn (constant) (declare (type constant constant)) (let* ((component (component-info *component-being-compiled*)) @@ -218,9 +218,9 @@ (ir2-component-alias-tns component)) res)) -;;; Return a load-time constant TN with the specified Kind and Info. If the -;;; desired Constants entry already exists, then reuse it, otherwise allocate a -;;; new load-time constant slot. +;;; Return a load-time constant TN with the specified KIND and INFO. +;;; If the desired CONSTANTS entry already exists, then reuse it, +;;; otherwise allocate a anew load-time constant slot. (defun make-load-time-constant-tn (kind info) (declare (type keyword kind)) (let* ((component (component-info *component-being-compiled*)) diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp index 1a332aa..3abec13 100644 --- a/src/compiler/typetran.lisp +++ b/src/compiler/typetran.lisp @@ -87,7 +87,7 @@ ;;; whether the single argument is known to (not) be of the ;;; appropriate type, expanding to T or NIL as appropriate. (deftransform fold-type-predicate ((object) * * :node node :defun-only t) - (let ((ctype (gethash (leaf-name + (let ((ctype (gethash (leaf-source-name (ref-leaf (continuation-use (basic-combination-fun node)))) diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index 7e0b1be..609e8b0 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -438,9 +438,11 @@ And so, we are saved. (defun make-caching-dfun (generic-function &optional cache) (unless cache (when (use-constant-value-dfun-p generic-function) - (return-from make-caching-dfun (make-constant-value-dfun generic-function))) + (return-from make-caching-dfun + (make-constant-value-dfun generic-function))) (when (use-dispatch-dfun-p generic-function) - (return-from make-caching-dfun (make-dispatch-dfun generic-function)))) + (return-from make-caching-dfun + (make-dispatch-dfun generic-function)))) (multiple-value-bind (nreq applyp metatypes nkeys) (get-generic-function-info generic-function) (declare (ignore nreq)) diff --git a/version.lisp-expr b/version.lisp-expr index 6d9c720..4d47b96 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; for internal versions, especially for internal versions off the ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.pre7.86" +"0.pre7.86.flaky7" -- 1.7.10.4