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 ;;;; SIMPLE-FUN and accessors
  15
  16 (deftype simple-fun ()
  17   '(satisfies simple-fun-p))
  18
  19 (declaim (inline code-header-words))
  20 (defun code-header-words (code)
  21   (logand (get-header-data code) sb!vm:short-header-max-words))
  22
  23 ;;; Extract halves of SIMPLE-FUN-INFO, which is a string if it holds
  24 ;;; documentation, a SIMPLE-VECTOR if XREFS,
  25 ;;; or (CONS STRING SIMPLE-VECTOR) for both, or NIL if neither.
  26 (macrolet ((def (name info-part if-simple-vector if-string)
  27              `(defun ,name (simple-fun)
  28                 (declare (simple-fun simple-fun))
  29                 (let ((info (%simple-fun-info simple-fun)))
  30                   (typecase info
  31                     (list (,info-part info))
  32                     (simple-vector ,if-simple-vector)
  33                     (string ,if-string)
  34                     (t (bug "bogus INFO for ~S: ~S" simple-fun info)))))))
  35   (def %simple-fun-doc   car nil info)
  36   (def %simple-fun-xrefs cdr info nil))
  37
  38 (defun (setf %simple-fun-doc) (doc simple-fun)
  39   (declare (type (or null string) doc)
  40            (simple-fun simple-fun))
  41   (let ((info (%simple-fun-info simple-fun)))
  42     (setf (%simple-fun-info simple-fun)
  43           (cond ((typep info '(or null string))
  44                  doc)
  45                 ((simple-vector-p info)
  46                  (if doc
  47                      (cons doc info)
  48                      info))
  49                 ((consp info)
  50                  (if doc
  51                      (cons doc (cdr info))
  52                      (cdr info)))
  53                 (t
  54                  (bug "bogus INFO for ~S: ~S" simple-fun info))))))
  55
  56 ;;; Extract the type from the function header FUNC.
  57 (defun %simple-fun-type (func)
  58   (let ((internal-type (sb!vm::%%simple-fun-type func)))
  59     ;; For backward-compatibility we expand SFUNCTION -> FUNCTION.
  60     (if (and (listp internal-type) (eq (car internal-type) 'sfunction))
  61         (sb!ext:typexpand-1 internal-type)
  62         internal-type)))
  63
  64 (defun %code-entry-points (code-obj) ; DO NOT USE IN NEW CODE
  65   (%code-entry-point code-obj 0))
  66
  67 (defun %simple-fun-next (simple-fun) ; DO NOT USE IN NEW CODE
  68   (let ((code-obj (fun-code-header simple-fun)))
  69     (dotimes (i (code-n-entries code-obj))
  70       (when (eq simple-fun (%code-entry-point code-obj i))
  71         (return (%code-entry-point code-obj (1+ i)))))))
  72
  73 ;;;; CLOSURE type and accessors
  74
  75 (deftype closure ()
  76   '(satisfies closurep))
  77
  78 ;;; FIXME: this should probably exclude the closure name slot, if named
  79 (defmacro do-closure-values ((value closure) &body body)
  80   (with-unique-names (i nclosure)
  81     `(let ((,nclosure ,closure))
  82        (declare (closure ,nclosure))
  83        (dotimes (,i (- (1+ (get-closure-length ,nclosure)) sb!vm:closure-info-offset))
  84          (let ((,value (%closure-index-ref ,nclosure ,i)))
  85            ,@body)))))
  86
  87 (defun %closure-values (closure)
  88   (declare (closure closure))
  89   (let (values)
  90     (do-closure-values (elt closure)
  91       (push elt values))
  92     values)) ; no need to reverse - this has no promised iteration order
  93
  94 (defun %set-vector-raw-bits (object offset value)
  95   (setf (%vector-raw-bits object offset) value))
  96
  97 ;;; A unique GC id. This is supplied for code that needs to detect
  98 ;;; whether a GC has happened since some earlier point in time. For
  99 ;;; example:
 100 ;;;
 101 ;;;   (let ((epoch *gc-epoch*))
 102 ;;;      ...
 103 ;;;      (unless (eql epoch *gc-epoch)
 104 ;;;        ....))
 105 ;;;
 106 ;;; This isn't just a fixnum counter since then we'd have theoretical
 107 ;;; problems when exactly 2^29 GCs happen between epoch
 108 ;;; comparisons. Unlikely, but the cost of using a cons instead is too
 109 ;;; small to measure. -- JES, 2007-09-30
 110 (declaim (type cons *gc-epoch*))
 111 (!defglobal *gc-epoch* '(nil . nil))
 112
 113 (declaim (inline lowtag-of))
 114 (defun lowtag-of (x) (logand (get-lisp-obj-address x) sb!vm:lowtag-mask))
 115
 116 ;;; Unlike most other "Stub functions" that never called called except
 117 ;;; by the interpreter, these two do get called, by MAKE-UNPORTABLE-FLOAT
 118 (defun make-single-float (x) (make-single-float x))
 119 (defun make-double-float (hi lo) (make-double-float hi lo))