src/code/kernel.lisp

   1 ;;;; miscellaneous kernel-level definitions
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!KERNEL")
  13
  14 ;;; Return the 24 bits of data in the header of object X, which must
  15 ;;; be an other-pointer object.
  16 (defun get-header-data (x)
  17   (get-header-data x))
  18
  19 ;;; Set the 24 bits of data in the header of object X (which must be
  20 ;;; an other-pointer object) to VAL.
  21 (defun set-header-data (x val)
  22   (set-header-data x val))
  23
  24 ;;; Return the 24 bits of data in the header of object X, which must
  25 ;;; be a fun-pointer object.
  26 ;;;
  27 ;;; FIXME: Should this not be called GET-FUN-LENGTH instead? Or even better
  28 ;;; yet, if GET-HEADER-DATA masked the lowtag instead of substracting it, we
  29 ;;; could just use it instead -- or at least this could just be a function on
  30 ;;; top of the same VOP.
  31 (defun get-closure-length (x)
  32   (get-closure-length x))
  33
  34 (defun lowtag-of (x)
  35   (lowtag-of x))
  36
  37 (defun widetag-of (x)
  38   (widetag-of x))
  39
  40 ;;; WIDETAG-OF needs extra code to handle LIST and FUNCTION lowtags. When
  41 ;;; we're only dealing with other pointers (eg. when dispatching on array
  42 ;;; element type), this is going to be faster.
  43 (defun %other-pointer-widetag (x)
  44   (%other-pointer-widetag x))
  45
  46 ;;; Return a System-Area-Pointer pointing to the data for the vector
  47 ;;; X, which must be simple.
  48 ;;;
  49 ;;; FIXME: So it should be SIMPLE-VECTOR-SAP, right? (or UNHAIRY-VECTOR-SAP,
  50 ;;; if the meaning is (SIMPLE-ARRAY * 1) instead of SIMPLE-VECTOR)
  51 ;;; (or maybe SIMPLE-VECTOR-DATA-SAP or UNHAIRY-VECTOR-DATA-SAP?)
  52 (defun vector-sap (x)
  53   (declare (type (simple-unboxed-array (*)) x))
  54   (vector-sap x))
  55
  56 ;;; Return a System-Area-Pointer pointing to the end of the binding stack.
  57 (defun sb!c::binding-stack-pointer-sap ()
  58   (sb!c::binding-stack-pointer-sap))
  59
  60 ;;; Return a System-Area-Pointer pointing to the next free word of the
  61 ;;; current dynamic space.
  62 (defun sb!c::dynamic-space-free-pointer ()
  63   (sb!c::dynamic-space-free-pointer))
  64
  65 ;;; Return a System-Area-Pointer pointing to the end of the control stack.
  66 (defun sb!c::control-stack-pointer-sap ()
  67   (sb!c::control-stack-pointer-sap))
  68
  69 ;;; FDEFN -> FUNCTION
  70 (defun sb!c:safe-fdefn-fun (x) (sb!c:safe-fdefn-fun x))
  71
  72 ;;; Return the header typecode for FUNCTION. Can be set with SETF.
  73 (defun fun-subtype (function)
  74   (fun-subtype function))
  75
  76 ;;;; SIMPLE-FUN and accessors
  77
  78 (defun simple-fun-p (object)
  79   (simple-fun-p object))
  80
  81 (deftype simple-fun ()
  82   '(satisfies simple-fun-p))
  83
  84 (defun %simple-fun-doc (simple-fun)
  85   (declare (simple-fun simple-fun))
  86   (let ((info (%simple-fun-info simple-fun)))
  87     (cond ((typep info '(or null string))
  88            info)
  89           ((simple-vector-p info)
  90            nil)
  91           ((consp info)
  92            (car info))
  93           (t
  94            (bug "bogus INFO for ~S: ~S" simple-fun info)))))
  95
  96 (defun (setf %simple-fun-doc) (doc simple-fun)
  97   (declare (type (or null string) doc)
  98            (simple-fun simple-fun))
  99   (let ((info (%simple-fun-info simple-fun)))
 100     (setf (%simple-fun-info simple-fun)
 101           (cond ((typep info '(or null string))
 102                  doc)
 103                 ((simple-vector-p info)
 104                  (if doc
 105                      (cons doc info)
 106                      info))
 107                 ((consp info)
 108                  (if doc
 109                      (cons doc (cdr info))
 110                      (cdr info)))
 111                 (t
 112                  (bug "bogus INFO for ~S: ~S" simple-fun info))))))
 113
 114 (defun %simple-fun-xrefs (simple-fun)
 115   (declare (simple-fun simple-fun))
 116   (let ((info (%simple-fun-info simple-fun)))
 117     (cond ((typep info '(or null string))
 118            nil)
 119           ((simple-vector-p info)
 120            info)
 121           ((consp info)
 122            (cdr info))
 123           (t
 124            (bug "bogus INFO for ~S: ~S" simple-fun info)))))
 125
 126 ;;; Extract the arglist from the function header FUNC.
 127 (defun %simple-fun-arglist (func)
 128   (%simple-fun-arglist func))
 129
 130 (defun (setf %simple-fun-arglist) (new-value func)
 131   (setf (%simple-fun-arglist func) new-value))
 132
 133 ;;; Extract the name from the function header FUNC.
 134 (defun %simple-fun-name (func)
 135   (%simple-fun-name func))
 136
 137 (defun (setf %simple-fun-name) (new-value func)
 138   (setf (%simple-fun-name func) new-value))
 139
 140 ;;; Extract the type from the function header FUNC.
 141 (defun %simple-fun-type (func)
 142   (let ((internal-type (sb!vm::%%simple-fun-type func)))
 143     ;; For backward-compatibility we expand SFUNCTION -> FUNCTION.
 144     (if (and (listp internal-type) (eq (car internal-type) 'sfunction))
 145         (sb!ext:typexpand-1 internal-type)
 146         internal-type)))
 147
 148 (defun %code-entry-points (code-obj) ; DO NOT USE IN NEW CODE
 149   (%code-entry-point code-obj 0))
 150
 151 (defun %simple-fun-next (simple-fun) ; DO NOT USE IN NEW CODE
 152   (let ((code-obj (fun-code-header simple-fun)))
 153     (dotimes (i (code-n-entries code-obj))
 154       (when (eq simple-fun (%code-entry-point code-obj i))
 155         (return (%code-entry-point code-obj (1+ i)))))))
 156
 157 ;; Given either a closure or a simple-fun, return the underlying simple-fun.
 158 ;; FIXME: %SIMPLE-FUN-SELF is a somewhat poor name for this function.
 159 ;; The x86[-64] code defines %CLOSURE-FUN as nothing more than %SIMPLE-FUN-SELF,
 160 ;; and it's not clear whether that's because callers need the "simple" accessor
 161 ;; to work on closures, versus reluctance to define a %CLOSURE/SIMPLE-FUN-FUN
 162 ;; reader. %FUN-FUN works on all three function subtypes, but is nontrivial.
 163 ;; Preferably at least one accessor should get a new name,
 164 ;; so that %SIMPLE-FUN-SELF can mean what it says.
 165
 166 (defun %simple-fun-self (simple-fun)
 167   (%simple-fun-self simple-fun))
 168
 169 ;;;; CLOSURE type and accessors
 170
 171 (defun closurep (object)
 172   (closurep object))
 173
 174 (deftype closure ()
 175   '(satisfies closurep))
 176
 177 (defmacro do-closure-values ((value closure) &body body)
 178   (with-unique-names (i nclosure)
 179     `(let ((,nclosure ,closure))
 180        (declare (closure ,nclosure))
 181        (dotimes (,i (- (1+ (get-closure-length ,nclosure)) sb!vm:closure-info-offset))
 182          (let ((,value (%closure-index-ref ,nclosure ,i)))
 183            ,@body)))))
 184
 185 (defun %closure-values (closure)
 186   (declare (closure closure))
 187   (let (values)
 188     (do-closure-values (elt closure)
 189       (push elt values))
 190     (nreverse values)))
 191
 192 ;;; Extract the function from CLOSURE.
 193 (defun %closure-fun (closure)
 194   (%closure-fun closure))
 195
 196 ;;; Extract the INDEXth slot from CLOSURE.
 197 (defun %closure-index-ref (closure index)
 198   (%closure-index-ref closure index))
 199
 200 ;;; Return the length of VECTOR. There is no reason to use this in
 201 ;;; ordinary code, 'cause length (the vector foo)) is the same.
 202 (defun sb!c::vector-length (vector)
 203   (sb!c::vector-length vector))
 204
 205 ;;; Allocate a unboxed, simple vector with type code TYPE, length LENGTH, and
 206 ;;; WORDS words long. Note: it is your responsibility to ensure that the
 207 ;;; relation between LENGTH and WORDS is correct.
 208 (defun allocate-vector (type length words)
 209   (allocate-vector type length words))
 210
 211 ;;; Allocate an array header with type code TYPE and rank RANK.
 212 (defun make-array-header (type rank)
 213   (make-array-header type rank))
 214
 215 ;;; Return a SAP pointing to the instructions part of CODE-OBJ.
 216 (defun code-instructions (code-obj)
 217   (code-instructions code-obj))
 218
 219 ;;; Extract the INDEXth element from the header of CODE-OBJ. Can be
 220 ;;; set with SETF.
 221 (defun code-header-ref (code-obj index)
 222   (code-header-ref code-obj index))
 223
 224 (defun code-header-set (code-obj index new)
 225   (code-header-set code-obj index new))
 226
 227 (defun %vector-raw-bits (object offset)
 228   (declare (type index offset))
 229   (%vector-raw-bits object offset))
 230
 231 (defun %set-vector-raw-bits (object offset value)
 232   (declare (type index offset))
 233   (declare (type word value))
 234   (setf (%vector-raw-bits object offset) value))
 235
 236 (defun make-single-float (x) (make-single-float x))
 237 (defun make-double-float (hi lo) (make-double-float hi lo))
 238
 239 (defun single-float-bits (x) (single-float-bits x))
 240 (defun double-float-high-bits (x) (double-float-high-bits x))
 241 (defun double-float-low-bits (x) (double-float-low-bits x))
 242
 243 (defun value-cell-ref (x) (value-cell-ref x))
 244
 245 ;;; A unique GC id. This is supplied for code that needs to detect
 246 ;;; whether a GC has happened since some earlier point in time. For
 247 ;;; example:
 248 ;;;
 249 ;;;   (let ((epoch *gc-epoch*))
 250 ;;;      ...
 251 ;;;      (unless (eql epoch *gc-epoch)
 252 ;;;        ....))
 253 ;;;
 254 ;;; This isn't just a fixnum counter since then we'd have theoretical
 255 ;;; problems when exactly 2^29 GCs happen between epoch
 256 ;;; comparisons. Unlikely, but the cost of using a cons instead is too
 257 ;;; small to measure. -- JES, 2007-09-30
 258 (declaim (type cons *gc-epoch*))
 259 (!defglobal *gc-epoch* '(nil . nil))