src/code/cross-misc.lisp

   1 ;;;; cross-compile-time-only replacements for miscellaneous unportable
   2 ;;;; stuff
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; This software is derived from the CMU CL system, which was
   8 ;;;; written at Carnegie Mellon University and released into the
   9 ;;;; public domain. The software is in the public domain and is
  10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  11 ;;;; files for more information.
  12
  13 (in-package "SB!IMPL")
  14
  15 ;;; In correct code, TRULY-THE has only a performance impact and can
  16 ;;; be safely degraded to ordinary THE.
  17 (defmacro truly-the (type expr)
  18   `(the ,type ,expr))
  19
  20 ;;; MAYBE-INLINE and FREEZE-TYPE declarations can be safely ignored
  21 ;;; (possibly at some cost in efficiency).
  22 (declaim (declaration freeze-type maybe-inline))
  23
  24 ;;; INHIBIT-WARNINGS declarations can be safely ignored (although we
  25 ;;; may then have to wade through some irrelevant warnings).
  26 (declaim (declaration inhibit-warnings))
  27
  28 ;;; Interrupt control isn't an issue in the cross-compiler: we don't
  29 ;;; use address-dependent (and thus GC-dependent) hashes, and we only
  30 ;;; have a single thread of control.
  31 (defmacro without-interrupts (&rest forms)
  32   `(macrolet ((allow-with-interrupts (&body body)
  33                 `(progn ,@body))
  34               (with-local-interrupts (&body body)
  35                 `(progn ,@body)))
  36      ,@forms))
  37
  38 (defmacro with-locked-hash-table ((table) &body body)
  39   (declare (ignore table))
  40   `(progn ,@body))
  41
  42 (defmacro with-locked-system-table ((table) &body body)
  43   (declare (ignore table))
  44   `(progn ,@body))
  45
  46 (defmacro defglobal (name value &rest doc)
  47   `(eval-when (:compile-toplevel :load-toplevel :execute)
  48      (defparameter ,name
  49        (if (boundp ',name)
  50            (symbol-value ',name)
  51            ,value)
  52        ,@doc)))
  53
  54 ;;; The GENESIS function works with fasl code which would, in the
  55 ;;; target SBCL, work on ANSI-STREAMs (streams which aren't extended
  56 ;;; Gray streams). In ANSI Common Lisp, an ANSI-STREAM is just a
  57 ;;; CL:STREAM.
  58 (deftype ansi-stream () 'stream)
  59
  60 (deftype sb!kernel:instance ()
  61   '(or condition structure-object standard-object))
  62 (deftype sb!kernel:funcallable-instance ()
  63   (error "not clear how to represent FUNCALLABLE-INSTANCE type"))
  64
  65 ;;; In the target SBCL, the INSTANCE type refers to a base
  66 ;;; implementation for compound types with lowtag
  67 ;;; INSTANCE-POINTER-LOWTAG. There's no way to express exactly that
  68 ;;; concept portably, but we can get essentially the same effect by
  69 ;;; testing for any of the standard types which would, in the target
  70 ;;; SBCL, be derived from INSTANCE:
  71 (defun %instancep (x)
  72   (typep x '(or condition structure-object standard-object)))
  73
  74 ;;; There aren't any FUNCALLABLE-INSTANCEs in the cross-compilation
  75 ;;; host Common Lisp.
  76 (defun funcallable-instance-p (x)
  77   (if (typep x 'generic-function)
  78     ;; In the target SBCL, FUNCALLABLE-INSTANCEs are used to implement
  79     ;; generic functions, so any case which tests for this might in
  80     ;; fact be trying to test for generic functions. My (WHN 19990313)
  81     ;; expectation is that this case won't arise in the
  82     ;; cross-compiler, but if it does, it deserves a little thought,
  83     ;; rather than reflexively returning NIL.
  84     (error "not clear how to handle GENERIC-FUNCTION")
  85     nil))
  86
  87 ;;; This seems to be the portable Common Lisp type test which
  88 ;;; corresponds to the effect of the target SBCL implementation test...
  89 (defun sb!kernel:array-header-p (x)
  90   (and (typep x 'array)
  91        (or (not (typep x 'simple-array))
  92            (/= (array-rank x) 1))))
  93
  94 ;;; GENESIS needs these at cross-compile time. The target
  95 ;;; implementation of these is reasonably efficient by virtue of its
  96 ;;; ability to peek into the internals of the package implementation;
  97 ;;; this reimplementation is portable but slow.
  98 (defun package-internal-symbol-count (package)
  99   (let ((result 0))
 100     (declare (type fixnum result))
 101     (do-symbols (i package)
 102       ;; KLUDGE: The ANSI Common Lisp specification warns that
 103       ;; DO-SYMBOLS may execute its body more than once for symbols
 104       ;; that are inherited from multiple packages, and we currently
 105       ;; make no attempt to correct for that here. (The current uses
 106       ;; of this function at cross-compile time don't really care if
 107       ;; the count is a little too high.) -- WHN 19990826
 108       (multiple-value-bind (symbol status)
 109           (find-symbol (symbol-name i) package)
 110         (declare (ignore symbol))
 111         (when (member status '(:internal :inherited))
 112           (incf result))))
 113     result))
 114 (defun package-external-symbol-count (package)
 115   (let ((result 0))
 116     (declare (type fixnum result))
 117     (do-external-symbols (i package)
 118       (declare (ignorable i))
 119       (incf result))
 120     result))
 121
 122 ;;; In the target Lisp, INTERN* is the primitive and INTERN is
 123 ;;; implemented in terms of it. This increases efficiency by letting
 124 ;;; us reuse a fixed-size buffer; the alternative would be
 125 ;;; particularly painful because we don't implement DYNAMIC-EXTENT. In
 126 ;;; the host Lisp, this is only used at cold load time, and we don't
 127 ;;; care as much about efficiency, so it's fine to treat the host
 128 ;;; Lisp's INTERN as primitive and implement INTERN* in terms of it.
 129 (defun intern* (nameoid length package)
 130   (intern (replace (make-string length) nameoid :end2 length) package))
 131
 132 ;;; In the target Lisp this is implemented by reading a fixed slot in
 133 ;;; the symbol. In portable ANSI Common Lisp the same criteria can be
 134 ;;; met (more slowly, and with the extra property of repeatability
 135 ;;; between runs) by just calling SXHASH.
 136 (defun symbol-hash (symbol)
 137   (declare (type symbol symbol))
 138   (sxhash symbol))
 139
 140 (defvar sb!xc:*gensym-counter* 0)
 141
 142 (defun sb!xc:gensym (&optional (thing "G"))
 143   (declare (type string thing))
 144   (let ((n sb!xc:*gensym-counter*))
 145     (prog1
 146         (make-symbol (concatenate 'string thing (write-to-string n :base 10 :radix nil :pretty nil)))
 147       (incf sb!xc:*gensym-counter*))))
 148
 149 ;;; These functions are needed for constant-folding.
 150 (defun sb!kernel:simple-array-nil-p (object)
 151   (when (typep object 'array)
 152     (assert (not (eq (array-element-type object) nil))))
 153   nil)
 154
 155 (defun sb!kernel:%negate (number)
 156   (- number))
 157
 158 (defun sb!kernel:%single-float (number)
 159   (coerce number 'single-float))
 160
 161 (defun sb!kernel:%double-float (number)
 162   (coerce number 'double-float))
 163
 164 (defun sb!kernel:%ldb (size posn integer)
 165   (ldb (byte size posn) integer))
 166
 167 (defun sb!kernel:%dpb (newbyte size posn integer)
 168   (dpb newbyte (byte size posn) integer))
 169
 170 (defun sb!kernel:%with-array-data (array start end)
 171   (assert (typep array '(simple-array * (*))))
 172   (values array start end 0))
 173
 174 (defun sb!kernel:%with-array-data/fp (array start end)
 175   (assert (typep array '(simple-array * (*))))
 176   (values array start end 0))
 177
 178 (defun sb!kernel:signed-byte-32-p (number)
 179   (typep number '(signed-byte 32)))
 180
 181 ;;; package locking nops for the cross-compiler
 182
 183 (defmacro without-package-locks (&body body)
 184   `(progn ,@body))
 185
 186 (defmacro with-single-package-locked-error ((&optional kind thing &rest format)
 187                                             &body body)
 188   (declare (ignore kind thing format))
 189   `(progn ,@body))
 190
 191 (defun program-assert-symbol-home-package-unlocked (context symbol control)
 192   (declare (ignore context control))
 193   symbol)
 194
 195 (defun assert-package-unlocked (package &optional control &rest args)
 196   (declare (ignore control args))
 197   package)
 198
 199 (defun assert-symbol-home-package-unlocked (name format &key continuablep)
 200   (declare (ignore format continuablep))
 201   name)
 202
 203 (declaim (declaration enable-package-locks disable-package-locks))