X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefboot.lisp;h=a816b2878c335d13f2313dda3c1d70f056b1a143;hb=0c7ffa8fb85a94482814835c9f28abfd0400ab99;hp=dd7305e59038f94eb0276d3b7057b5f60f0fad2c;hpb=7c07a6f965c51828d8f452b47e0620d8e6cf2959;p=sbcl.git diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index dd7305e..a816b28 100644 --- a/src/code/defboot.lisp +++ b/src/code/defboot.lisp @@ -58,8 +58,8 @@ ((list-of-symbols-p vars) (let ((temps (make-gensym-list (length vars)))) `(multiple-value-bind ,temps ,value-form - ,@(mapcar #'(lambda (var temp) - `(setq ,var ,temp)) + ,@(mapcar (lambda (var temp) + `(setq ,var ,temp)) vars temps) ,(car temps)))) (t (error "Vars is not a list of symbols: ~S" vars)))) @@ -141,81 +141,111 @@ (defmacro-mundanely prog2 (form1 result &body body) `(prog1 (progn ,form1 ,result) ,@body)) -;;; Now that we have the definition of MULTIPLE-VALUE-BIND, we can make a -;;; reasonably readable definition of DEFUN. -;;; -;;; DEFUN expands into %DEFUN which is a function that is treated -;;; magically by the compiler (through an IR1 transform) in order to -;;; handle stuff like inlining. After the compiler has gotten the -;;; information it wants out of macro definition, it compiles a call -;;; to %%DEFUN which happens at load time. -(defmacro-mundanely defun (&whole whole name args &body body) +;;;; DEFUN + +;;; Should we save the inline expansion of the function named NAME? +(defun inline-fun-name-p (name) + (or + ;; the normal reason for saving the inline expansion + (info :function :inlinep name) + ;; another reason for saving the inline expansion: If the + ;; ANSI-recommended idiom + ;; (DECLAIM (INLINE FOO)) + ;; (DEFUN FOO ..) + ;; (DECLAIM (NOTINLINE FOO)) + ;; has been used, and then we later do another + ;; (DEFUN FOO ..) + ;; without a preceding + ;; (DECLAIM (INLINE FOO)) + ;; what should we do with the old inline expansion when we see the + ;; new DEFUN? Overwriting it with the new definition seems like + ;; the only unsurprising choice. + (info :function :inline-expansion-designator name))) + +;;; Now that we have the definition of MULTIPLE-VALUE-BIND, we can +;;; make a reasonably readable definition of DEFUN. +(defmacro-mundanely defun (&environment env name args &body body) + "Define a function at top level." + #+sb-xc-host + (unless (symbol-package (fun-name-block-name name)) + (warn "DEFUN of uninterned symbol ~S (tricky for GENESIS)" name)) (multiple-value-bind (forms decls doc) (parse-body body) - (let ((def `(lambda ,args - ,@decls - (block ,(function-name-block-name name) - ,@forms)))) - `(sb!c::%defun ',name #',def ,doc ',whole)))) -#+sb-xc-host (/show "before PROCLAIM" (sb!c::info :function :kind 'sb!c::%%defun)) -#+sb-xc-host (sb!xc:proclaim '(ftype function sb!c::%%defun)) ; to avoid - ; undefined function warnings -#+sb-xc-host (/show "after PROCLAIM" (sb!c::info :function :kind 'sb!c::%%defun)) -(defun sb!c::%%defun (name def doc &optional inline-expansion) - ;; When we're built as a cross-compiler, the DEF is a function - ;; implemented by the cross-compilation host, which is opaque to us. - ;; Similarly, other things like FDEFINITION or DOCUMENTATION either - ;; aren't ours to mess with or are meaningless to mess with. Thus, - ;; we punt. - #+sb-xc-host (declare (ignore def)) - #-sb-xc-host - (progn - (when (fboundp name) - (style-warn "redefining ~S in DEFUN" name)) - (setf (sb!xc:fdefinition name) def) - (when doc - ;; FIXME: This should use shared SETF-name-parsing logic. - (if (and (consp name) (eq (first name) 'setf)) - (setf (fdocumentation (second name) 'setf) doc) - (setf (fdocumentation name 'function) doc)))) - ;; Other stuff remains meaningful whether we're cross-compiling or - ;; native compiling. - (become-defined-function-name name) - (when (or inline-expansion - (info :function :inline-expansion name)) - (setf (info :function :inline-expansion name) - inline-expansion)) - ;; Voila. + (let* (;; stuff shared between LAMBDA and INLINE-LAMBDA and NAMED-LAMBDA + (lambda-guts `(,args + ,@decls + (block ,(fun-name-block-name name) + ,@forms))) + (lambda `(lambda ,@lambda-guts)) + (named-lambda `(named-lambda ,name ,@lambda-guts)) + (inline-lambda + (cond (;; Does the user not even want to inline? + (not (inline-fun-name-p name)) + nil) + (;; Does inlining look too hairy to handle? + (not (sb!c:lambda-independent-of-lexenv-p lambda env)) + (sb!c:maybe-compiler-note + "lexical environment too hairy, can't inline DEFUN ~S" + name) + nil) + (t + ;; FIXME: The only reason that we return + ;; LAMBDA-WITH-LEXENV instead of returning bare + ;; LAMBDA is to avoid modifying downstream code + ;; which expects LAMBDA-WITH-LEXENV. But the code + ;; here is the only code which feeds into the + ;; downstream code, and the generality of the + ;; interface is no longer used, so it'd make sense + ;; to simplify the interface instead of using the + ;; old general LAMBDA-WITH-LEXENV interface in this + ;; simplified way. + `(sb!c:lambda-with-lexenv + nil nil nil ; i.e. no DECLS, no MACROS, no SYMMACS + ,@lambda-guts))))) + `(progn + + ;; In cross-compilation of toplevel DEFUNs, we arrange + ;; for the LAMBDA to be statically linked by GENESIS. + ;; + ;; It may seem strangely inconsistent not to use NAMED-LAMBDA + ;; here instead of LAMBDA. The reason is historical: + ;; COLD-FSET was written before NAMED-LAMBDA, and has special + ;; logic of its own to notify the compiler about NAME. + #+sb-xc-host + (cold-fset ,name ,lambda) + + (eval-when (:compile-toplevel :load-toplevel :execute) + (sb!c:%compiler-defun ',name ',inline-lambda)) + + (%defun ',name + ;; In normal compilation (not for cold load) this is + ;; where the compiled LAMBDA first appears. In + ;; cross-compilation, we manipulate the + ;; previously-statically-linked LAMBDA here. + #-sb-xc-host ,named-lambda + #+sb-xc-host (fdefinition ',name) + ,doc))))) +#-sb-xc-host +(defun %defun (name def doc) + (declare (type function def)) + (declare (type (or null simple-string doc))) + (aver (legal-fun-name-p name)) + (when (fboundp name) + (/show0 "redefining NAME in %DEFUN") + (style-warn "redefining ~S in DEFUN" name)) + (setf (sb!xc:fdefinition name) def) + + ;; FIXME: I want to do this here (and fix bug 137), but until the + ;; breathtaking CMU CL function name architecture is converted into + ;; something sane, (1) doing so doesn't really fix the bug, and + ;; (2) doing probably isn't even really safe. + #+nil (setf (%fun-name def) name) + + (when doc + ;; FIXME: This should use shared SETF-name-parsing logic. + (if (and (consp name) (eq (first name) 'setf)) + (setf (fdocumentation (second name) 'setf) doc) + (setf (fdocumentation (the symbol name) 'function) doc))) name) -;;; FIXME: Now that the IR1 interpreter is going away and EVAL-WHEN is -;;; becoming ANSI-compliant, it should be possible to merge this and -;;; DEF-IR1-TRANSLATOR %DEFUN into a single DEFUN. (And does %%DEFUN -;;; merge into that too? dunno..) -(defun sb!c::%defun (name def doc source) - (declare (ignore source)) - #-sb-xc-host (progn - #!+sb-interpreter - (setf (sb!eval:interpreted-function-name def) name)) - (flet ((set-type-info-from-def () - (setf (info :function :type name) - #-sb-xc-host (extract-function-type def) - ;; When we're built as a cross-compiler, the DEF is - ;; a function implemented by the cross-compilation - ;; host, which is opaque to us, so we have to punt here. - #+sb-xc-host *universal-function-type*))) - (ecase (info :function :where-from name) - (:assumed - (setf (info :function :where-from name) :defined) - (set-type-info-from-def) - (when (info :function :assumed-type name) - (setf (info :function :assumed-type name) nil))) - (:declared) - (:defined - (set-type-info-from-def) - ;; We shouldn't need to clear this here because it should be - ;; clear already (having been cleared when the last definition - ;; was processed). - (aver (null (info :function :assumed-type name)))))) - (sb!c::%%defun name def doc)) ;;;; DEFVAR and DEFPARAMETER @@ -253,11 +283,11 @@ ;;;; iteration constructs -;;; (These macros are defined in terms of a function DO-DO-BODY which +;;; (These macros are defined in terms of a function FROB-DO-BODY which ;;; is also used by SB!INT:DO-ANONYMOUS. Since these macros should not ;;; be loaded on the cross-compilation host, but SB!INT:DO-ANONYMOUS -;;; and DO-DO-BODY should be, these macros can't conveniently be in -;;; the same file as DO-DO-BODY.) +;;; and FROB-DO-BODY should be, these macros can't conveniently be in +;;; the same file as FROB-DO-BODY.) (defmacro-mundanely do (varlist endlist &body body) #!+sb-doc "DO ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form* @@ -268,7 +298,7 @@ are evaluated as a PROGN, with the result being the value of the DO. A block named NIL is established around the entire expansion, allowing RETURN to be used as an alternate exit mechanism." - (do-do-body varlist endlist body 'let 'psetq 'do nil)) + (frob-do-body varlist endlist body 'let 'psetq 'do nil)) (defmacro-mundanely do* (varlist endlist &body body) #!+sb-doc "DO* ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form* @@ -279,7 +309,7 @@ the Exit-Forms are evaluated as a PROGN, with the result being the value of the DO. A block named NIL is established around the entire expansion, allowing RETURN to be used as an laternate exit mechanism." - (do-do-body varlist endlist body 'let* 'setq 'do* nil)) + (frob-do-body varlist endlist body 'let* 'setq 'do* nil)) ;;; DOTIMES and DOLIST could be defined more concisely using ;;; destructuring macro lambda lists or DESTRUCTURING-BIND, but then @@ -316,8 +346,8 @@ ;; form, we introduce a gratuitous binding of the variable to NIL ;; without the declarations, then evaluate the result form in that ;; environment. We spuriously reference the gratuitous variable, - ;; since we don't want to use IGNORABLE on what might be a special - ;; var. + ;; since since we don't want to use IGNORABLE on what might be a + ;; special var. (let ((n-list (gensym))) `(do ((,n-list ,list (cdr ,n-list))) ((endp ,n-list)