X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Fkernel.lisp;h=ad5d8158de9ba7c2d71954c49781d298ab5f1750;hb=f33fdd489e9012e5064d35ca7edc7d4bc3c4a0c2;hp=7624d2cf2a064fbb674b26bd494136be2d341b4d;hpb=4eb1a6d3ad2b7dcc19ac0ec979a1eb1eb049659a;p=sbcl.git

diff --git a/src/code/kernel.lisp b/src/code/kernel.lisp
index 7624d2c..ad5d815 100644
--- a/src/code/kernel.lisp
+++ b/src/code/kernel.lisp
@@ -32,6 +32,18 @@
 (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.
 ;;;
@@ -56,15 +68,18 @@
   (sb!c::control-stack-pointer-sap))
 
 ;;; Return the header typecode for FUNCTION. Can be set with SETF.
-(defun function-subtype (function)
-  (function-subtype function))
-(defun (setf function-subtype) (type function)
-  (setf (function-subtype function) type))
+(defun fun-subtype (function)
+  (fun-subtype function))
+(defun (setf fun-subtype) (type function)
+  (setf (fun-subtype function) type))
 
 ;;; 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))
@@ -114,28 +129,19 @@
 (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)
+(defun %set-vector-raw-bits (object offset value)
   (declare (type index offset))
-  (declare (type (unsigned-byte #.sb!vm:n-word-bits) value))
-  (setf (sb!kernel:%raw-bits object offset) value))
+  (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))
+