X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=6d077229a8f84ee4d618fde0114f16462d8cb8dd;hb=9a241987c408980164f71237f7d840265302bbc1;hp=fc7078e8ad3b9f7fcd582cc105eba80045444564;hpb=20748f2dd7965dcd1446a1cb27e5a5af18a0e5bb;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index fc7078e..6d07722 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -33,7 +33,7 @@ ;;; FIXME: It's confusing having one variable named *CURRENT-COMPONENT* ;;; and another named *COMPONENT-BEING-COMPILED*. (In CMU CL they ;;; were called *CURRENT-COMPONENT* and *COMPILE-COMPONENT* respectively, -;;; which also confusing.) +;;; which was also confusing.) (declaim (type (or component null) *current-component*)) (defvar *current-component*) @@ -53,7 +53,7 @@ ;;; Return a GLOBAL-VAR structure usable for referencing the global ;;; function NAME. -(defun find-free-really-function (name) +(defun find-free-really-fun (name) (unless (info :function :kind name) (setf (info :function :kind name) :function) (setf (info :function :where-from name) :assumed)) @@ -75,39 +75,58 @@ (specifier-type 'function)) :where-from where))) -;;; Return a SLOT-ACCESSOR structure usable for referencing the slot -;;; accessor NAME. CLASS is the structure class. -(defun find-structure-slot-accessor (class name) - (declare (type sb!xc:class class)) - (let* ((info (layout-info - (or (info :type :compiler-layout (sb!xc:class-name class)) - (class-layout class)))) - (accessor-name (if (listp name) (cadr name) name)) - (slot (find accessor-name (dd-slots info) - :key #'sb!kernel:dsd-accessor-name)) - (type (dd-name info)) - (slot-type (dsd-type slot))) - (unless slot - (error "can't find slot ~S" type)) - (make-slot-accessor - :%source-name name - :type (specifier-type - (if (listp name) - `(function (,slot-type ,type) ,slot-type) - `(function (,type) ,slot-type))) - :for class - :slot slot))) - -;;; If NAME is already entered in *FREE-FUNCTIONS*, then return the -;;; value. Otherwise, make a new GLOBAL-VAR using information from the -;;; global environment and enter it in *FREE-FUNCTIONS*. If NAME names -;;; a macro or special form, then we error out using the supplied -;;; context which indicates what we were trying to do that demanded a -;;; function. -(defun find-free-function (name context) +;;; Has the *FREE-FUNS* entry FREE-FUN become invalid? +;;; +;;; In CMU CL, the answer was implicitly always true, so this +;;; predicate didn't exist. +;;; +;;; This predicate was added to fix bug 138 in SBCL. In some obscure +;;; circumstances, it was possible for a *FREE-FUNS* to contain a +;;; DEFINED-FUN whose DEFINED-FUN-FUNCTIONAL object contained IR1 +;;; stuff (NODEs, BLOCKs...) referring to an already compiled (aka +;;; "dead") component. When this IR1 stuff was reused in a new +;;; component, under further obscure circumstances it could be used by +;;; WITH-IR1-ENVIRONMENT-FROM-NODE to generate a binding for +;;; *CURRENT-COMPONENT*. At that point things got all confused, since +;;; IR1 conversion was sending code to a component which had already +;;; been compiled and would never be compiled again. +(defun invalid-free-fun-p (free-fun) + ;; There might be other reasons that *FREE-FUN* entries could + ;; become invalid, but the only one we've been bitten by so far + ;; (sbcl-0.pre7.118) is this one: + (and (defined-fun-p free-fun) + (let ((functional (defined-fun-functional free-fun))) + (and (lambda-p functional) + (or + ;; (The main reason for this first test is to bail out + ;; early in cases where the LAMBDA-COMPONENT call in + ;; the second test would fail because links it needs + ;; are uninitialized or invalid.) + ;; + ;; If the BIND node for this LAMBDA is null, then + ;; according to the slot comments, the LAMBDA has been + ;; deleted or its call has been deleted. In that case, + ;; it seems rather questionable to reuse it, and + ;; certainly it shouldn't be necessary to reuse it, so + ;; we cheerfully declare it invalid. + (null (lambda-bind functional)) + ;; If this IR1 stuff belongs to a dead component, then + ;; we can't reuse it without getting into bizarre + ;; confusion. + (eql (component-info (lambda-component functional)) :dead)))))) + +;;; If NAME already has a valid entry in *FREE-FUNS*, then return +;;; the value. Otherwise, make a new GLOBAL-VAR using information from +;;; the global environment and enter it in *FREE-FUNS*. If NAME +;;; names a macro or special form, then we error out using the +;;; supplied context which indicates what we were trying to do that +;;; demanded a function. +(defun find-free-fun (name context) (declare (string context)) (declare (values global-var)) - (or (gethash name *free-functions*) + (or (let ((old-free-fun (gethash name *free-funs*))) + (and (not (invalid-free-fun-p old-free-fun)) + old-free-fun)) (ecase (info :function :kind name) ;; FIXME: The :MACRO and :SPECIAL-FORM cases could be merged. (:macro @@ -118,10 +137,10 @@ context)) ((:function nil) (check-fun-name name) - (note-if-setf-function-and-macro name) + (note-if-setf-fun-and-macro name) (let ((expansion (fun-name-inline-expansion name)) (inlinep (info :function :inlinep name))) - (setf (gethash name *free-functions*) + (setf (gethash name *free-funs*) (if (or expansion inlinep) (make-defined-fun :%source-name name @@ -129,38 +148,37 @@ :inlinep inlinep :where-from (info :function :where-from name) :type (info :function :type name)) - (find-free-really-function name)))))))) + (find-free-really-fun name)))))))) ;;; Return the LEAF structure for the lexically apparent function ;;; definition of NAME. -(declaim (ftype (function (t string) leaf) find-lexically-apparent-function)) -(defun find-lexically-apparent-function (name context) - (let ((var (lexenv-find name functions :test #'equal))) +(declaim (ftype (function (t string) leaf) find-lexically-apparent-fun)) +(defun find-lexically-apparent-fun (name context) + (let ((var (lexenv-find name funs :test #'equal))) (cond (var (unless (leaf-p var) (aver (and (consp var) (eq (car var) 'macro))) (compiler-error "found macro name ~S ~A" name context)) var) (t - (find-free-function name context))))) + (find-free-fun name context))))) ;;; Return the LEAF node for a global variable reference to NAME. If -;;; NAME is already entered in *FREE-VARIABLES*, then we just return -;;; the corresponding value. Otherwise, we make a new leaf using +;;; NAME is already entered in *FREE-VARS*, then we just return the +;;; corresponding value. Otherwise, we make a new leaf using ;;; information from the global environment and enter it in -;;; *FREE-VARIABLES*. If the variable is unknown, then we emit a -;;; warning. -(defun find-free-variable (name) +;;; *FREE-VARS*. If the variable is unknown, then we emit a warning. +(defun find-free-var (name) (declare (values (or leaf heap-alien-info))) (unless (symbolp name) (compiler-error "Variable name is not a symbol: ~S." name)) - (or (gethash name *free-variables*) + (or (gethash name *free-vars*) (let ((kind (info :variable :kind name)) (type (info :variable :type 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*) + (setf (gethash name *free-vars*) (case kind (:alien (info :variable :alien-info name)) @@ -256,8 +274,7 @@ ;;; This function sets up the back link between the node and the ;;; continuation which continues at it. -#!-sb-fluid (declaim (inline prev-link)) -(defun prev-link (node cont) +(defun link-node-to-previous-continuation (node cont) (declare (type node node) (type continuation cont)) (aver (not (continuation-next cont))) (setf (continuation-next cont) node) @@ -268,7 +285,7 @@ ;;; the continuation has no block, then we make it be in the block ;;; that the node is in. If the continuation heads its block, we end ;;; our block and link it to that block. If the continuation is not -;;; currently used, then we set the derived-type for the continuation +;;; currently used, then we set the DERIVED-TYPE for the continuation ;;; to that of the node, so that a little type propagation gets done. ;;; ;;; We also deal with a bit of THE's semantics here: we weaken the @@ -320,11 +337,10 @@ ;;; otherwise NIL is returned. ;;; ;;; This function may have arbitrary effects on the global environment -;;; due to processing of PROCLAIMs and EVAL-WHENs. All syntax error -;;; checking is done, with erroneous forms being replaced by a proxy -;;; which signals an error if it is evaluated. Warnings about possibly -;;; inconsistent or illegal changes to the global environment will -;;; also be given. +;;; due to processing of EVAL-WHENs. All syntax error checking is +;;; done, with erroneous forms being replaced by a proxy which signals +;;; an error if it is evaluated. Warnings about possibly inconsistent +;;; or illegal changes to the global environment will also be given. ;;; ;;; We make the initial component and convert the form in a PROGN (and ;;; an optional NIL tacked on the end.) We then return the lambda. We @@ -431,14 +447,14 @@ (cons form *current-path*)))) (if (atom form) (cond ((and (symbolp form) (not (keywordp form))) - (ir1-convert-variable start cont form)) + (ir1-convert-var start cont form)) ((leaf-p form) (reference-leaf start cont form)) (t (reference-constant start cont form))) (let ((opname (car form))) (cond ((symbolp opname) - (let ((lexical-def (lexenv-find opname functions))) + (let ((lexical-def (lexenv-find opname funs))) (typecase lexical-def (null (ir1-convert-global-functoid start cont form)) (functional @@ -457,7 +473,7 @@ ((or (atom opname) (not (eq (car opname) 'lambda))) (compiler-error "illegal function call")) (t - ;; implicitly #'(LAMBDA ..) because the LAMBDA + ;; implicitly (LAMBDA ..) because the LAMBDA ;; expression is the CAR of an executed form (ir1-convert-combination start cont @@ -483,15 +499,29 @@ (let* ((leaf (find-constant value)) (res (make-ref (leaf-type leaf) leaf))) (push res (leaf-refs leaf)) - (prev-link res start) + (link-node-to-previous-continuation res start) (use-continuation res cont))) (values))) -;;; Add FUN to the COMPONENT-REANALYZE-FUNS. FUN is returned. +;;; Add FUN to the COMPONENT-REANALYZE-FUNS, unless it's some trivial +;;; type for which reanalysis is a trivial no-op, or unless it doesn't +;;; belong in this component at all. +;;; +;;; FUN is returned. (defun maybe-reanalyze-fun (fun) (declare (type functional fun)) + + (aver-live-component *current-component*) + + ;; When FUN is of a type for which reanalysis isn't a trivial no-op (when (typep fun '(or optional-dispatch clambda)) + + ;; When FUN knows its component + (when (lambda-p fun) + (aver (eql (lambda-component fun) *current-component*))) + (pushnew fun (component-reanalyze-funs *current-component*))) + fun) ;;; Generate a REF node for LEAF, frobbing the LEAF structure as @@ -512,22 +542,26 @@ leaf))) (push res (leaf-refs leaf)) (setf (leaf-ever-used leaf) t) - (prev-link res start) + (link-node-to-previous-continuation res start) (use-continuation res cont))) ;;; Convert a reference to a symbolic constant or variable. If the -;;; symbol is entered in the LEXENV-VARIABLES we use that definition, +;;; symbol is entered in the LEXENV-VARS we use that definition, ;;; otherwise we find the current global definition. This is also -;;; where we pick off symbol macro and Alien variable references. -(defun ir1-convert-variable (start cont name) +;;; where we pick off symbol macro and alien variable references. +(defun ir1-convert-var (start cont name) (declare (type continuation start cont) (symbol name)) - (let ((var (or (lexenv-find name variables) (find-free-variable name)))) + (let ((var (or (lexenv-find name vars) (find-free-var name)))) (etypecase var (leaf - (when (and (lambda-var-p var) (lambda-var-ignorep var)) - ;; (ANSI's specification for the IGNORE declaration requires - ;; that this be a STYLE-WARNING, not a full WARNING.) - (compiler-style-warning "reading an ignored variable: ~S" name)) + (when (lambda-var-p var) + (let ((home (continuation-home-lambda-or-null start))) + (when home + (pushnew var (lambda-calls-or-closes home)))) + (when (lambda-var-ignorep var) + ;; (ANSI's specification for the IGNORE declaration requires + ;; that this be a STYLE-WARNING, not a full WARNING.) + (compiler-style-warn "reading an ignored variable: ~S" name))) (reference-leaf start cont var)) (cons (aver (eq (car var) 'MACRO)) @@ -554,8 +588,8 @@ (t (ir1-convert-global-functoid-no-cmacro start cont form fun))))) -;;; Handle the case of where the call was not a compiler macro, or was a -;;; compiler macro and passed. +;;; Handle the case of where the call was not a compiler macro, or was +;;; a compiler macro and passed. (defun ir1-convert-global-functoid-no-cmacro (start cont form fun) (declare (type continuation start cont) (list form)) ;; FIXME: Couldn't all the INFO calls here be converted into @@ -571,8 +605,7 @@ ((nil :function) (ir1-convert-srctran start cont - (find-free-function fun - "shouldn't happen! (no-cmacro)") + (find-free-fun fun "shouldn't happen! (no-cmacro)") form)))) (defun muffle-warning-or-die () @@ -673,14 +706,15 @@ (return)) (let ((this-cont (make-continuation))) (ir1-convert this-start this-cont form) - (setq this-start this-cont forms (cdr forms))))))) + (setq this-start this-cont + forms (cdr forms))))))) (values)) ;;;; converting combinations ;;; 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. +;;; is a LEAF. We return the COMBINATION node so that the caller can +;;; poke at it if it wants to. (declaim (ftype (function (continuation continuation list leaf) combination) ir1-convert-combination)) (defun ir1-convert-combination (start cont form fun) @@ -706,7 +740,7 @@ (ir1-convert this-start this-cont arg) (setq this-start this-cont) (arg-conts this-cont))) - (prev-link node this-start) + (link-node-to-previous-continuation node this-start) (use-continuation node cont) (setf (combination-args node) (arg-conts)))) node)) @@ -742,7 +776,7 @@ (declare (type continuation start cont) (list form) (type global-var var)) (let ((info (info :function :info (leaf-source-name var)))) (if (and info - (ir1-attributep (function-info-attributes info) predicate) + (ir1-attributep (fun-info-attributes info) predicate) (not (if-p (continuation-dest cont)))) (ir1-convert start cont `(if ,form t nil)) (ir1-convert-combination-checking-type start cont form var)))) @@ -773,7 +807,7 @@ (values)) ;;; Convert a call to a local function. If the function has already -;;; been let converted, then throw FUN to LOCAL-CALL-LOSSAGE. This +;;; been LET converted, then throw FUN to LOCAL-CALL-LOSSAGE. This ;;; should only happen when we are converting inline expansions for ;;; local functions during optimization. (defun ir1-convert-local-combination (start cont form fun) @@ -818,8 +852,8 @@ (dolist (var-name (rest decl)) (let* ((bound-var (find-in-bindings vars var-name)) (var (or bound-var - (lexenv-find var-name variables) - (find-free-variable var-name)))) + (lexenv-find var-name vars) + (find-free-var var-name)))) (etypecase var (leaf (let* ((old-type (or (lexenv-find var type-restrictions) @@ -830,7 +864,7 @@ (type-approx-intersection2 old-type type)))) (cond ((eq int *empty-type*) (unless (policy *lexenv* (= inhibit-warnings 3)) - (compiler-warning + (compiler-warn "The type declarations ~S and ~S for ~S conflict." (type-specifier old-type) (type-specifier type) var-name))) @@ -850,7 +884,7 @@ (if (or (restr) (new-vars)) (make-lexenv :default res :type-restrictions (restr) - :variables (new-vars)) + :vars (new-vars)) res)))) ;;; This is somewhat similar to PROCESS-TYPE-DECL, but handles @@ -870,10 +904,10 @@ (found (setf (leaf-type found) type) (assert-definition-type found type - :warning-function #'compiler-note + :unwinnage-fun #'compiler-note :where "FTYPE declaration")) (t - (res (cons (find-lexically-apparent-function + (res (cons (find-lexically-apparent-fun name "in a function type declaration") type)))))) (if (res) @@ -898,7 +932,7 @@ (when (lambda-var-ignorep var) ;; ANSI's definition for "Declaration IGNORE, IGNORABLE" ;; requires that this be a STYLE-WARNING, not a full WARNING. - (compiler-style-warning + (compiler-style-warn "The ignored variable ~S is being declared special." name)) (setf (lambda-var-specvar var) @@ -907,7 +941,7 @@ (unless (assoc name (new-venv) :test #'eq) (new-venv (cons name (specvar-for-binding name)))))))) (if (new-venv) - (make-lexenv :default res :variables (new-venv)) + (make-lexenv :default res :vars (new-venv)) res))) ;;; Return a DEFINED-FUN which copies a GLOBAL-VAR but for its INLINEP. @@ -937,7 +971,7 @@ (if fvar (setf (functional-inlinep fvar) sense) (let ((found - (find-lexically-apparent-function + (find-lexically-apparent-fun name "in an inline or notinline declaration"))) (etypecase found (functional @@ -950,7 +984,7 @@ new-fenv))))))) (if new-fenv - (make-lexenv :default res :functions new-fenv) + (make-lexenv :default res :funs new-fenv) res))) ;;; Like FIND-IN-BINDINGS, but looks for #'foo in the fvars. @@ -974,8 +1008,8 @@ ((not var) ;; ANSI's definition for "Declaration IGNORE, IGNORABLE" ;; requires that this be a STYLE-WARNING, not a full WARNING. - (compiler-style-warning "declaring unknown variable ~S to be ignored" - name)) + (compiler-style-warn "declaring unknown variable ~S to be ignored" + name)) ;; FIXME: This special case looks like non-ANSI weirdness. ((and (consp var) (consp (cdr var)) (eq (cadr var) 'macro)) ;; Just ignore the IGNORE decl. @@ -985,8 +1019,8 @@ ((lambda-var-specvar var) ;; ANSI's definition for "Declaration IGNORE, IGNORABLE" ;; requires that this be a STYLE-WARNING, not a full WARNING. - (compiler-style-warning "declaring special variable ~S to be ignored" - name)) + (compiler-style-warn "declaring special variable ~S to be ignored" + name)) ((eq (first spec) 'ignorable) (setf (leaf-ever-used var) t)) (t @@ -1028,19 +1062,21 @@ (if *suppress-values-declaration* res (let ((types (cdr spec))) - (do-the-stuff (if (eql (length types) 1) - (car types) - `(values ,@types)) - cont res 'values)))) + (ir1ize-the-or-values (if (eql (length types) 1) + (car types) + `(values ,@types)) + cont + res + 'values)))) (dynamic-extent (when (policy *lexenv* (> speed inhibit-warnings)) (compiler-note - "compiler limitation:~ - ~% There's no special support for DYNAMIC-EXTENT (so it's ignored).")) + "compiler limitation: ~ + ~% There's no special support for DYNAMIC-EXTENT (so it's ignored).")) res) (t (unless (info :declaration :recognized (first spec)) - (compiler-warning "unrecognized declaration ~S" raw-spec)) + (compiler-warn "unrecognized declaration ~S" raw-spec)) res)))) ;;; Use a list of DECLARE forms to annotate the lists of LAMBDA-VAR @@ -1069,7 +1105,7 @@ ;;; anonymous GLOBAL-VAR. (defun specvar-for-binding (name) (cond ((not (eq (info :variable :where-from name) :assumed)) - (let ((found (find-free-variable name))) + (let ((found (find-free-var name))) (when (heap-alien-info-p found) (compiler-error "~S is an alien variable and so can't be declared special." @@ -1108,7 +1144,7 @@ (compiler-error "The name of the lambda-variable ~S is a constant." name)) (cond ((eq kind :special) - (let ((specvar (find-free-variable name))) + (let ((specvar (find-free-var name))) (make-lambda-var :%source-name name :type (leaf-type specvar) :where-from (leaf-where-from specvar) @@ -1137,8 +1173,8 @@ key)))) key)) -;;; Parse a lambda-list into a list of VAR structures, stripping off -;;; any aux bindings. Each arg name is checked for legality, and +;;; Parse a lambda list into a list of VAR structures, stripping off +;;; any &AUX bindings. Each arg name is checked for legality, and ;;; duplicate names are checked for. If an arg is globally special, ;;; the var is marked as :SPECIAL instead of :LEXICAL. &KEY, ;;; &OPTIONAL and &REST args are annotated with an ARG-INFO structure @@ -1150,8 +1186,8 @@ ;;; 4. a list of the &AUX variables; and ;;; 5. a list of the &AUX values. (declaim (ftype (function (list) (values list boolean boolean list list)) - find-lambda-vars)) -(defun find-lambda-vars (list) + make-lambda-vars)) +(defun make-lambda-vars (list) (multiple-value-bind (required optional restp rest keyp keys allowp aux morep more-context more-count) (parse-lambda-list list) @@ -1271,6 +1307,10 @@ ;;; sequentially bind each AUX-VAR to the corresponding AUX-VAL before ;;; converting the body. If there are no bindings, just convert the ;;; body, otherwise do one binding and recurse on the rest. +;;; +;;; FIXME: This could and probably should be converted to use +;;; SOURCE-NAME and DEBUG-NAME. But I (WHN) don't use &AUX bindings, +;;; so I'm not motivated. Patches will be accepted... (defun ir1-convert-aux-bindings (start cont body aux-vars aux-vals) (declare (type continuation start cont) (list body aux-vars aux-vals)) (if (null aux-vars) @@ -1322,8 +1362,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-FUNS in the *CURRENT-COMPONENT* and +;;; with adding the names to the LEXENV-VARS for the conversion. 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 @@ -1347,6 +1387,10 @@ debug-name) (declare (list body vars aux-vars aux-vals) (type (or continuation null) result)) + + ;; We're about to try to put new blocks into *CURRENT-COMPONENT*. + (aver-live-component *current-component*) + (let* ((bind (make-bind)) (lambda (make-lambda :vars vars :bind bind @@ -1379,7 +1423,7 @@ (note-lexical-binding (leaf-source-name var)) (new-venv (cons (leaf-source-name var) var)))))) - (let ((*lexenv* (make-lexenv :variables (new-venv) + (let ((*lexenv* (make-lexenv :vars (new-venv) :lambda lambda :cleanup nil))) (setf (bind-lambda bind) lambda) @@ -1388,7 +1432,7 @@ (let ((cont1 (make-continuation)) (cont2 (make-continuation))) (continuation-starts-block cont1) - (prev-link bind cont1) + (link-node-to-previous-continuation bind cont1) (use-continuation bind cont2) (ir1-convert-special-bindings cont2 result body aux-vars aux-vals (svars))) @@ -1402,12 +1446,13 @@ (setf (lambda-return lambda) return) (setf (continuation-dest result) return) (setf (block-last block) return) - (prev-link return result) + (link-node-to-previous-continuation return result) (use-continuation return dummy)) (link-blocks block (component-tail *current-component*)))))) (link-blocks (component-head *current-component*) (node-block bind)) (push lambda (component-new-funs *current-component*)) + lambda)) ;;; Create the actual entry-point function for an optional entry @@ -1451,7 +1496,8 @@ (defun generate-optional-default-entry (res default-vars default-vals entry-vars entry-vals vars supplied-p-p body - aux-vars aux-vals cont) + aux-vars aux-vals cont + source-name debug-name) (declare (type optional-dispatch res) (list default-vars default-vals entry-vars entry-vals vars body aux-vars aux-vals) @@ -1467,14 +1513,16 @@ (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) + (rest vars) t body aux-vars aux-vals cont + source-name debug-name) (ir1-convert-hairy-args res (cons arg default-vars) (cons arg-name default-vals) (cons arg entry-vars) (cons arg-name entry-vals) - (rest vars) supplied-p-p body aux-vars aux-vals cont)))) + (rest vars) supplied-p-p body aux-vars aux-vals cont + source-name debug-name)))) (convert-optional-entry ep default-vars default-vals (if supplied-p @@ -1572,7 +1620,7 @@ (body `(when (oddp ,n-count) - (%odd-key-arguments-error))) + (%odd-key-args-error))) (body `(locally @@ -1587,7 +1635,7 @@ (unless allowp (body `(when (and ,n-losep (not ,n-allowp)) - (%unknown-key-argument-error ,n-losep))))))) + (%unknown-key-arg-error ,n-losep))))))) (let ((ep (ir1-convert-lambda-body `((let ,(temps) @@ -1619,7 +1667,8 @@ ;;; type when computing the type for the main entry's argument. (defun ir1-convert-more (res default-vars default-vals entry-vars entry-vals rest more-context more-count keys supplied-p-p - body aux-vars aux-vals cont) + body aux-vars aux-vals cont + source-name debug-name) (declare (type optional-dispatch res) (list default-vars default-vals entry-vars entry-vals keys body aux-vars aux-vals) @@ -1680,7 +1729,9 @@ :aux-vars (append (bind-vars) aux-vars) :aux-vals (append (bind-vals) aux-vals) :result cont - :debug-name (debug-namify "~S processor" '&more))) + :debug-name (debug-namify "varargs entry point for ~A" + (as-debug-name source-name + debug-name)))) (last-entry (convert-optional-entry main-entry default-vars (main-vals) ()))) (setf (optional-dispatch-main-entry res) main-entry) @@ -1727,7 +1778,8 @@ (defun ir1-convert-hairy-args (res default-vars default-vals entry-vars entry-vals vars supplied-p-p body aux-vars - aux-vals cont) + aux-vals cont + source-name debug-name) (declare (type optional-dispatch res) (list default-vars default-vals entry-vars entry-vals vars body aux-vars aux-vals) @@ -1738,13 +1790,16 @@ (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) + aux-vals cont source-name debug-name) (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"))) + :debug-name (debug-namify + "hairy arg processor for ~A" + (as-debug-name source-name + debug-name))))) (setf (optional-dispatch-main-entry res) fun) (push (if supplied-p-p (convert-optional-entry fun entry-vars entry-vals ()) @@ -1757,7 +1812,8 @@ (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))) + cont + source-name debug-name))) (t (let* ((arg (first vars)) (info (lambda-var-arg-info arg)) @@ -1767,7 +1823,8 @@ (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))) + aux-vars aux-vals cont + source-name debug-name))) (push (if supplied-p-p (convert-optional-entry ep entry-vars entry-vals ()) ep) @@ -1777,17 +1834,19 @@ (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)) + aux-vars aux-vals cont + source-name debug-name)) (: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)) + body aux-vars aux-vals cont + source-name debug-name)) (: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))))))) + aux-vals cont source-name debug-name))))))) ;;; This function deals with the case where we have to make an ;;; OPTIONAL-DISPATCH to represent a LAMBDA. We cons up the result and @@ -1806,9 +1865,10 @@ :%source-name source-name :%debug-name debug-name)) (min (or (position-if #'lambda-var-arg-info vars) (length vars)))) + (aver-live-component *current-component*) (push res (component-new-funs *current-component*)) (ir1-convert-hairy-args res () () () () vars nil body aux-vars aux-vals - cont) + cont source-name debug-name) (setf (optional-dispatch-min-args res) min) (setf (optional-dispatch-max-args res) (+ (1- (length (optional-dispatch-entry-points res))) min)) @@ -1826,6 +1886,7 @@ ;;; Convert a LAMBDA form into a LAMBDA leaf or an OPTIONAL-DISPATCH leaf. (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) @@ -1837,26 +1898,26 @@ form)) (unless (and (consp (cdr form)) (listp (cadr form))) (compiler-error - "The lambda expression has a missing or non-list lambda-list:~% ~S" + "The lambda expression has a missing or non-list lambda list:~% ~S" form)) (multiple-value-bind (vars keyp allow-other-keys aux-vars aux-vals) - (find-lambda-vars (cadr form)) + (make-lambda-vars (cadr form)) (multiple-value-bind (forms decls) (sb!sys:parse-body (cddr form)) - (let* ((cont (make-continuation)) + (let* ((result-cont (make-continuation)) (*lexenv* (process-decls decls (append aux-vars vars) - nil cont)) + nil result-cont)) (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 result-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 result-cont :source-name source-name :debug-name debug-name)))) (setf (functional-inline-expansion res) form) @@ -1880,12 +1941,11 @@ :default (process-decls decls nil nil (make-continuation) (make-null-lexenv)) - :variables (copy-list symbol-macros) - :functions - (mapcar (lambda (x) - `(,(car x) . - (macro . ,(coerce (cdr x) 'function)))) - macros) + :vars (copy-list symbol-macros) + :funs (mapcar (lambda (x) + `(,(car x) . + (macro . ,(coerce (cdr x) 'function)))) + macros) :policy (lexenv-policy *lexenv*)))) (ir1-convert-lambda `(lambda ,@body) :source-name source-name @@ -1896,7 +1956,7 @@ ;;; substitute for the previous references. (defun get-defined-fun (name) (proclaim-as-fun-name name) - (let ((found (find-free-function name "shouldn't happen! (defined-fun)"))) + (let ((found (find-free-fun name "shouldn't happen! (defined-fun)"))) (note-name-defined name :function) (cond ((not (defined-fun-p found)) (aver (not (info :function :inlinep name))) @@ -1907,11 +1967,11 @@ :declared :defined) :type (leaf-type found)))) (substitute-leaf res found) - (setf (gethash name *free-functions*) res))) - ;; If *FREE-FUNCTIONS* has a previously converted definition + (setf (gethash name *free-funs*) res))) + ;; If *FREE-FUNS* has a previously converted definition ;; for this name, then blow it away and try again. ((defined-fun-functional found) - (remhash name *free-functions*) + (remhash name *free-funs*) (get-defined-fun name)) (t found)))) @@ -1934,14 +1994,14 @@ ;; 3.2.2.3 of the spec) but at least as of sbcl-0.6.11, we don't ;; keep track of whether the mismatched data came from the same ;; compilation unit, so we can't do that. -- WHN 2001-02-11 - :error-function #'compiler-style-warning - :warning-function (cond (info #'compiler-style-warning) - (for-real #'compiler-note) - (t nil)) + :lossage-fun #'compiler-style-warn + :unwinnage-fun (cond (info #'compiler-style-warn) + (for-real #'compiler-note) + (t nil)) :really-assert (and for-real (not (and info - (ir1-attributep (function-info-attributes info) + (ir1-attributep (fun-info-attributes info) explicit-check)))) :where (if for-real "previous declaration" @@ -1964,7 +2024,7 @@ (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))) + (fun-info (info :function :info name))) (setf (functional-inlinep fun) (defined-fun-inlinep var)) (assert-new-definition var fun) (setf (defined-fun-inline-expansion var) var-expansion) @@ -1972,10 +2032,10 @@ ;; old references. (unless (or (eq (defined-fun-inlinep var) :notinline) (not *block-compile*) - (and function-info - (or (function-info-transforms function-info) - (function-info-templates function-info) - (function-info-ir2-convert function-info)))) + (and fun-info + (or (fun-info-transforms fun-info) + (fun-info-templates fun-info) + (fun-info-ir2-convert fun-info)))) (substitute-leaf fun var) ;; If in a simple environment, then we can allow backward ;; references to this function from following top level forms. @@ -1993,7 +2053,7 @@ (when (boundp '*lexenv*) ; when in the compiler (when sb!xc:*compile-print* (compiler-mumble "~&; recognizing DEFUN ~S~%" name)) - (remhash name *free-functions*) + (remhash name *free-funs*) (setf defined-fun (get-defined-fun name))) (become-defined-fun-name name) @@ -2019,18 +2079,3 @@ (specifier-type 'function)))) (values)) - -;;;; hacking function names - -;;; 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-fun-name-p name)) - `(lambda ,args ,@body))