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 arm64)
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)))
58