1.0.28.68: move PPC over to slimmed-down EMIT-ERROR-BREAK interface

[sbcl.git] / src / code / kernel.lisp

diff --git a/src/code/kernel.lisp b/src/code/kernel.lisp
index f664cdb..ad5d815 100644 (file)
--- a/src/code/kernel.lisp
+++ b/src/code/kernel.lisp
@@ -21,23 +21,35 @@
 (defun set-header-data (x val)
   (set-header-data x val))
 
-;;; Return the length of the closure X. This is one more than the
-;;; number of variables closed over.
+;;; the length of the closure X, i.e. one more than the
+;;; number of variables closed over
 (defun get-closure-length (x)
   (get-closure-length x))
 
-;;; Return the three-bit lowtag for the object X.
-(defun get-lowtag (x)
-  (get-lowtag x))
+(defun lowtag-of (x)
+  (lowtag-of x))
 
-;;; Return the 8-bit header type for the object X.
-(defun get-type (x)
-  (get-type 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?
+;;; 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)
   (declare (type (simple-unboxed-array (*)) x))
   (vector-sap x))
@@ -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))
+