#-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)
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.
(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)))))))
\f
;;; Grovel over CONSTANT checking for any sub-parts that need to be
;;; processed with MAKE-LOAD-FORM. We have to be careful, because
\f
;;;; 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.
;;; 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))
(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-fun 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.
(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.
- (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
;;; 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))
(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)
;;; 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*)))))
\f
;;;; conversion utilities
\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)))
;;; 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
;;; 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
(if (functional-kind fun)
(throw 'local-call-lossage fun)
(ir1-convert-combination start cont form
- (maybe-reanalyze-function fun))))
+ (maybe-reanalyze-fun fun))))
\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)
(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
(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
(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))))
\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
;;; &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
(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)))))
;;; 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
;;; 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))))
+
+ ;; just to check: 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 ((block (continuation-block result)))
(when block
(let ((return (make-return :result result :lambda lambda))
- (tail-set (make-tail-set :functions (list lambda)))
+ (tail-set (make-tail-set :funs (list lambda)))
(dummy (make-continuation)))
(setf (lambda-tail-set lambda) tail-set)
(setf (lambda-return lambda) return)
(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
(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*))
+ (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)
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-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
(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
;;; 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)
(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
;;; 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?
\f
;;;; hacking function names
-;;; This is like LAMBDA, except the result is tweaked so that
-;;; %FUNCTION-NAME can extract a name. (Also possibly the name could
-;;; also be used at compile time to emit more-informative name-based
-;;; compiler diagnostic messages as well.)
+;;; This is like LAMBDA, except the result is tweaked so that FUN-NAME
+;;; can extract a name. (Also possibly the name could also be used at
+;;; compile time to emit more-informative name-based compiler
+;;; diagnostic messages as well.)
(defmacro-mundanely named-lambda (name args &body body)
;; FIXME: For now, in this stub version, we just discard the name. A
;; 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))
projects / sbcl.git / blobdiff