advantage of the new EVAL-WHEN stuff and to clean them up in
general, and they are now more ANSI-compliant in a number of
ways. Martin Atzmueller is responsible for a lot of this.
+?? Inlining can now be controlled the ANSI way, without
+ MAYBE-INLINE, since the idiom
+ (DECLAIM (INLINE FOO))
+ (DEFUN FOO (..) ..)
+ (DECLAIM (NOTINLINE FOO))
+ (DEFUN BAR (..) (FOO ..))
+ (DEFUN BLETCH (..) (DECLARE (INLINE FOO)) (FOO ..))
+ now does what ANSI says it should. The CMU-CL-style
+ SB-EXT:MAYBE-INLINE declaration is now deprecated and ignored.
* A bug in LOOP operations on hash tables has been fixed, thanks
to a bug report and patch from Alexey Dejneka.
* PPRINT-LOGICAL-BLOCK now copies the *PRINT-LINES* value on entry
software is in the public domain and is provided with absolutely no
warranty. See the COPYING and CREDITS files for more information.
+KLUDGE: The ENTITY docbook.dsl command is hardwired to the appropriate
+location for my OpenBSD 2.9 system. There's got to be a more flexible
+way to do it, but I'm not enough of an SGML guru to begin to guess
+what it would be. (WHN 2001-10-15)
+
--
[<!ENTITY docbook.dsl
SYSTEM
- "/usr/lib/sgml/stylesheets/nwalsh-modular/html/docbook.dsl"
+ "/usr/local/share/sgml/docbook/dsssl/modular/html/docbook.dsl"
CDATA
dsssl>]>
"CONSTANTLY-T" "CONSTANTLY-NIL" "CONSTANTLY-0"
"PSXHASH"
"%BREAK"
+ "NTH-BUT-WITH-SANE-ARG-ORDER"
;; ..and macros..
"COLLECT"
;; option was given with no argument, or 0 if no PRINT-OBJECT option
;; was given
(print-object 0 :type (or cons symbol (member 0)))
- ;; the index of the raw data vector and the number of words in it.
- ;; NIL and 0 if not allocated yet.
+ ;; the index of the raw data vector and the number of words in it,
+ ;; or NIL and 0 if not allocated (either because this structure
+ ;; has no raw slots, or because we're still parsing it and haven't
+ ;; run across any raw slots yet)
(raw-index nil :type (or index null))
(raw-length 0 :type index)
;; the value of the :PURE option, or :UNSPECIFIED. This is only
(t
(values nil nil nil))))
-;;; Allocate storage for a DSD in DEFSTRUCT. This is where we decide
-;;; whether a slot is raw or not. If raw, and we haven't allocated a
-;;; raw-index yet for the raw data vector, then do it. Raw objects are
-;;; aligned on the unit of their size.
-(defun allocate-1-slot (defstruct dsd)
+;;; Allocate storage for a DSD in DD. This is where we decide whether
+;;; a slot is raw or not. If raw, and we haven't allocated a raw-index
+;;; yet for the raw data vector, then do it. Raw objects are aligned
+;;; on the unit of their size.
+(defun allocate-1-slot (dd dsd)
(multiple-value-bind (raw? raw-type words)
- (if (eq (dd-type defstruct) 'structure)
+ (if (eq (dd-type dd) 'structure)
(structure-raw-slot-type-and-size (dsd-type dsd))
(values nil nil nil))
(/noshow "ALLOCATE-1-SLOT" dsd raw? raw-type words)
(cond ((not raw?)
- (setf (dsd-index dsd) (dd-length defstruct))
- (incf (dd-length defstruct)))
+ (setf (dsd-index dsd) (dd-length dd))
+ (incf (dd-length dd)))
(t
- (unless (dd-raw-index defstruct)
- (setf (dd-raw-index defstruct) (dd-length defstruct))
- (incf (dd-length defstruct)))
- (let ((off (rem (dd-raw-length defstruct) words)))
+ (unless (dd-raw-index dd)
+ (setf (dd-raw-index dd) (dd-length dd))
+ (incf (dd-length dd)))
+ (let ((off (rem (dd-raw-length dd) words)))
(unless (zerop off)
- (incf (dd-raw-length defstruct) (- words off))))
+ (incf (dd-raw-length dd) (- words off))))
(setf (dsd-raw-type dsd) raw-type)
- (setf (dsd-index dsd) (dd-raw-length defstruct))
- (incf (dd-raw-length defstruct) words))))
+ (setf (dsd-index dsd) (dd-raw-length dd))
+ (incf (dd-raw-length dd) words))))
(values))
(defun typed-structure-info-or-lose (name)
(values))
+;;; Return a form describing the writable place used for this slot
+;;; in the instance named INSTANCE-NAME.
+(defun %accessor-place-form (dd dsd instance-name)
+ (let (;; the operator that we'll use to access a typed slot or, in
+ ;; the case of a raw slot, to read the vector of raw slots
+ (ref (ecase (dd-type dd)
+ (structure '%instance-ref)
+ (funcallable-structure '%funcallable-instance-info)
+ (list 'nth-but-with-sane-arg-order)
+ (vector 'aref)))
+ (raw-type (dsd-raw-type dsd)))
+ (if (eq raw-type t) ; if not raw slot
+ `(,ref ,instance-name ,(dsd-index dsd))
+ (let (;; the operator that we'll use to access one value in
+ ;; the raw data vector
+ (rawref (ecase raw-type
+ ;; The compiler thinks that the raw data
+ ;; vector is a vector of unsigned bytes, so if
+ ;; the slot we want to access actually *is* an
+ ;; unsigned byte, it'll access the slot for
+ ;; us even if we don't lie to it at all.
+ (unsigned-byte 'aref)
+ ;; "A lie can travel halfway round the world while
+ ;; the truth is putting on its shoes." -- Mark Twain
+ (single-float '%raw-ref-single)
+ (double-float '%raw-ref-double)
+ #!+long-float (long-float '%raw-ref-long)
+ (complex-single-float '%raw-ref-complex-single)
+ (complex-double-float '%raw-ref-complex-double)
+ #!+long-float (complex-long-float
+ '%raw-ref-complex-long))))
+ `(,rawref (,ref ,instance-name ,(dd-raw-index dd))
+ ,(dsd-index dsd))))))
+
+;;; Return inline expansion designators (i.e. values suitable for
+;;; (INFO :FUNCTION :INLINE-EXPANSSION-DESIGNATOR ..)) for the reader
+;;; and writer functions of the slot described by DSD.
+(defun accessor-inline-expansion-designators (dd dsd)
+ ;; ordinary tagged non-raw slot case
+ (values (lambda ()
+ `(lambda (instance)
+ (declare (type ,(dd-name dd) instance))
+ (truly-the ,(dsd-type dsd)
+ ,(%accessor-place-form dd dsd 'instance))))
+ (lambda ()
+ `(lambda (new-value instance)
+ (declare (type ,(dsd-type dsd) new-value))
+ (declare (type ,(dd-name dd) structure-object))
+ (setf ,(%accessor-place-form dd dsd 'instance) new-value)))))
+
;;; Do (COMPILE LOAD EVAL)-time actions for the defstruct described by DD.
(defun %compiler-defstruct (dd inherits)
(declare (type defstruct-description dd))
(undefine-structure class)
(subs (class-proper-name class)))
(when (subs)
- (warn "Removing old subclasses of ~S:~% ~S"
+ (warn "removing old subclasses of ~S:~% ~S"
(sb!xc:class-name class)
(subs))))))
(t
(when copier
(proclaim `(ftype (function (,name) ,name) ,copier))))
- (dolist (slot (dd-slots dd))
- (let* ((fun (dsd-accessor-name slot))
- (setf-fun `(setf ,fun)))
- (when (and fun (eq (dsd-raw-type slot) t))
- (proclaim-as-defstruct-fun-name fun)
- (setf (info :function :accessor-for fun) class)
- (unless (dsd-read-only slot)
- (proclaim-as-defstruct-fun-name setf-fun)
- (setf (info :function :accessor-for setf-fun) class)))))
+ (dolist (dsd (dd-slots dd))
+ (let* ((accessor-name (dsd-accessor-name dsd)))
+ (when accessor-name
+
+ ;; new implementation sbcl-0.pre7.64
+ (multiple-value-bind (reader-designator writer-designator)
+ (accessor-inline-expansion-designators dd dsd)
+ (setf (info :function
+ :inline-expansion-designator
+ accessor-name)
+ reader-designator
+ (info :function :inlinep accessor-name)
+ :inline)
+ (unless (dsd-read-only dsd)
+ (let ((setf-accessor-name `(setf ,accessor-name)))
+ (setf (info :function
+ :inline-expansion-designator
+ setf-accessor-name)
+ writer-designator
+ (info :function :inlinep setf-accessor-name)
+ :inline))))
+
+ ;; old code from before sbcl-0.pre7.64, will hopefully
+ ;; fade away and/or merge into new code above
+ (when (eq (dsd-raw-type dsd) t) ; when not raw slot
+ (proclaim-as-defstruct-fun-name accessor-name)
+ (setf (info :function :accessor-for accessor-name) class)
+ (unless (dsd-read-only dsd)
+ (proclaim-as-defstruct-fun-name `(setf ,accessor-name))
+ (setf (info :function :accessor-for `(setf ,accessor-name))
+ class))))))
;; FIXME: Couldn't this logic be merged into
- ;; PROCLAIM-AS-DEFSTRUCT-FUNCTION?
+ ;; PROCLAIM-AS-DEFSTRUCT-FUN-NAME?
(when (boundp 'sb!c:*free-functions*) ; when compiling
(let ((free-functions sb!c:*free-functions*))
(dolist (slot (dd-slots dd))
;;;; slot accessors for raw slots
;;; Return info about how to read/write a slot in the value stored in
-;;; OBJECT. This is also used by constructors (we can't use the
-;;; accessor function, since some slots are read-only.) If supplied,
-;;; DATA is a variable holding the raw-data vector.
+;;; OBJECT. This is also used by constructors (since we can't safely
+;;; use the accessor function, since some slots are read-only). If
+;;; supplied, DATA is a variable holding the raw-data vector.
;;;
;;; returned values:
;;; 1. accessor function name (SETFable)
(declaim (inline neq))
(defun neq (x y)
(not (eq x y)))
+
+;;; not really an old-fashioned function, but what the calling
+;;; convention should've been: like NTH, but with the same argument
+;;; order as in all the other dereferencing functions, with the
+;;; collection first and the index second
+(declaim (inline nth-but-with-sane-arg-order))
+(declaim (ftype (function (list index) t) nth-but-with-sane-arg-order))
+(defun nth-but-with-sane-arg-order (list index)
+ (nth index list))
\f
;;;; miscellaneous iteration extensions
(let ((name (car form)))
(dolist (x (sb!c::lexenv-functions environment))
(when (and (eq (car x) name)
- (not (sb!c::defined-function-p (cdr x))))
+ (not (sb!c::defined-fun-p (cdr x))))
(return t)))))
(expand-or-get-setf-inverse form environment))
((setq temp (info :setf :inverse (car form)))
(let ((found (and env
(cdr (assoc name (sb!c::lexenv-functions env)
:test #'equal)))))
- (unless (eq (cond ((sb!c::defined-function-p found)
- (sb!c::defined-function-inlinep found))
+ (unless (eq (cond ((sb!c::defined-fun-p found)
+ (sb!c::defined-fun-inlinep found))
(found :notinline)
(t
(info :function :inlinep name)))
(let* ((where (info :function :where-from name))
(*compiler-error-context* (lambda-bind (main-entry leaf)))
(global-def (gethash name *free-functions*))
- (global-p (defined-function-p global-def)))
+ (global-p (defined-fun-p global-def)))
(note-name-defined name :function)
(when global-p
(remhash name *free-functions*))
;;; types.
(defun note-assumed-types (component name var)
(when (and (eq (leaf-where-from var) :assumed)
- (not (and (defined-function-p var)
- (eq (defined-function-inlinep var) :notinline)))
+ (not (and (defined-fun-p var)
+ (eq (defined-fun-inlinep var) :notinline)))
(eq (info :function :where-from name) :assumed)
(eq (info :function :kind name) :function))
(let ((atype (info :function :assumed-type name)))
;;; wondering if something should be done to special-case the call. If
;;; CALL is a call to a global function, then see whether it defined
;;; or known:
-;;; -- If a DEFINED-FUNCTION should be inline expanded, then convert
+;;; -- If a DEFINED-FUN should be inline expanded, then convert
;;; the expansion and change the call to call it. Expansion is
;;; enabled if :INLINE or if SPACE=0. If the FUNCTIONAL slot is
;;; true, we never expand, since this function has already been
(declare (type combination call))
(let* ((ref (continuation-use (basic-combination-fun call)))
(leaf (when (ref-p ref) (ref-leaf ref)))
- (inlinep (if (defined-function-p leaf)
- (defined-function-inlinep leaf)
+ (inlinep (if (defined-fun-p leaf)
+ (defined-fun-inlinep leaf)
:no-chance)))
(cond
((eq inlinep :notinline) (values nil nil))
(:inline t)
(:no-chance nil)
((nil :maybe-inline) (policy call (zerop space))))
- (defined-function-inline-expansion leaf)
- (let ((fun (defined-function-functional leaf)))
+ (defined-fun-inline-expansion leaf)
+ (let ((fun (defined-fun-functional leaf)))
(or (not fun)
(and (eq inlinep :inline) (functional-kind fun))))
(inline-expansion-ok call))
(flet ((frob ()
(let ((res (ir1-convert-lambda-for-defun
- (defined-function-inline-expansion leaf)
+ (defined-fun-inline-expansion leaf)
leaf t
#'ir1-convert-inline-lambda)))
- (setf (defined-function-functional leaf) res)
+ (setf (defined-fun-functional leaf) res)
(change-ref-leaf ref res))))
(if ir1-p
(frob)
((or constant functional) t)
(lambda-var
(null (lambda-var-sets leaf)))
- (defined-function
- (not (eq (defined-function-inlinep leaf) :notinline)))
+ (defined-fun
+ (not (eq (defined-fun-inlinep leaf) :notinline)))
(global-var
(case (global-var-kind leaf)
(:global-function t)
(inlinep (info :function :inlinep name)))
(setf (gethash name *free-functions*)
(if (or expansion inlinep)
- (make-defined-function
+ (make-defined-fun
: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)))
+ (when info
+ (error "no expansion for ~S even though :ACCESSOR-FOR"
+ name))
(etypecase info
(null
(find-free-really-function name))
;;; 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))))
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)
;;; 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))))
(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
+ (let ((res (make-defined-fun
:name (leaf-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
:policy (lexenv-policy *lexenv*))))
(ir1-convert-lambda `(lambda ,@body) 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)
+(defun get-defined-fun (name)
(let* ((name (proclaim-as-fun-name name))
- (found (find-free-function name "Eh?")))
+ (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
+ (res (make-defined-fun
:name name
:where-from (if (eq where-from :declared)
:declared :defined)
(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)
+ ((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
;;; 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))
+ (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-name var))
(fun (funcall converter lambda 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)
(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)))
+ (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-fun-name name)
(cond (lambda-with-lexenv
(setf (info :function :inline-expansion-designator name)
lambda-with-lexenv)
- (when defined-function
- (setf (defined-function-inline-expansion defined-function)
+ (when defined-fun
+ (setf (defined-fun-inline-expansion defined-fun)
lambda-with-lexenv)))
(t
(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?
(let ((leaf (ref-leaf use)))
(if (and (global-var-p leaf)
(eq (global-var-kind leaf) :global-function)
- (or (not (defined-function-p leaf))
- (not (eq (defined-function-inlinep leaf) :notinline))
+ (or (not (defined-fun-p leaf))
+ (not (eq (defined-fun-inlinep leaf) :notinline))
notinline-ok))
(leaf-name leaf)
nil))
(functions variables blocks tags type-restrictions
lambda cleanup policy options)))
;; an alist of (NAME . WHAT), where WHAT is either a FUNCTIONAL (a
- ;; local function), a DEFINED-FUNCTION, representing an
+ ;; local function), a DEFINED-FUN, representing an
;; INLINE/NOTINLINE declaration, or a list (MACRO . <function>) (a
;; local macro, with the specifier expander). Note that NAME may be
;; a (SETF <name>) list, not necessarily a single symbol.
for
slot)
-;;; The DEFINED-FUNCTION structure represents functions that are
-;;; defined in the same compilation block, or that have inline
-;;; expansions, or have a non-NIL INLINEP value. Whenever we change
-;;; the INLINEP state (i.e. an inline proclamation) we copy the
-;;; structure so that former INLINEP values are preserved.
-(def!struct (defined-function (:include global-var
- (where-from :defined)
- (kind :global-function)))
+;;; A DEFINED-FUN represents a function that is defined in the same
+;;; compilation block, or that has an inline expansion, or that has a
+;;; non-NIL INLINEP value. Whenever we change the INLINEP state (i.e.
+;;; an inline proclamation) we copy the structure so that former
+;;; INLINEP values are preserved.
+(def!struct (defined-fun (:include global-var
+ (where-from :defined)
+ (kind :global-function)))
;; The values of INLINEP and INLINE-EXPANSION initialized from the
;; global environment.
(inlinep nil :type inlinep)
(inline-expansion nil :type (or cons null))
- ;; The block-local definition of this function (either because it
- ;; was semi-inline, or because it was defined in this block.) If
+ ;; the block-local definition of this function (either because it
+ ;; was semi-inline, or because it was defined in this block). If
;; this function is not an entry point, then this may be deleted or
- ;; let-converted. Null if we haven't converted the expansion yet.
+ ;; LET-converted. Null if we haven't converted the expansion yet.
(functional nil :type (or functional null)))
-(defprinter (defined-function :identity t)
+(defprinter (defined-fun :identity t)
name
inlinep
(functional :test functional))
(def!struct (functional (:include leaf
(where-from :defined)
(type (specifier-type 'function))))
- ;; Some information about how this function is used. These values are
- ;; meaningful:
+ ;; some information about how this function is used. These values
+ ;; are meaningful:
;;
;; NIL
;; an ordinary function, callable using local call
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.pre7.64"
+"0.pre7.65"
projects / sbcl.git / commitdiff