X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fkernel.lisp;h=c0e455715395b6a7f38b9dc688070faf0da546d8;hb=HEAD;hp=42fe9431ee98719b863780e7bf84ec07a3f6bf08;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git

diff --git a/src/code/kernel.lisp b/src/code/kernel.lisp
index 42fe943..c0e4557 100644
--- a/src/code/kernel.lisp
+++ b/src/code/kernel.lisp
@@ -11,143 +11,220 @@
 
 (in-package "SB!KERNEL")
 
+;;; Return the 24 bits of data in the header of object X, which must
+;;; be an other-pointer object.
 (defun get-header-data (x)
-  #!+sb-doc
-  "Return the 24 bits of data in the header of object X, which must be an
-  other-pointer object."
   (get-header-data x))
 
+;;; Set the 24 bits of data in the header of object X (which must be
+;;; an other-pointer object) to VAL.
 (defun set-header-data (x val)
-  #!+sb-doc
-  "Sets the 24 bits of data in the header of object X (which must be an
-  other-pointer object) to VAL."
   (set-header-data x val))
 
+;;; Return the 24 bits of data in the header of object X, which must
+;;; be a fun-pointer object.
+;;;
+;;; FIXME: Should this not be called GET-FUN-LENGTH instead? Or even better
+;;; yet, if GET-HEADER-DATA masked the lowtag instead of substracting it, we
+;;; could just use it instead -- or at least this could just be a function on
+;;; top of the same VOP.
 (defun get-closure-length (x)
-  #!+sb-doc
-  "Returns the length of the closure X. This is one more than the number
-  of variables closed over."
   (get-closure-length x))
 
-(defun get-lowtag (x)
-  #!+sb-doc
-  "Returns the three-bit lowtag for the object X."
-  (get-lowtag x))
-
-(defun get-type (x)
-  #!+sb-doc
-  "Returns the 8-bit header type for the object X."
-  (get-type x))
-
+(defun lowtag-of (x)
+  (lowtag-of x))
+
+(defun widetag-of (x)
+  (widetag-of x))
+
+;;; WIDETAG-OF needs extra code to handle LIST and FUNCTION lowtags. When
+;;; we're only dealing with other pointers (eg. when dispatching on array
+;;; element type), this is going to be faster.
+(declaim (inline %other-pointer-widetag))
+(defun %other-pointer-widetag (x)
+  (sb!sys:sap-ref-8 (int-sap (get-lisp-obj-address x))
+                    #.(ecase sb!c:*backend-byte-order*
+                        (:little-endian
+                         (- sb!vm:other-pointer-lowtag))
+                        (:big-endian
+                         (- (1- sb!vm:n-word-bytes) sb!vm:other-pointer-lowtag)))))
+
+;;; Return a System-Area-Pointer pointing to the data for the vector
+;;; X, which must be simple.
+;;;
+;;; FIXME: So it should be SIMPLE-VECTOR-SAP, right? (or UNHAIRY-VECTOR-SAP,
+;;; if the meaning is (SIMPLE-ARRAY * 1) instead of SIMPLE-VECTOR)
+;;; (or maybe SIMPLE-VECTOR-DATA-SAP or UNHAIRY-VECTOR-DATA-SAP?)
 (defun vector-sap (x)
-  #!+sb-doc
-  "Return a System-Area-Pointer pointing to the data for the vector X, which
-  must be simple."
   (declare (type (simple-unboxed-array (*)) x))
   (vector-sap x))
 
+;;; Return a System-Area-Pointer pointing to the end of the binding stack.
 (defun sb!c::binding-stack-pointer-sap ()
-  #!+sb-doc
-  "Return a System-Area-Pointer pointing to the end of the binding stack."
   (sb!c::binding-stack-pointer-sap))
 
+;;; Return a System-Area-Pointer pointing to the next free word of the
+;;; current dynamic space.
 (defun sb!c::dynamic-space-free-pointer ()
-  #!+sb-doc
-  "Returns a System-Area-Pointer pointing to the next free work of the current
-  dynamic space."
   (sb!c::dynamic-space-free-pointer))
 
+;;; Return a System-Area-Pointer pointing to the end of the control stack.
 (defun sb!c::control-stack-pointer-sap ()
-  #!+sb-doc
-  "Return a System-Area-Pointer pointing to the end of the control stack."
   (sb!c::control-stack-pointer-sap))
 
-(defun function-subtype (function)
-  #!+sb-doc
-  "Return the header typecode for FUNCTION. Can be set with SETF."
-  (function-subtype function))
-
-(defun (setf function-subtype) (type function)
-  (setf (function-subtype function) type))
-
-(defun %function-arglist (func)
-  #!+sb-doc
-  "Extracts the arglist from the function header FUNC."
-  (%function-arglist func))
-
-(defun %function-name (func)
-  #!+sb-doc
-  "Extracts the name from the function header FUNC."
-  (%function-name func))
-
-(defun %function-type (func)
-  #!+sb-doc
-  "Extracts the type from the function header FUNC."
-  (%function-type func))
-
-(defun %closure-function (closure)
-  #!+sb-doc
-  "Extracts the function from CLOSURE."
-  (%closure-function closure))
+;;; Return the header typecode for FUNCTION. Can be set with SETF.
+(defun fun-subtype (function)
+  (fun-subtype function))
+(defun (setf fun-subtype) (type function)
+  (setf (fun-subtype function) type))
+
+;;;; SIMPLE-FUN and accessors
+
+(declaim (inline simple-fun-p))
+(defun simple-fun-p (object)
+  (= sb!vm:simple-fun-header-widetag (widetag-of object)))
+
+(deftype simple-fun ()
+  '(satisfies simple-fun-p))
+
+(defun %simple-fun-doc (simple-fun)
+  (declare (simple-fun simple-fun))
+  (let ((info (%simple-fun-info simple-fun)))
+    (cond ((typep info '(or null string))
+           info)
+          ((simple-vector-p info)
+           nil)
+          ((consp info)
+           (car info))
+          (t
+           (bug "bogus INFO for ~S: ~S" simple-fun info)))))
+
+(defun (setf %simple-fun-doc) (doc simple-fun)
+  (declare (type (or null string) doc)
+           (simple-fun simple-fun))
+  (let ((info (%simple-fun-info simple-fun)))
+    (setf (%simple-fun-info simple-fun)
+          (cond ((typep info '(or null string))
+                 doc)
+                ((simple-vector-p info)
+                 (if doc
+                     (cons doc info)
+                     info))
+                ((consp info)
+                 (if doc
+                     (cons doc (cdr info))
+                     (cdr info)))
+                (t
+                 (bug "bogus INFO for ~S: ~S" simple-fun info))))))
+
+(defun %simple-fun-xrefs (simple-fun)
+  (declare (simple-fun simple-fun))
+  (let ((info (%simple-fun-info simple-fun)))
+    (cond ((typep info '(or null string))
+           nil)
+          ((simple-vector-p info)
+           info)
+          ((consp info)
+           (cdr info))
+          (t
+           (bug "bogus INFO for ~S: ~S" simple-fun info)))))
+
+;;; Extract the arglist from the function header FUNC.
+(defun %simple-fun-arglist (func)
+  (%simple-fun-arglist func))
+
+(defun (setf %simple-fun-arglist) (new-value func)
+  (setf (%simple-fun-arglist func) new-value))
+
+;;; Extract the name from the function header FUNC.
+(defun %simple-fun-name (func)
+  (%simple-fun-name func))
+
+(defun (setf %simple-fun-name) (new-value func)
+  (setf (%simple-fun-name func) new-value))
+
+;;; Extract the type from the function header FUNC.
+(defun %simple-fun-type (func)
+  (%simple-fun-type func))
+
+(defun %simple-fun-next (simple-fun)
+  (%simple-fun-next simple-fun))
+
+(defun %simple-fun-self (simple-fun)
+  (%simple-fun-self simple-fun))
+
+;;;; CLOSURE type and accessors
+
+(declaim (inline closurep))
+(defun closurep (object)
+  (= sb!vm:closure-header-widetag (widetag-of object)))
+
+(deftype closure ()
+  '(satisfies closurep))
+
+(defmacro do-closure-values ((value closure) &body body)
+  (with-unique-names (i nclosure)
+    `(let ((,nclosure ,closure))
+       (declare (closure ,nclosure))
+       (dotimes (,i (- (1+ (get-closure-length ,nclosure)) sb!vm:closure-info-offset))
+         (let ((,value (%closure-index-ref ,nclosure ,i)))
+           ,@body)))))
+
+(defun %closure-values (closure)
+  (declare (closure closure))
+  (let (values)
+    (do-closure-values (elt closure)
+      (push elt values))
+    (nreverse values)))
+
+;;; Extract the function from CLOSURE.
+(defun %closure-fun (closure)
+  (%closure-fun closure))
+
+;;; Extract the INDEXth slot from CLOSURE.
+(defun %closure-index-ref (closure index)
+  (%closure-index-ref closure index))
 
+;;; Return the length of VECTOR. There is no reason to use this in
+;;; ordinary code, 'cause length (the vector foo)) is the same.
 (defun sb!c::vector-length (vector)
-  #!+sb-doc
-  "Return the length of VECTOR. There is no reason to use this, 'cause
-  (length (the vector foo)) is the same."
   (sb!c::vector-length vector))
 
-(defun %closure-index-ref (closure index)
-  #!+sb-doc
-  "Extract the INDEXth slot from CLOSURE."
-  (%closure-index-ref closure index))
-
+;;; Allocate a unboxed, simple vector with type code TYPE, length LENGTH, and
+;;; WORDS words long. Note: it is your responsibility to ensure that the
+;;; relation between LENGTH and WORDS is correct.
 (defun allocate-vector (type length words)
-  #!+sb-doc
-  "Allocate a unboxed, simple vector with type code TYPE, length LENGTH, and
-  WORDS words long. Note: it is your responsibility to ensure that the
-  relation between LENGTH and WORDS is correct."
   (allocate-vector type length words))
 
+;;; Allocate an array header with type code TYPE and rank RANK.
 (defun make-array-header (type rank)
-  #!+sb-doc
-  "Allocate an array header with type code TYPE and rank RANK."
   (make-array-header type rank))
 
+;;; Return a SAP pointing to the instructions part of CODE-OBJ.
 (defun code-instructions (code-obj)
-  #!+sb-doc
-  "Return a SAP pointing to the instructions part of CODE-OBJ."
   (code-instructions code-obj))
 
+;;; Extract the INDEXth element from the header of CODE-OBJ. Can be
+;;; set with SETF.
 (defun code-header-ref (code-obj index)
-  #!+sb-doc
-  "Extract the INDEXth element from the header of CODE-OBJ. Can be set with
-  setf."
   (code-header-ref code-obj index))
 
 (defun code-header-set (code-obj index new)
   (code-header-set code-obj index new))
 
-(defun %raw-bits (object offset)
+(defun %vector-raw-bits (object offset)
   (declare (type index offset))
-  (sb!kernel:%raw-bits object offset))
+  (sb!kernel:%vector-raw-bits object offset))
 
-(defun %set-raw-bits (object offset value)
-  (declare (type index offset) (type (unsigned-byte #.sb!vm:word-bits) value))
-  (setf (sb!kernel:%raw-bits object offset) value))
+(defun %set-vector-raw-bits (object offset value)
+  (declare (type index offset))
+  (declare (type sb!vm:word value))
+  (setf (sb!kernel:%vector-raw-bits object offset) value))
 
 (defun make-single-float (x) (make-single-float x))
 (defun make-double-float (hi lo) (make-double-float hi lo))
-#!+long-float
-(defun make-long-float (exp hi #!+sparc mid lo)
-  (make-long-float exp hi #!+sparc mid lo))
+
 (defun single-float-bits (x) (single-float-bits x))
 (defun double-float-high-bits (x) (double-float-high-bits x))
 (defun double-float-low-bits (x) (double-float-low-bits x))
-#!+long-float
-(defun long-float-exp-bits (x) (long-float-exp-bits x))
-#!+long-float
-(defun long-float-high-bits (x) (long-float-high-bits x))
-#!+(and long-float sparc)
-(defun long-float-mid-bits (x) (long-float-mid-bits x))
-#!+long-float
-(defun long-float-low-bits (x) (long-float-low-bits x))
+