diff --git a/compiler/ir1tran.lisp b/compiler/ir1tran.lisp index 5bdcc751792ef3b40a5e95e39a357844a4407557..6248dc730bb82ddd7595a0175d861630ee32b39b 100644 --- a/compiler/ir1tran.lisp +++ b/compiler/ir1tran.lisp @@ -17,7 +17,7 @@ (export '(*compile-time-define-macros* *converting-for-interpreter*)) (in-package 'ext) -(export '(ignorable truly-the maybe-inline)) +(export '(ignorable truly-the maybe-inline *derive-function-types*)) (in-package "LISP") (export '(symbol-macro-let)) @@ -551,7 +551,8 @@ ;;; 4] A list of the &aux variables. ;;; 5] A list of the &aux values. ;;; -(proclaim '(function find-lambda-vars (list) (values list boolean list list))) +(proclaim '(function find-lambda-vars (list) + (values list boolean boolean list list))) (defun find-lambda-vars (list) (multiple-value-bind (required optional restp rest keyp keys allowp aux) (parse-lambda-list list) @@ -672,7 +673,7 @@ ;;; of Name. The second value is the inlinep information which currently ;;; applies to the variable. ;;; -(proclaim '(function find-lexically-apparent-function (symbol string) +(proclaim '(function find-lexically-apparent-function (t string) (values leaf inlinep))) (defun find-lexically-apparent-function (name context) (let ((var (lexenv-find name functions :test #'equal))) @@ -844,8 +845,8 @@ ;;; Res and returning it as a result. Vars and Fvars are as described in ;;; PROCESS-DECLARATIONS. ;;; -(defun process-1-declaration (spec res vars fvars) - (declare (list spec vars fvars) (type lexenv res)) +(defun process-1-declaration (spec res vars fvars cont) + (declare (list spec vars fvars) (type lexenv res) (type continuation cont)) (case (first spec) (special (process-special-declaration spec res vars)) (ftype @@ -870,6 +871,12 @@ :cookie (process-optimize-declaration spec (lexenv-cookie res)))) (type (process-type-declaration (cdr spec) res vars)) + (values + (let ((types (cdr spec))) + (do-the-stuff (if (null (cdr types)) + (car types) + `(values ,@types)) + cont res 'values))) (t (let ((what (first spec))) (cond ((member what type-specifier-symbols) @@ -887,10 +894,11 @@ ;;; Functional structures which are being bound. In addition to filling in ;;; slots in the leaf structures, we return a new LEXENV which reflects ;;; pervasive special and function type declarations, (not)inline declarations -;;; and optimize declarations. +;;; and optimize declarations. Cont is the continuation affected by VALUES +;;; declarations. ;;; -(defun process-declarations (decls vars fvars) - (declare (list decls vars fvars)) +(defun process-declarations (decls vars fvars cont) + (declare (list decls vars fvars) (type continuation cont)) (let ((res *lexical-environment*)) (dolist (decl decls) (dolist (spec (rest decl)) @@ -898,7 +906,7 @@ (compiler-error "Malformed declaration specifier ~S in ~S." spec decl)) - (setq res (process-1-declaration spec res vars fvars)))) + (setq res (process-1-declaration spec res vars fvars cont)))) res)) @@ -995,11 +1003,12 @@ ;;; 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 &optional aux-vars aux-vals) - (declare (list body vars aux-vars aux-vals)) +(defun ir1-convert-lambda-body (body vars &optional aux-vars aux-vals result) + (declare (list body vars aux-vars aux-vals) + (type (or continuation null) result)) (let* ((bind (make-bind)) (lambda (make-lambda :vars vars :bind bind)) - (result (make-continuation))) + (result (or result (make-continuation)))) (setf (lambda-home lambda) lambda) (collect ((svars) (new-venv nil cons)) @@ -1090,10 +1099,11 @@ (defun generate-optional-default-entry (res default-vars default-vals entry-vars entry-vals vars supplied-p-p body - aux-vars aux-vals) + 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)) + aux-vars aux-vals) + (type (or continuation null) cont)) (let* ((arg (first vars)) (arg-name (leaf-name arg)) (info (lambda-var-arg-info arg)) @@ -1105,14 +1115,14 @@ (list* (leaf-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) + (rest vars) t body aux-vars aux-vals cont) (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)))) + (rest vars) supplied-p-p body aux-vars aux-vals cont)))) (convert-optional-entry ep default-vars default-vals (if supplied-p @@ -1243,10 +1253,12 @@ ;;; rest arg. Keys is a list of the keyword argument vars. ;;; (defun ir1-convert-more (res default-vars default-vals entry-vars entry-vals - rest keys supplied-p-p body aux-vars aux-vals) + rest keys supplied-p-p body aux-vars aux-vals + cont) (declare (type optional-dispatch res) (list default-vars default-vals entry-vars entry-vals keys body - aux-vars aux-vals)) + aux-vars aux-vals) + (type (or continuation null) cont)) (collect ((main-vars (reverse default-vars)) (main-vals default-vals cons) (bind-vars) @@ -1260,8 +1272,12 @@ (default (arg-info-default info)) (hairy-default (not (compiler-constantp default))) (supplied-p (arg-info-supplied-p info)) - (n-val (gensym)) - (val-temp (make-lambda-var :name n-val))) + (n-val (make-symbol (format nil "~A-DEFAULTING-TEMP" + (leaf-name key)))) + (val-temp (make-lambda-var :name n-val + :type (if hairy-default + *universal-type* + (leaf-type key))))) (main-vars val-temp) (bind-vars key) (cond ((or hairy-default supplied-p) @@ -1282,7 +1298,8 @@ (let* ((main-entry (ir1-convert-lambda-body body (main-vars) (append (bind-vars) aux-vars) - (append (bind-vals) aux-vals))) + (append (bind-vals) aux-vals) + cont)) (last-entry (convert-optional-entry main-entry default-vars (main-vals) ()))) (setf (optional-dispatch-main-entry res) main-entry) @@ -1332,13 +1349,14 @@ (defun ir1-convert-hairy-args (res default-vars default-vals entry-vars entry-vals vars supplied-p-p body aux-vars - aux-vals) + aux-vals cont) (declare (type optional-dispatch res) (list default-vars default-vals entry-vars entry-vals vars body - aux-vars aux-vals)) + aux-vars aux-vals) + (type (or continuation null) cont)) (cond ((not vars) (let ((fun (ir1-convert-lambda-body body (reverse default-vars) - aux-vars aux-vals))) + aux-vars aux-vals cont))) (setf (optional-dispatch-main-entry res) fun) (push (if supplied-p-p (convert-optional-entry fun entry-vars entry-vals ()) @@ -1350,7 +1368,8 @@ (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))) + (rest vars) nil body aux-vars aux-vals + cont))) (t (let* ((arg (first vars)) (info (lambda-var-arg-info arg)) @@ -1360,7 +1379,7 @@ (let ((ep (generate-optional-default-entry res default-vars default-vals entry-vars entry-vals vars supplied-p-p body - aux-vars aux-vals))) + aux-vars aux-vals cont))) (push (if supplied-p-p (convert-optional-entry ep entry-vars entry-vals ()) ep) @@ -1370,12 +1389,12 @@ (ir1-convert-more res default-vars default-vals entry-vars entry-vals arg (rest vars) supplied-p-p body - aux-vars aux-vals)) + aux-vars aux-vals cont)) (:keyword (ir1-convert-more res default-vars default-vals entry-vars entry-vals nil vars supplied-p-p body aux-vars - aux-vals))))))) + aux-vals cont))))))) ;;; IR1-Convert-Hairy-Lambda -- Internal @@ -1385,13 +1404,14 @@ ;;; 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) - (declare (list body vars aux-vars aux-vals)) +(defun ir1-convert-hairy-lambda (body vars keyp allowp aux-vars aux-vals cont) + (declare (list body vars aux-vars aux-vals) (type continuation cont)) (let ((res (make-optional-dispatch :arglist vars :allowp allowp :keyp keyp)) (min (or (position-if #'lambda-var-arg-info vars) (length vars)))) (push res (component-new-functions *current-component*)) - (ir1-convert-hairy-args res () () () () vars nil body aux-vars aux-vals) + (ir1-convert-hairy-args res () () () () vars nil body aux-vars aux-vals + cont) (setf (optional-dispatch-min-args res) min) (setf (optional-dispatch-max-args res) (+ (1- (length (optional-dispatch-entry-points res))) min)) @@ -1421,13 +1441,15 @@ (multiple-value-bind (body decls) (system:parse-body (cddr form) *lexical-environment* t) - (let* ((*lexical-environment* - (process-declarations decls (append aux-vars vars) nil)) + (let* ((cont (make-continuation)) + (*lexical-environment* + (process-declarations decls (append aux-vars vars) nil cont)) (res (if (or (find-if #'lambda-var-arg-info vars) keyp) (ir1-convert-hairy-lambda body vars keyp allow-other-keys - aux-vars aux-vals) - (ir1-convert-lambda-body body vars aux-vars aux-vals)))) + aux-vars aux-vals cont) + (ir1-convert-lambda-body body vars aux-vars aux-vals + cont)))) (setf (functional-inline-expansion res) form) (setf (functional-arg-documentation res) (cadr form)) res)))) @@ -1436,6 +1458,12 @@ ;;;; Variable hacking: +(defvar *derive-function-types* t + "If true, argument and result type information derived from compilation of + DEFUNs is used when compiling calls to that function. If false, only + information from FTYPE proclamations will be used.") + + ;;; Find-Free-Really-Function -- Internal ;;; ;;; Return a Global-Var structure usable for referencing the global function @@ -1445,13 +1473,17 @@ (unless (info function kind name) (setf (info function kind name) :function) (setf (info function where-from name) :assumed)) - + (when (eq (info function where-from name) :assumed) (note-undefined-reference name :function)) - - (make-global-var :kind :global-function :name name - :type (info function type name) - :where-from (info function where-from name))) + + (let ((where (info function where-from name))) + (make-global-var :kind :global-function :name name + :type (if (or *derive-function-types* + (eq where :declared)) + (info function type name) + (specifier-type 'function)) + :where-from where))) ;;; Find-Slot-Accessor -- Internal @@ -1498,6 +1530,7 @@ (compiler-error "Found special-form name ~S ~A." name context)) ((:function nil) (check-function-name name) + (note-if-setf-function-and-macro name) (let ((info (info function accessor-for name))) (values (setf (gethash name *free-functions*) (if info @@ -1566,6 +1599,8 @@ ;;; (defun reference-constant (start cont value) (declare (type continuation start cont)) + (unless (typep value '(or list number array symbol character structure)) + (compiler-error "~S constants not supported." (type-of value))) (let* ((leaf (find-constant value)) (res (make-ref (leaf-type leaf) leaf nil))) (push res (leaf-refs leaf)) @@ -1637,6 +1672,10 @@ ;;; 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 assertion +;;; on Cont to be no stronger than the assertion on Cont in our scope. See the +;;; THE IR1-CONVERT method. +;;; (proclaim '(function use-continuation (node continuation) void)) (defun use-continuation (node cont) (let ((block (continuation-block cont)) @@ -1658,7 +1697,12 @@ (assert (not (member node-block (block-pred block))) () "~S is already a predecessor of ~S." node-block block) (push node-block (block-pred block)) - (add-continuation-use node cont))))) + (add-continuation-use node cont) + (unless (eq (continuation-asserted-type cont) *wild-type*) + (setf (continuation-asserted-type cont) + (values-type-union (continuation-asserted-type cont) + (or (lexenv-find cont type-restrictions) + *wild-type*)))))))) ;;; Continuation-Starts-Block -- Internal @@ -2071,6 +2115,9 @@ (def-ir1-translator eval-when ((situations &rest body) start cont) + "EVAL-WHEN (Situation*) Form* + Evaluate the Forms in the specified Situations, any of COMPILE, LOAD, EVAL. + This is conceptually a compile-only implementation, so EVAL is a no-op." (do-eval-when-stuff situations body #'(lambda (forms) (ir1-convert-progn-body start cont forms)))) @@ -2116,6 +2163,11 @@ (def-ir1-translator macrolet ((definitions &rest body) start cont) + "MACROLET ({(Name Lambda-List Form*)}*) Body-Form* + Evaluate the Body-Forms in an environment with the specified local macros + defined. Name is the local macro name, Lambda-List is the DEFMACRO style + destructuring lambda list, and the Forms evaluate to the expansion. The + Forms are evaluated in the null environment." (do-macrolet-stuff definitions #'(lambda () (ir1-convert-progn-body start cont body)))) @@ -2205,10 +2257,15 @@ ;;;; Quote and Function: (def-ir1-translator quote ((thing) start cont) + "QUOTE Value + Return Value without evaluating it." (reference-constant start cont thing)) (def-ir1-translator function ((thing) start cont) + "FUNCTION Name + Return the lexically apparent definition of the function Name. Name may also + be a lambda." (if (and (consp thing) (eq (car thing) 'lambda)) (reference-leaf start cont (ir1-convert-lambda thing) nil) (multiple-value-bind (var inlinep) @@ -2400,38 +2457,20 @@ ;;; %Compiler-Defstruct IR1 Convert -- Internal ;;; ;;; This is a frob that DEFMACRO expands into to establish the compiler -;;; semantics. This is similar to the translator for proclaim: its job is to -;;; keep the *free-functions* in sync. +;;; semantics. %%COMPILER-DEFSTRUCT does most of the work, we just clear all +;;; of the functions out of *FREE-FUNCTIONS* to keep things in synch. ;;; (def-ir1-translator %compiler-defstruct ((info) start cont :kind :function) - (let* ((info (eval info)) - (name (dd-name info)) - (copier (dd-copier info)) - (predicate (dd-predicate info))) - (setf (info type kind name) :structure) - (setf (info type structure-info name) info) + (let* ((info (eval info))) + (funcall #'%%compiler-defstruct info) (dolist (slot (dd-slots info)) - (let ((fun (dsd-accessor slot)) - (type (dsd-type slot))) - (process-1-ftype-proclamation - fun - (specifier-type `(function (,name) ,type))) + (let ((fun (dsd-accessor slot))) + (remhash fun *free-functions*) (unless (dsd-read-only slot) - (process-1-ftype-proclamation - `(setf ,fun) - (specifier-type `(function (,type ,name) ,type)))))) - - (collect ((forms)) - (when copier - (forms `(proclaim '(ftype (function (,name) ,name) ,copier)))) - - (when predicate - (forms `(proclaim '(ftype (function (t) boolean) ,predicate)))) - - (funcall #'%%compiler-defstruct info) - (ir1-convert start cont `(progn - ,@(forms) - (%%compiler-defstruct ',info)))))) + (remhash `(setf ,fun) *free-functions*)))) + (remhash (dd-predicate info) *free-functions*) + (remhash (dd-copier info) *free-functions*) + (ir1-convert start cont `(%%compiler-defstruct ',info)))) ;;;; Let and Let*: @@ -2449,7 +2488,8 @@ ;;; are marked as such. Context is the name of the form, for error reporting ;;; purposes. ;;; -(proclaim '(function extract-let-variables (list symbol) (values list list))) +(proclaim '(function extract-let-variables (list symbol) + (values list list list))) (defun extract-let-variables (bindings context) (collect ((vars) (vals) @@ -2474,9 +2514,13 @@ (def-ir1-translator let ((bindings &body (body decls)) start cont) + "LET ({(Var [Value]) | Var}*) Declaration* Form* + During evaluation of the Forms, Bind the Vars to the result of evaluating the + Value forms. The variables are bound in parallel after all of the Values are + evaluated." (multiple-value-bind (vars values) (extract-let-variables bindings 'let) - (let* ((*lexical-environment* (process-declarations decls vars nil)) + (let* ((*lexical-environment* (process-declarations decls vars nil cont)) (fun-cont (make-continuation)) (fun (ir1-convert-lambda-body body vars))) (reference-leaf start fun-cont fun nil) @@ -2485,9 +2529,12 @@ (def-ir1-translator let* ((bindings &body (body decls)) start cont) + "LET* ({(Var [Value]) | Var}*) Declaration* Form* + Similar to LET, but the variables are bound sequentially, allowing each Value + form to reference any of the previous Vars." (multiple-value-bind (vars values) (extract-let-variables bindings 'let*) - (let ((*lexical-environment* (process-declarations decls vars nil))) + (let ((*lexical-environment* (process-declarations decls vars nil cont))) (ir1-convert-aux-bindings start cont body vars values)))) @@ -2524,6 +2571,10 @@ (def-ir1-translator flet ((definitions &body (body decls)) start cont) + "FLET ({(Name Lambda-List Declaration* Form*)}*) Declaration* Body-Form* + Evaluate the Body-Forms with some local function definitions. The bindings + do not enclose the definitions; any use of Name in the Forms will refer to + the lexically apparent function definition in the enclosing environment." (multiple-value-bind (names defs) (extract-flet-variables definitions 'flet) (let* ((fvars (mapcar #'(lambda (n d) @@ -2532,7 +2583,7 @@ res)) names defs)) (*lexical-environment* - (make-lexenv :default (process-declarations decls nil fvars) + (make-lexenv :default (process-declarations decls nil fvars cont) :functions (pairlis names fvars)))) (ir1-convert-progn-body start cont body)))) @@ -2548,6 +2599,10 @@ ;;; local functions.] ;;; (def-ir1-translator labels ((definitions &body (body decls)) start cont) + "LABELS ({(Name Lambda-List Declaration* Form*)}*) Declaration* Body-Form* + Evaluate the Body-Forms with some local function definitions. The bindings + enclose the new definitions, so the defined functions can call themselves or + each other." (multiple-value-bind (names defs) (extract-flet-variables definitions 'labels) (let* ((dummies (mapcar #'(lambda (x) @@ -2564,40 +2619,79 @@ (mapc #'substitute-leaf real-funs dummies) (let ((*lexical-environment* - (make-lexenv :default (process-declarations decls nil real-funs) - :functions (pairlis names real-funs)))) + (make-lexenv + :default (process-declarations decls nil real-funs cont) + :functions (pairlis names real-funs)))) (ir1-convert-progn-body start cont body))))) ;;;; THE + +;;; DO-THE-STUFF -- Internal +;;; +;;; Do stuff to recognize a THE or VALUES declaration. Cont is the +;;; continuation that the assertion applies to, Type is the type specifier and +;;; Lexenv is the current lexical environment. Name is the name of the +;;; declaration we are doing, for use in error messages. ;;; ;;; This is somewhat involved, since a type assertion may only be made on a -;;; continuation, not on a node. If the continuation has no uses before the -;;; form is converted, then we may make the type the assertion for the -;;; continuation. If there are other uses, then we accept some loss of -;;; information, but try to retain as much as possible. In this case, we make -;;; the type assertion the union of the pre-existing type assertion and the new -;;; type. - +;;; continuation, not on a node. We can't just set the continuation asserted +;;; type and let it go at that, since there may be paralell THE's for the same +;;; continuation, i.e.: +;;; (if ... +;;; (the foo ...) +;;; (the bar ...)) +;;; +;;; In this case, our representation can do no better than the union of these +;;; assertions. And if there is a branch with no assertion, we have nothing at +;;; all. We really need to recognize scoping, since we need to be able to +;;; discern between parallel assertions (which we union) and nested ones (which +;;; we intersect). +;;; +;;; We represent the scoping by throwing our innermost (intersected) assertion +;;; on Cont into the TYPE-RESTRICTIONS. As we go down, we intersect our +;;; assertions together. If Cont has no uses yet, we have not yet bottomed out +;;; on the first COND branch; in this case we optimistically assume that this +;;; type will be the one we end up with, and set the ASSERTED-TYPE to it. +;;; We can never get better than the type that we have the first time we bottom +;;; out. Later THE's (or the absence thereof) can only weaken this result. +;;; +;;; We make this work by getting USE-CONTINUATION to do the unioning across +;;; COND branches. We can't do it here, since we don't know how many branches +;;; there are going to be. +;;; +(defun do-the-stuff (type cont lexenv name) + (declare (type continuation cont) (type lexenv lexenv)) + (let* ((ctype (values-specifier-type type)) + (old-type (or (lexenv-find cont type-restrictions) + *wild-type*)) + (int (values-type-intersection old-type ctype)) + (new (if (eq int *empty-type*) old-type int))) + (when (null (find-uses cont)) + (setf (continuation-asserted-type cont) new)) + (when (and (eq int *empty-type*) + (not (policy nil (= brevity 3)))) + (compiler-warning + "Type ~S in ~S declaration conflicts with enclosing assertion:~% ~S" + (type-specifier ctype) name (type-specifier old-type))) + (make-lexenv :type-restrictions `((,cont . ,new)) + :default lexenv))) + + +;;; THE IR1 Convert -- Internal +;;; (def-ir1-translator the ((type value) start cont) - (let ((ctype (values-specifier-type type))) - (if (null (find-uses cont)) - (let* ((old-type (continuation-asserted-type cont)) - (int (values-type-intersection old-type ctype))) - (when (and (eq int *empty-type*) - (not (policy nil (= brevity 3)))) - (compiler-warning - "Type ~S in THE declaration conflicts with previous type ~S." - (type-specifier ctype) (type-specifier old-type))) - (setf (continuation-asserted-type cont) int)) - (setf (continuation-asserted-type cont) - (values-type-union ctype (continuation-asserted-type cont))))) - (ir1-convert start cont value)) + "THE Type Form + Assert that Form evaluates to the specified type (which may be a VALUES + type.)" + (let ((*lexical-environment* + (do-the-stuff type cont *lexical-environment* 'the))) + (ir1-convert start cont value))) ;;; Truly-The IR1 convert -- Internal ;;; -;;; Since the Continuation-Derive-Type is computed as the union of its +;;; Since the Continuation-Derived-Type is computed as the union of its ;;; uses's types, setting it won't work. Instead we must intersect the type ;;; with the uses's Derived-Type. ;;; @@ -2621,6 +2715,10 @@ ;;; out. (def-ir1-translator setq ((&rest things &whole source) start cont) + "SETQ {Var Value}* + Set the variables to the values. If more than one pair is supplied, the + assignments are done sequentially. If Var names a symbol macro, SETF the + expansion." (let ((len (length things))) (when (oddp len) (compiler-error "Odd number of args to SETQ: ~S." source)) @@ -2783,6 +2881,9 @@ ;;; compilation of MV-Combinations. ;;; (def-ir1-translator multiple-value-call ((fun &rest args) start cont) + "MULTIPLE-VALUE-CALL Function Values-Form* + Call Function, passing all the values of each Values-Form as arguments, + values from the first Values-Form making up the first argument, etc." (let* ((fun-cont (make-continuation)) (node (if args (make-mv-combination fun-cont) @@ -2829,6 +2930,9 @@ ;;; whose block is the true control destination. ;;; (def-ir1-translator multiple-value-prog1 ((result &rest forms) start cont) + "MULTIPLE-VALUE-PROG1 Values-Form Form* + Evaluate Values-Form and then the Forms, but return all the values of + Values-Form." (continuation-starts-block cont) (let* ((dummy-result (make-continuation)) (dummy-start (make-continuation)) @@ -2888,11 +2992,11 @@ (unless (symbolp name) (compiler-error "Macro name is not a symbol: ~S." name)) - (force-output) (ecase (info function kind name) ((nil)) (:function (remhash name *free-functions*) + (undefine-function-name name) (compiler-warning "Defining ~S to be a macro when it was ~(~A~) to be a function." name (info function where-from name))) @@ -2919,11 +3023,12 @@ (compiler-mumble "Converted ~S.~%" name))) +;;; %DEFUN IR1 convert -- Internal ;;; ;;; Convert the definition and substitute for previous global uses. We only ;;; do the substitution if the function is in the null environment, ensuring ;;; that the function cannot be called outside of the correct environment. -;;; Emit top-level code to install the definition. +;;; Also, emit top-level code to install the definition. ;;; (def-ir1-translator %defun ((name def doc source) start cont :kind :function) @@ -2935,28 +3040,48 @@ (in-null-environment)) (cadr def) nil)) (*current-path* (revert-source-path 'defun))) - (setf (info function where-from name) :defined) (setf (info function inline-expansion name) expansion) ;; - ;; If there is a previous defun for the same name, disown the leaf for it. + ;; If function has type information from a previous DEFUN, blow it away. + (when (eq (info function where-from name) :defined) + (setf (info function type name) (specifier-type 'function)) + (remhash name *free-functions*)) + ;; + ;; If there is a previous defun for Name in the same compilation, disown + ;; the leaf for it. (let ((old (gethash name *free-functions*))) (when (functional-p old) (remhash name *free-functions*))) - + ;; + ;; Convert definition. If in the null environment and definitely not an + ;; interpreter stub, then substitute for any references that aren't + ;; :NOTINLINE. (let ((fun (ir1-convert-lambda (cadr def))) (new (gethash name *free-functions*)) (info (info function info name))) (setf (leaf-name fun) name) (cond ((and (in-null-environment t) - (not (eq (info function inlinep name) :notinline)) (or (not info) (and (null (function-info-transforms info)) (null (function-info-templates info)) (not (function-info-ir2-convert info))))) (setf (gethash name *free-functions*) fun) - (when new (substitute-leaf fun new))) + (when new + (substitute-leaf-if + #'(lambda (x) + (not (eq (ref-inlinep x) :notinline))) + fun new))) (t - (let ((var (find-free-function name "in a strange place"))) - (setf (leaf-where-from var) :defined)))) + ;; + ;; We call CHECK-FREE-FUNCTION now, since the functional never + ;; gets into *FREE-FUNCTIONS*. + ;; ### Not so good for inferring result types. + (setf (leaf-type fun) (definition-type fun)) + (check-free-function name fun))) + + (when (eq (info function where-from name) :declared) + (let ((type (info function type name))) + (when (function-type-p type) + (assert-definition-type fun type)))) (ir1-convert start cont `(%%defun ',name ,fun ,doc @@ -2971,15 +3096,23 @@ ;;; (def-ir1-translator %defconstant ((name value doc) start cont :kind :function) - (let ((name (eval name))) + (let ((name (eval name)) + (newval (eval value))) (unless (symbolp name) (compiler-error "Constant name is not a symbol: ~S." name)) + (ecase (info variable kind name) + (:constant + (unless (equalp newval (info variable constant-value name)) + (compiler-warning "Redefining constant ~S as:~% ~S" + name newval))) + (:special + (compiler-warning "Redefining special ~S to be a constant." name)) + (:global)) + (setf (info variable kind name) :constant) (setf (info variable where-from name) :defined) - - (when (and (constantp value) (not (symbolp value))) - (setf (info variable constant-value name) (eval value))) + (setf (info variable constant-value name) newval) (remhash name *free-variables*)) (ir1-convert start cont `(%%defconstant ,name ,value ,doc)))