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