;;; 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)
(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))
*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)
: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)
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*)
frame)))))
\f
;;; 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))))
(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)
(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"
;;; 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
(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)))))))
((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
"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))
(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))
;;; 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)))))
(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)
(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
(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))
(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))
(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)))
(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)))))
(: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))
(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
"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)))
(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
;;; 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))
(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
(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
(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)))))
(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*
(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))))))
\f
-;;;; 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 ...))
(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)))
(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)))
;;; 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 "~@<The previously declared FTYPE~2I ~_~S~I ~_~
+ (when (leaf-has-source-name-p leaf)
+ (let ((source-name (leaf-source-name leaf)))
+ (let* ((where (info :function :where-from source-name))
+ (*compiler-error-context* (lambda-bind (main-entry leaf)))
+ (global-def (gethash source-name *free-functions*))
+ (global-p (defined-fun-p global-def)))
+ (note-name-defined source-name :function)
+ (when global-p
+ (remhash source-name *free-functions*))
+ (ecase where
+ (:assumed
+ (let ((approx-type (info :function :assumed-type source-name)))
+ (when (and approx-type (fun-type-p defined-ftype))
+ (valid-approximate-type approx-type defined-ftype))
+ (setf (info :function :type source-name) defined-ftype)
+ (setf (info :function :assumed-type source-name) nil))
+ (setf (info :function :where-from source-name) :defined))
+ (:declared
+ (let ((declared-ftype (info :function :type source-name)))
+ (unless (defined-ftype-matches-declared-ftype-p
+ defined-ftype declared-ftype)
+ (note-lossage "~@<The previously declared FTYPE~2I ~_~S~I ~_~
conflicts with the definition type ~2I~_~S~:>"
- (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
;; 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)))
(: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)
(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))))
(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
(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))
\f
;;;; known function optimization
(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 "<something inlined in TRANSFORM-CALL>"))
(ref (continuation-use (combination-fun node))))
(change-ref-leaf ref new-fun)
(setf (combination-kind node) :full)
;;; 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.
(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))))
;;; 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
#-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)
(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)
(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)
(: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)))))))
\f
(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
(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
(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))
(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))
\f
;;;; 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)
(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)))
(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
;;; 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))))
(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
\f
;;;; 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))
(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)))))
(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)
(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)))
(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
(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
found))
(t
(make-global-var :kind :special
- :name name
+ :%source-name name
:where-from :declared))))
\f
;;;; LAMBDA hackery
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
(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)))))
;;; 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))
(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
(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)))
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)
(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)
,@(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))
(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))))
(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
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)
;;; 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
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)
(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))))
\f
;;;; defining global functions
;;; 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)
(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
(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))))
(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
(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)
(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)))
;; 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))
\f
;;;; 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)
;;; 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)))
\f
;;; 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.
(or (not (defined-fun-p leaf))
(not (eq (defined-fun-inlinep leaf) :notinline))
notinline-ok))
- (leaf-name leaf)
+ (leaf-source-name leaf)
nil))
nil)))
(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)))
(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))
(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)))
;;; 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)
(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)))
(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
(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)
(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))
call-args nargs)
(setf (basic-combination-kind call) :error)))))
\f
-;;;; 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
;;; 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))))
;;; 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)))
;; 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 "~@<recursion in known function definition~2I ~
~_policy=~S ~_arg types=~S~:>"
,@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)))))
\f
;;;; boolean attribute utilities
;;;;
(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)
;; 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
(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)))
(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)
(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)))
(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))))
\f
;;; 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:
;; 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
;; 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))
(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)
;; The slot description of the slot.
(slot (missing-arg)))
(defprinter (slot-accessor :identity t)
- name
+ %source-name
for
slot)
;; 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))
\f
;;; 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:
;;
;; 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
(: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
;; 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
;; 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
;; 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)
;; 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)
;;; 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.
(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))
(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))))
"<return value>")
(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
(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
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*))
(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*))
;;; 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))))
(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))
;;; 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"
projects / sbcl.git / commitdiff