X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=7a10dc174b451feb47219132dbc618ef930903ff;hb=0cfad881b88e03971a2b3ef0c0c0fc2e5f4f1bc8;hp=f0427878b8e2cf605f55c7174e17ee2e9ea04308;hpb=f143939b1dbaf38ebd4f92c851fbc4ecddf37af1;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index f042787..7a10dc1 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) @@ -117,31 +117,19 @@ name context)) ((:function nil) - (check-function-name name) + (check-fun-name name) (note-if-setf-function-and-macro name) - (let ((expansion (info :function :inline-expansion name)) + (let ((expansion (fun-name-inline-expansion name)) (inlinep (info :function :inlinep name))) (setf (gethash name *free-functions*) (if (or expansion inlinep) - (make-defined-function - :name name + (make-defined-fun + :%source-name name :inline-expansion expansion :inlinep inlinep :where-from (info :function :where-from name) :type (info :function :type name)) - (let ((info (info :function :accessor-for name))) - (etypecase info - (null - (find-free-really-function name)) - (sb!xc:structure-class - (find-structure-slot-accessor info name)) - (sb!xc:class - (if (typep (layout-info (info :type :compiler-layout - (sb!xc:class-name - info))) - 'defstruct-description) - (find-structure-slot-accessor info name) - (find-free-really-function name)))))))))))) + (find-free-really-function name)))))))) ;;; Return the LEAF structure for the lexically apparent function ;;; definition of NAME. @@ -172,21 +160,21 @@ (where-from (info :variable :where-from name))) (when (and (eq where-from :assumed) (eq kind :global)) (note-undefined-reference name :variable)) - (setf (gethash name *free-variables*) - (if (eq kind :alien) - (info :variable :alien-info name) - (multiple-value-bind (val valp) - (info :variable :constant-value name) - (if (and (eq kind :constant) valp) - (make-constant :value val - :name name - :type (ctype-of val) - :where-from where-from) - (make-global-var :kind kind - :name name - :type type - :where-from where-from)))))))) + (case kind + (:alien + (info :variable :alien-info name)) + (:constant + (let ((value (info :variable :constant-value name))) + (make-constant :value value + :%source-name name + :type (ctype-of value) + :where-from where-from))) + (t + (make-global-var :kind kind + :%source-name name + :type type + :where-from where-from))))))) ;;; Grovel over CONSTANT checking for any sub-parts that need to be ;;; processed with MAKE-LOAD-FORM. We have to be careful, because @@ -323,10 +311,10 @@ ;;;; exported functions -;;; This function takes a form and the top-level form number for that +;;; This function takes a form and the top level form number for that ;;; form, and returns a lambda representing the translation of that ;;; form in the current global environment. The returned lambda is a -;;; top-level lambda that can be called to cause evaluation of the +;;; top level lambda that can be called to cause evaluation of the ;;; forms. This lambda is in the initial component. If FOR-VALUE is T, ;;; then the value of the form is returned from the function, ;;; otherwise NIL is returned. @@ -347,7 +335,7 @@ ;;; The hashtables used to hold global namespace info must be ;;; reallocated elsewhere. Note also that *LEXENV* is not bound, so ;;; that local macro definitions can be introduced by enclosing code. -(defun ir1-top-level (form path for-value) +(defun ir1-toplevel (form path for-value) (declare (list path)) (let* ((*current-path* path) (component (make-empty-component)) @@ -355,24 +343,25 @@ (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") - (setf (functional-entry-function res) res) - (setf (functional-arg-documentation res) ()) - (setf (functional-kind res) :top-level) + (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 ;;; form number to associate with a source path. This should be bound ;;; to an initial value of 0 before the processing of each truly -;;; top-level form. +;;; top level form. (declaim (type index *current-form-number*)) (defvar *current-form-number*) ;;; This function is called on freshly read forms to record the ;;; initial location of each form (and subform.) Form is the form to -;;; find the paths in, and TLF-NUM is the top-level form number of the -;;; truly top-level form. +;;; find the paths in, and TLF-NUM is the top level form number of the +;;; truly top level form. ;;; ;;; This gets a bit interesting when the source code is circular. This ;;; can (reasonably?) happen in the case of circular list constants. @@ -447,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 @@ -483,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)) @@ -494,11 +487,11 @@ (use-continuation res cont))) (values))) -;;; Add Fun to the COMPONENT-REANALYZE-FUNCTIONS. Fun is returned. - (defun maybe-reanalyze-function (fun) +;;; Add FUN to the COMPONENT-REANALYZE-FUNS. FUN is returned. +(defun maybe-reanalyze-fun (fun) (declare (type functional fun)) (when (typep fun '(or optional-dispatch clambda)) - (pushnew fun (component-reanalyze-functions *current-component*))) + (pushnew fun (component-reanalyze-funs *current-component*))) fun) ;;; Generate a REF node for LEAF, frobbing the LEAF structure as @@ -507,12 +500,12 @@ ;;; functional instead. (defun reference-leaf (start cont leaf) (declare (type continuation start cont) (type leaf leaf)) - (let* ((leaf (or (and (defined-function-p leaf) - (not (eq (defined-function-inlinep leaf) + (let* ((leaf (or (and (defined-fun-p leaf) + (not (eq (defined-fun-inlinep leaf) :notinline)) - (let ((fun (defined-function-functional leaf))) + (let ((fun (defined-fun-functional leaf))) (when (and fun (not (functional-kind fun))) - (maybe-reanalyze-function fun)))) + (maybe-reanalyze-fun fun)))) leaf)) (res (make-ref (or (lexenv-find leaf type-restrictions) (leaf-type leaf)) @@ -576,7 +569,11 @@ (careful-expand-macro (info :function :macro-function fun) form))) ((nil :function) - (ir1-convert-srctran start cont (find-free-function fun "Eh?") form)))) + (ir1-convert-srctran start + cont + (find-free-function fun + "shouldn't happen! (no-cmacro)") + form)))) (defun muffle-warning-or-die () (muffle-warning) @@ -585,63 +582,78 @@ ;;; Expand FORM using the macro whose MACRO-FUNCTION is FUN, trapping ;;; errors which occur during the macroexpansion. (defun careful-expand-macro (fun form) - (handler-bind (;; When cross-compiling, we can get style warnings - ;; about e.g. undefined functions. An unhandled - ;; CL:STYLE-WARNING (as opposed to a - ;; SB!C::COMPILER-NOTE) would cause FAILURE-P to be - ;; set on the return from #'SB!XC:COMPILE-FILE, which - ;; would falsely indicate an error sufficiently - ;; serious that we should stop the build process. To - ;; avoid this, we translate CL:STYLE-WARNING - ;; conditions from the host Common Lisp into - ;; cross-compiler SB!C::COMPILER-NOTE calls. (It - ;; might be cleaner to just make Python use - ;; CL:STYLE-WARNING internally, so that the - ;; significance of any host Common Lisp - ;; CL:STYLE-WARNINGs is understood automatically. But - ;; for now I'm not motivated to do this. -- WHN - ;; 19990412) - (style-warning (lambda (c) - (compiler-note "(during macroexpansion)~%~A" - c) - (muffle-warning-or-die))) - ;; KLUDGE: CMU CL in its wisdom (version 2.4.6 for - ;; Debian Linux, anyway) raises a CL:WARNING - ;; condition (not a CL:STYLE-WARNING) for undefined - ;; symbols when converting interpreted functions, - ;; causing COMPILE-FILE to think the file has a real - ;; problem, causing COMPILE-FILE to return FAILURE-P - ;; set (not just WARNINGS-P set). Since undefined - ;; symbol warnings are often harmless forward - ;; references, and since it'd be inordinately painful - ;; to try to eliminate all such forward references, - ;; these warnings are basically unavoidable. Thus, we - ;; need to coerce the system to work through them, - ;; and this code does so, by crudely suppressing all - ;; warnings in cross-compilation macroexpansion. -- - ;; WHN 19990412 - #+cmu - (warning (lambda (c) - (compiler-note - "(during macroexpansion)~%~ - ~A~%~ - (KLUDGE: That was a non-STYLE WARNING.~%~ - Ordinarily that would cause compilation to~%~ - fail. However, since we're running under~%~ - CMU CL, and since CMU CL emits non-STYLE~%~ - warnings for safe, hard-to-fix things (e.g.~%~ - references to not-yet-defined functions)~%~ - we're going to have to ignore it and proceed~%~ - anyway. Hopefully we're not ignoring anything~%~ - horrible here..)~%" - c) - (muffle-warning-or-die))) - (error (lambda (c) - (compiler-error "(during macroexpansion)~%~A" c)))) - (funcall sb!xc:*macroexpand-hook* - fun - form - *lexenv*))) + (let (;; a hint I (WHN) wish I'd known earlier + (hint "(hint: For more precise location, try *BREAK-ON-SIGNALS*.)")) + (flet (;; Return a string to use as a prefix in error reporting, + ;; telling something about which form caused the problem. + (wherestring () + (let ((*print-pretty* nil) + ;; We rely on the printer to abbreviate FORM. + (*print-length* 3) + (*print-level* 1)) + (format + nil + #-sb-xc-host "(in macroexpansion of ~S)" + ;; longer message to avoid ambiguity "Was it the xc host + ;; or the cross-compiler which encountered the problem?" + #+sb-xc-host "(in cross-compiler macroexpansion of ~S)" + form)))) + (handler-bind (;; When cross-compiling, we can get style warnings + ;; about e.g. undefined functions. An unhandled + ;; CL:STYLE-WARNING (as opposed to a + ;; SB!C::COMPILER-NOTE) would cause FAILURE-P to be + ;; set on the return from #'SB!XC:COMPILE-FILE, which + ;; would falsely indicate an error sufficiently + ;; serious that we should stop the build process. To + ;; avoid this, we translate CL:STYLE-WARNING + ;; conditions from the host Common Lisp into + ;; cross-compiler SB!C::COMPILER-NOTE calls. (It + ;; might be cleaner to just make Python use + ;; CL:STYLE-WARNING internally, so that the + ;; significance of any host Common Lisp + ;; CL:STYLE-WARNINGs is understood automatically. But + ;; for now I'm not motivated to do this. -- WHN + ;; 19990412) + (style-warning (lambda (c) + (compiler-note "~@<~A~:@_~A~:@_~A~:>" + (wherestring) hint c) + (muffle-warning-or-die))) + ;; KLUDGE: CMU CL in its wisdom (version 2.4.6 for + ;; Debian Linux, anyway) raises a CL:WARNING + ;; condition (not a CL:STYLE-WARNING) for undefined + ;; symbols when converting interpreted functions, + ;; causing COMPILE-FILE to think the file has a real + ;; problem, causing COMPILE-FILE to return FAILURE-P + ;; set (not just WARNINGS-P set). Since undefined + ;; symbol warnings are often harmless forward + ;; references, and since it'd be inordinately painful + ;; to try to eliminate all such forward references, + ;; these warnings are basically unavoidable. Thus, we + ;; need to coerce the system to work through them, + ;; and this code does so, by crudely suppressing all + ;; warnings in cross-compilation macroexpansion. -- + ;; WHN 19990412 + #+cmu + (warning (lambda (c) + (compiler-note + "~@<~A~:@_~ + ~A~:@_~ + ~@<(KLUDGE: That was a non-STYLE WARNING. ~ + Ordinarily that would cause compilation to ~ + fail. However, since we're running under ~ + CMU CL, and since CMU CL emits non-STYLE ~ + warnings for safe, hard-to-fix things (e.g. ~ + references to not-yet-defined functions) ~ + we're going to have to ignore it and ~ + proceed anyway. Hopefully we're not ~ + ignoring anything horrible here..)~:@>~:>" + (wherestring) + c) + (muffle-warning-or-die))) + (error (lambda (c) + (compiler-error "~@<~A~:@_~A~@:_~A~:>" + (wherestring) hint c)))) + (funcall sb!xc:*macroexpand-hook* fun form *lexenv*))))) ;;;; conversion utilities @@ -666,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) @@ -675,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))) @@ -704,11 +718,13 @@ ;;; go to ok-combination conversion. (defun ir1-convert-srctran (start cont var form) (declare (type continuation start cont) (type global-var var)) - (let ((inlinep (when (defined-function-p var) - (defined-function-inlinep var)))) + (let ((inlinep (when (defined-fun-p var) + (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 @@ -724,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)))) @@ -754,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 @@ -765,13 +780,13 @@ (if (functional-kind fun) (throw 'local-call-lossage fun) (ir1-convert-combination start cont form - (maybe-reanalyze-function fun)))) + (maybe-reanalyze-fun fun)))) ;;;; 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)) @@ -779,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))))) @@ -848,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) @@ -893,19 +910,19 @@ (make-lexenv :default res :variables (new-venv)) res))) -;;; Return a DEFINED-FUNCTION which copies a global-var but for its inlinep. +;;; Return a DEFINED-FUN which copies a GLOBAL-VAR but for its INLINEP. (defun make-new-inlinep (var inlinep) (declare (type global-var var) (type inlinep inlinep)) - (let ((res (make-defined-function - :name (leaf-name var) + (let ((res (make-defined-fun + :%source-name (leaf-source-name var) :where-from (leaf-where-from var) :type (leaf-type var) :inlinep inlinep))) - (when (defined-function-p var) - (setf (defined-function-inline-expansion res) - (defined-function-inline-expansion var)) - (setf (defined-function-functional res) - (defined-function-functional var))) + (when (defined-fun-p var) + (setf (defined-fun-inline-expansion res) + (defined-fun-inline-expansion var)) + (setf (defined-fun-functional res) + (defined-fun-functional var))) res)) ;;; Parse an inline/notinline declaration. If it's a local function we're @@ -914,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 @@ -942,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 @@ -1055,15 +1074,14 @@ (compiler-error "~S is an alien variable and so can't be declared special." name)) - (when (or (not (global-var-p found)) - (eq (global-var-kind found) :constant)) + (unless (global-var-p found) (compiler-error "~S is a constant and so can't be declared special." name)) found)) (t (make-global-var :kind :special - :name name + :%source-name name :where-from :declared)))) ;;;; LAMBDA hackery @@ -1091,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 @@ -1126,7 +1144,7 @@ ;;; &OPTIONAL and &REST args are annotated with an ARG-INFO structure ;;; which contains the extra information. If we hit something losing, ;;; we bug out with COMPILER-ERROR. These values are returned: -;;; 1. a list of the var structures for each top-level argument; +;;; 1. a list of the var structures for each top level argument; ;;; 2. a flag indicating whether &KEY was specified; ;;; 3. a flag indicating whether other &KEY args are allowed; ;;; 4. a list of the &AUX variables; and @@ -1261,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))))) @@ -1302,8 +1323,8 @@ ;;; Create a lambda node out of some code, returning the result. The ;;; bindings are specified by the list of VAR structures VARS. We deal ;;; with adding the names to the LEXENV-VARIABLES for the conversion. -;;; The result is added to the NEW-FUNCTIONS in the -;;; *CURRENT-COMPONENT* and linked to the component head and tail. +;;; The result is added to the NEW-FUNS in the *CURRENT-COMPONENT* and +;;; linked to the component head and tail. ;;; ;;; We detect special bindings here, replacing the original VAR in the ;;; lambda list with a temporary variable. We then pass a list of the @@ -1316,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)) @@ -1334,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 @@ -1367,7 +1407,7 @@ (link-blocks block (component-tail *current-component*)))))) (link-blocks (component-head *current-component*) (node-block bind)) - (push lambda (component-new-functions *current-component*)) + (push lambda (component-new-funs *current-component*)) lambda)) ;;; Create the actual entry-point function for an optional entry @@ -1384,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))) @@ -1417,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) @@ -1473,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) @@ -1554,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)) @@ -1603,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)))) @@ -1614,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 @@ -1637,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) @@ -1682,79 +1725,88 @@ ;;; 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*)) + (push res (component-new-funs *current-component*)) (ir1-convert-hairy-args res () () () () vars nil body aux-vars aux-vals cont) (setf (optional-dispatch-min-args res) min) @@ -1773,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) @@ -1798,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 @@ -1814,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) @@ -1830,30 +1887,32 @@ (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-FUNCTION object for a function we are about to +;;; Get a DEFINED-FUN object for a function we are about to ;;; define. If the function has been forward referenced, then ;;; substitute for the previous references. -(defun get-defined-function (name) - (let* ((name (proclaim-as-function-name name)) - (found (find-free-function name "Eh?"))) +(defun get-defined-fun (name) + (proclaim-as-fun-name name) + (let ((found (find-free-function name "shouldn't happen! (defined-fun)"))) (note-name-defined name :function) - (cond ((not (defined-function-p found)) + (cond ((not (defined-fun-p found)) (aver (not (info :function :inlinep name))) (let* ((where-from (leaf-where-from found)) - (res (make-defined-function - :name name + (res (make-defined-fun + :%source-name name :where-from (if (eq where-from :declared) :declared :defined) :type (leaf-type found)))) (substitute-leaf res found) (setf (gethash name *free-functions*) res))) - ;; If *FREE-FUNCTIONS* has a previously converted definition for this - ;; name, then blow it away and try again. - ((defined-function-functional found) + ;; If *FREE-FUNCTIONS* has a previously converted definition + ;; for this name, then blow it away and try again. + ((defined-fun-functional found) (remhash name *free-functions*) - (get-defined-function name)) + (get-defined-fun name)) (t found)))) ;;; Check a new global function definition for consistency with @@ -1865,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 @@ -1899,19 +1958,19 @@ ;;; expansion. This prevents recursive inline expansion of ;;; opportunistic pseudo-inlines. (defun ir1-convert-lambda-for-defun (lambda var expansion converter) - (declare (cons lambda) (function converter) (type defined-function var)) - (let ((var-expansion (defined-function-inline-expansion var))) - (unless (eq (defined-function-inlinep var) :inline) - (setf (defined-function-inline-expansion var) nil)) - (let* ((name (leaf-name var)) - (fun (funcall converter lambda name)) + (declare (cons lambda) (function converter) (type defined-fun var)) + (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-source-name var)) + (fun (funcall converter lambda :source-name name)) (function-info (info :function :info name))) - (setf (functional-inlinep fun) (defined-function-inlinep var)) + (setf (functional-inlinep fun) (defined-fun-inlinep var)) (assert-new-definition var fun) - (setf (defined-function-inline-expansion var) var-expansion) + (setf (defined-fun-inline-expansion var) var-expansion) ;; If definitely not an interpreter stub, then substitute for any ;; old references. - (unless (or (eq (defined-function-inlinep var) :notinline) + (unless (or (eq (defined-fun-inlinep var) :notinline) (not *block-compile*) (and function-info (or (function-info-transforms function-info) @@ -1919,8 +1978,8 @@ (function-info-ir2-convert function-info)))) (substitute-leaf fun var) ;; If in a simple environment, then we can allow backward - ;; references to this function from following top-level forms. - (when expansion (setf (defined-function-functional var) fun))) + ;; references to this function from following top level forms. + (when expansion (setf (defined-fun-functional var) fun))) fun))) ;;; the even-at-compile-time part of DEFUN @@ -1929,31 +1988,31 @@ ;;; no inline expansion. (defun %compiler-defun (name lambda-with-lexenv) - (let ((defined-function nil)) ; will be set below if we're in the compiler + (let ((defined-fun nil)) ; will be set below if we're in the compiler - ;; when in the compiler - (when (boundp '*lexenv*) + (when (boundp '*lexenv*) ; when in the compiler (when sb!xc:*compile-print* (compiler-mumble "~&; recognizing DEFUN ~S~%" name)) (remhash name *free-functions*) - (setf defined-function (get-defined-function name))) + (setf defined-fun (get-defined-fun name))) - (become-defined-function-name name) + (become-defined-fun-name name) (cond (lambda-with-lexenv - (setf (info :function :inline-expansion name) lambda-with-lexenv) - (when defined-function - (setf (defined-function-inline-expansion defined-function) + (setf (info :function :inline-expansion-designator name) + lambda-with-lexenv) + (when defined-fun + (setf (defined-fun-inline-expansion defined-fun) lambda-with-lexenv))) (t - (clear-info :function :inline-expansion name))) + (clear-info :function :inline-expansion-designator name))) ;; old CMU CL comment: ;; If there is a type from a previous definition, blast it, ;; since it is obsolete. - (when (and defined-function - (eq (leaf-where-from defined-function) :defined)) - (setf (leaf-type defined-function) + (when (and defined-fun + (eq (leaf-where-from defined-fun) :defined)) + (setf (leaf-type defined-fun) ;; FIXME: If this is a block compilation thing, shouldn't ;; we be setting the type to the full derived type for the ;; definition, instead of this most general function type? @@ -1973,5 +2032,5 @@ ;; non-stub version might use either macro-level LOAD-TIME-VALUE ;; hackery or customized IR1-transform level magic to actually put ;; the name in place. - (aver (legal-function-name-p name)) + (aver (legal-fun-name-p name)) `(lambda ,args ,@body))