src/code/cross-modular.lisp

   1 ;;;; cross-compile-time-only replacements for modular functions;
   2 ;;;; needed for constant-folding
   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!C")
  14
  15 (defun mask-signed-field (size integer)
  16   (cond ((zerop size)
  17          0)
  18         ((logbitp (1- size) integer)
  19          (dpb integer (byte size 0) -1))
  20         (t
  21          (ldb (byte size 0) integer))))
  22
  23 #.
  24 (collect ((forms))
  25   (flet ((unsigned-definition (name lambda-list prototype width)
  26            `(defun ,name ,lambda-list
  27               (ldb (byte ,width 0) (,prototype ,@lambda-list))))
  28          (signed-definition (name lambda-list prototype width)
  29            `(defun ,name ,lambda-list
  30               (mask-signed-field ,width (,prototype ,@lambda-list)))))
  31     (flet ((do-mfuns (class)
  32              (loop for infos being each hash-value of (modular-class-funs class) using (hash-key prototype)
  33                    when (listp infos)
  34                    do (loop for info in infos
  35                             for name = (modular-fun-info-name info)
  36                             and width = (modular-fun-info-width info)
  37                             and signedp = (modular-fun-info-signedp info)
  38                             and lambda-list = (modular-fun-info-lambda-list info)
  39                             if signedp
  40                             do (forms (signed-definition name lambda-list prototype width))
  41                             else
  42                             do (forms (unsigned-definition name lambda-list prototype width))))))
  43       (do-mfuns *untagged-unsigned-modular-class*)
  44       (do-mfuns *untagged-signed-modular-class*)
  45       (do-mfuns *tagged-modular-class*)))
  46   `(progn ,@(forms)))
  47
  48 #.`
  49 (defun ,(intern (format nil "ASH-LEFT-MOD~D" sb!vm:n-machine-word-bits)
  50                 "SB!VM")
  51     (integer amount)
  52   (ldb (byte ,sb!vm:n-machine-word-bits 0) (ash integer amount)))
  53
  54 #!+(or x86 x86-64 arm)
  55 (defun sb!vm::ash-left-modfx (integer amount)
  56   (mask-signed-field (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits)
  57                      (ash integer amount)))