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