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   `(progn ,@forms))
  33
  34 ;;; When we're running as a cross-compiler in an arbitrary host ANSI
  35 ;;; Lisp, we shouldn't be doing anything which is sensitive to GC.
  36 ;;; KLUDGE: I (WHN 19990131) think the proper long-term solution would
  37 ;;; be to remove any operations from cross-compiler source files
  38 ;;; (putting them in target-only source files) if they refer to these
  39 ;;; hooks. This is a short-term hack.
  40 (defvar *before-gc-hooks* nil)
  41 (defvar *after-gc-hooks* nil)
  42
  43 ;;; The GENESIS function works with fasl code which would, in the
  44 ;;; target SBCL, work on ANSI-STREAMs (streams which aren't extended
  45 ;;; Gray streams). In ANSI Common Lisp, an ANSI-STREAM is just a
  46 ;;; CL:STREAM.
  47 (deftype ansi-stream () 'stream)
  48
  49 ;;; In the target SBCL, the INSTANCE type refers to a base
  50 ;;; implementation for compound types. There's no way to express
  51 ;;; exactly that concept portably, but we can get essentially the same
  52 ;;; effect by testing for any of the standard types which would, in
  53 ;;; the target SBCL, be derived from INSTANCE:
  54 (deftype sb!kernel:instance ()
  55   '(or condition standard-object structure-object))
  56
  57 ;;; There aren't any FUNCALLABLE-INSTANCEs in the cross-compilation
  58 ;;; host Common Lisp.
  59 (defun funcallable-instance-p (x)
  60   (if (typep x 'generic-function)
  61     ;; In the target SBCL, FUNCALLABLE-INSTANCEs are used to implement
  62     ;; generic functions, so any case which tests for this might in
  63     ;; fact be trying to test for generic functions. My (WHN 19990313)
  64     ;; expectation is that this case won't arise in the
  65     ;; cross-compiler, but if it does, it deserves a little thought,
  66     ;; rather than reflexively returning NIL.
  67     (error "not clear how to handle GENERIC-FUNCTION")
  68     nil))
  69
  70 ;;; This seems to be the portable Common Lisp type test which
  71 ;;; corresponds to the effect of the target SBCL implementation test...
  72 (defun sb!kernel:array-header-p (x)
  73   (and (typep x 'array)
  74        (or (not (typep x 'simple-array))
  75            (/= (array-rank x) 1))))
  76
  77 ;;; GENESIS needs these at cross-compile time. The target
  78 ;;; implementation of these is reasonably efficient by virtue of its
  79 ;;; ability to peek into the internals of the package implementation;
  80 ;;; this reimplementation is portable but slow.
  81 (defun package-internal-symbol-count (package)
  82   (let ((result 0))
  83     (declare (type fixnum result))
  84     (do-symbols (i package)
  85       ;; KLUDGE: The ANSI Common Lisp specification warns that
  86       ;; DO-SYMBOLS may execute its body more than once for symbols
  87       ;; that are inherited from multiple packages, and we currently
  88       ;; make no attempt to correct for that here. (The current uses
  89       ;; of this function at cross-compile time don't really care if
  90       ;; the count is a little too high.) -- WHN 19990826
  91       (multiple-value-bind (symbol status)
  92           (find-symbol (symbol-name i) package)
  93         (declare (ignore symbol))
  94         (when (member status '(:internal :inherited))
  95           (incf result))))
  96     result))
  97 (defun package-external-symbol-count (package)
  98   (let ((result 0))
  99     (declare (type fixnum result))
 100     (do-external-symbols (i package)
 101       (declare (ignorable i))
 102       (incf result))
 103     result))
 104
 105 ;;; In the target Lisp, INTERN* is the primitive and INTERN is
 106 ;;; implemented in terms of it. This increases efficiency by letting
 107 ;;; us reuse a fixed-size buffer; the alternative would be
 108 ;;; particularly painful because we don't implement DYNAMIC-EXTENT. In
 109 ;;; the host Lisp, this is only used at cold load time, and we don't
 110 ;;; care as much about efficiency, so it's fine to treat the host
 111 ;;; Lisp's INTERN as primitive and implement INTERN* in terms of it.
 112 (defun intern* (nameoid length package)
 113   (intern (replace (make-string length) nameoid :end2 length) package))
 114
 115 ;;; In the target Lisp this is implemented by reading a fixed slot in
 116 ;;; the symbol. In portable ANSI Common Lisp the same criteria can be
 117 ;;; met (more slowly, and with the extra property of repeatability
 118 ;;; between runs) by just calling SXHASH.
 119 (defun symbol-hash (symbol)
 120   (declare (type symbol symbol))
 121   (sxhash symbol))
 122
 123 ;;; These functions are needed for constant-folding.
 124 (defun sb!kernel:simple-array-nil-p (object)
 125   (when (typep object 'array)
 126     (assert (not (eq (array-element-type object) nil))))
 127   nil)
 128
 129 (defun sb!kernel:%negate (number)
 130   (- number))
 131
 132 (defun sb!kernel:%single-float (number)
 133   (coerce number 'single-float))
 134
 135 (defun sb!kernel:%double-float (number)
 136   (coerce number 'double-float))
 137
 138 (defun sb!kernel:%ldb (size posn integer)
 139   (ldb (byte size posn) integer))
 140
 141 (defun sb!kernel:%dpb (newbyte size posn integer)
 142   (dpb newbyte (byte size posn) integer))
 143
 144 (defun sb!kernel:%with-array-data (array start end)
 145   (assert (typep array '(simple-array * (*))))
 146   (values array start end 0))
 147
 148 #!-alpha
 149 (defun sb!vm::ash-left-mod32 (integer amount)
 150   (ldb (byte 32 0) (ash integer amount)))
 151 #!+alpha
 152 (defun sb!vm::ash-left-mod64 (integer amount)
 153   (ldb (byte 64 0) (ash integer amount)))