;;; -*- Package: C; Log: C.Log -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/compiler/generic/vm-tran.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; This file contains impelemtentation-dependent transforms. ;;; ;;; Written by Rob MacLachlan ;;; (in-package "C") (intl:textdomain "cmucl") ;;; We need to define these predicates, since the TYPEP source transform picks ;;; whichever predicate was defined last when there are multiple predicates for ;;; equivalent types. ;;; (def-source-transform short-float-p (x) `(single-float-p ,x)) #-long-float (def-source-transform long-float-p (x) `(double-float-p ,x)) (def-source-transform compiled-function-p (x) `(functionp ,x)) (def-source-transform char-int (x) `(char-code ,x)) #-(or sparc ppc) (deftransform abs ((x) (rational)) '(if (< x 0) (- x) x)) #+(or sparc ppc) (deftransform abs ((x) (rational)) (let ((x-type (continuation-type x))) (if (csubtypep x-type (specifier-type '(signed-byte #.vm:word-bits))) (give-up) '(if (< x 0) (- x) x)))) ;;; For now, the layout is stored in slot 0. ;;; (def-source-transform %instance-layout (x) `(truly-the layout (%instance-ref ,x 0))) ;;; (def-source-transform %set-instance-layout (x val) `(%instance-set ,x 0 (the layout ,val))) ;;;; Character support. ;;; There are really only base-chars. ;;; (def-source-transform characterp (obj) `(base-char-p ,obj)) ;;;; Transforms for data-vector-ref for strange array types. (deftransform data-vector-ref ((array index) (simple-array t)) (let ((array-type (continuation-type array))) (unless (array-type-p array-type) (give-up)) (let ((dims (array-type-dimensions array-type))) (when (and (consp dims) (= (length dims) 1)) (give-up)) (let* ((el-type (array-type-specialized-element-type array-type)) (declared-type (array-type-element-type array-type)) (total-size (if (or (atom dims) (member '* dims)) '* (reduce #'* dims))) (vector-type `(simple-array ,(type-specifier el-type) (,total-size)))) (if (atom dims) `(the ,(type-specifier declared-type) (data-vector-ref (truly-the ,vector-type (if (array-header-p array) (%array-data-vector array) array)) index)) `(the ,(type-specifier declared-type) (data-vector-ref (truly-the ,vector-type (%array-data-vector array)) index))))))) (deftransform data-vector-ref ((array index) (array t) * :node node :policy (> speed space)) (let ((array-type (continuation-type array))) (unless (and (array-type-p array-type) (array-type-complexp array-type) (not (eq (array-type-specialized-element-type array-type) *wild-type*))) (give-up)) (delay-transform node :optimize) (let* ((dims (array-type-dimensions array-type)) (el-type (array-type-specialized-element-type array-type)) (declared-type (array-type-element-type array-type)) (total-size (if (or (atom dims) (member '* dims)) '* (reduce #'* dims))) (vector-type `(simple-array ,(type-specifier el-type) (,total-size)))) (if (and (consp dims) (> (length dims) 1)) `(multiple-value-bind (vector index) (%with-array-data array index nil) (the ,(type-specifier declared-type) (data-vector-ref (truly-the ,vector-type vector) index))) `(multiple-value-bind (vector index) (if (array-header-p array) (%with-array-data array index nil) (values array index)) (the ,(type-specifier declared-type) (data-vector-ref (truly-the ,vector-type vector) index))))))) (deftransform data-vector-set ((array index new-value) (simple-array t t)) (let ((array-type (continuation-type array))) (unless (array-type-p array-type) (give-up)) (let ((dims (array-type-dimensions array-type))) (when (and (consp dims) (= (length dims) 1)) (give-up)) (let* ((el-type (array-type-element-type array-type)) (declared-type (array-type-element-type array-type)) (total-size (if (or (atom dims) (member '* dims)) '* (reduce #'* dims))) (vector-type `(simple-array ,(type-specifier el-type) (,total-size)))) (if (atom dims) `(data-vector-set (truly-the ,vector-type (if (array-header-p array) (%array-data-vector array) array)) index (the ,(type-specifier declared-type) new-value)) `(data-vector-set (truly-the ,vector-type (%array-data-vector array)) index (the ,(type-specifier declared-type) new-value))))))) (deftransform data-vector-set ((array index new-value) (array t t) * :node node :policy (> speed space)) (let ((array-type (continuation-type array))) (unless (and (array-type-p array-type) (array-type-complexp array-type) (not (eq (array-type-specialized-element-type array-type) *wild-type*))) (give-up)) (delay-transform node :optimize) (let* ((dims (array-type-dimensions array-type)) (el-type (array-type-element-type array-type)) (declared-type (array-type-element-type array-type)) (total-size (if (or (atom dims) (member '* dims)) '* (reduce #'* dims))) (vector-type `(simple-array ,(type-specifier el-type) (,total-size)))) (if (and (consp dims) (> (length dims) 1)) `(multiple-value-bind (vector index) (%with-array-data array index nil) (data-vector-set (truly-the ,vector-type vector) index (the ,(type-specifier declared-type) new-value))) `(multiple-value-bind (vector index) (if (array-header-p array) (%with-array-data array index nil) (values array index)) (data-vector-set (truly-the ,vector-type vector) index (the ,(type-specifier declared-type) new-value))))))) ;;; Transforms for getting at arrays of unsigned-byte n when n < 8. #+nil (macrolet ((frob (type bits) (let ((elements-per-word (truncate vm:word-bits bits))) `(progn (deftransform data-vector-ref ((vector index) (,type *)) `(multiple-value-bind (word bit) (floor index ,',elements-per-word) (ldb ,(ecase vm:target-byte-order (:little-endian '(byte ,bits (* bit ,bits))) (:big-endian '(byte ,bits (- vm:word-bits (* (1+ bit) ,bits))))) (%raw-bits vector (+ word vm:vector-data-offset))))) (deftransform data-vector-set ((vector index new-value) (,type * *)) `(multiple-value-bind (word bit) (floor index ,',elements-per-word) (setf (ldb ,(ecase vm:target-byte-order (:little-endian '(byte ,bits (* bit ,bits))) (:big-endian '(byte ,bits (- vm:word-bits (* (1+ bit) ,bits))))) (%raw-bits vector (+ word vm:vector-data-offset))) new-value))))))) (frob simple-bit-vector 1) (frob (simple-array (unsigned-byte 2) (*)) 2) (frob (simple-array (unsigned-byte 4) (*)) 4)) ;;;; Simple string transforms: (defconstant vector-data-bit-offset (* vm:vector-data-offset vm:word-bits)) (defconstant vector-data-byte-offset (* vm:vector-data-offset vm:word-bytes)) (deftransform subseq ((string start &optional (end nil)) (simple-string t &optional t)) '(let* ((len (length string)) (end (if end (min end len) len)) (start (min start end)) (size (- end start)) (result (make-string size))) (declare (optimize (safety 0))) (byte-bash-copy string (the vm::offset (+ (the vm::offset (* start vm:char-bytes)) vector-data-byte-offset)) result vector-data-byte-offset (the vm::offset (* size vm:char-bytes))) result)) (deftransform copy-seq ((seq) (simple-string)) '(let* ((len (length seq)) (res (make-string len))) (declare (optimize (safety 0))) (byte-bash-copy seq vector-data-byte-offset res vector-data-byte-offset (the vm::offset (* len vm:char-bytes))) res)) (deftransform replace ((string1 string2 &key (start1 0) (start2 0) end1 end2) (simple-string simple-string &rest t)) '(progn ;; Make sure the indices make sense before we go bashing bits ;; around! (assert (<= 0 start1)) (assert (<= start1 (or end1 (length string1)))) (assert (<= (or end1 (length string1)) (length string1))) (assert (<= 0 start2)) (assert (<= start2 (or end2 (length string2)))) (assert (<= (or end2 (length string2)) (length string2))) (locally (declare (optimize (safety 0))) (vm::byte-bash-copy string2 (the vm::offset (+ (the vm::offset (* start2 vm:char-bytes)) vector-data-byte-offset)) string1 (the vm::offset (+ (the vm::offset (* start1 vm:char-bytes)) vector-data-byte-offset)) (the vm::offset (* (min (the vm::offset (- (or end1 (length string1)) start1)) (the vm::offset (- (or end2 (length string2)) start2))) vm:char-bytes))) string1))) ;; The original version of this deftransform seemed to cause the ;; compiler to spend huge amounts of time deriving the type of the ;; START variable. The following version uses nested lets to prevent ;; the compiler from doing this analysis. This only hides the ;; symptom. (deftransform concatenate ((rtype &rest sequences) (t &rest simple-string) simple-string :policy (< safety 3)) (collect ((lets) (forms) (all-lengths) (args)) (dolist (seq sequences) (declare (ignore seq)) (let ((n-seq (gensym)) (n-length (gensym))) (args n-seq) (lets `(,n-length (the index (* (length ,n-seq) vm:char-bytes)))) (all-lengths n-length) (forms `((byte-bash-copy ,n-seq vector-data-byte-offset res start ,n-length) (start (+ start ,n-length)))))) (flet ((nestify (lists) (let* ((lists (reverse lists)) (result `(,(caar lists)))) (dolist (item (rest lists)) (destructuring-bind (bit-bash init) item (setf result `(,bit-bash (let (,init) ,@result))))) result))) (let ((result `(lambda (rtype ,@(args)) (declare (ignore rtype)) (let* (,@(lets) (res (make-string (truncate (the index (+ ,@(all-lengths))) vm:char-bytes)))) (declare (type index ,@(all-lengths))) (let ((start vector-data-byte-offset)) ,@(nestify (forms))) res)))) result)))) ;;;; Bit vector hackery: ;;; SIMPLE-BIT-VECTOR bit-array operations are transformed to a word loop that ;;; does 32 bits at a time. ;;; (dolist (x '((bit-and 32bit-logical-and) (bit-ior 32bit-logical-or) (bit-xor 32bit-logical-xor) (bit-eqv 32bit-logical-eqv) (bit-nand 32bit-logical-nand) (bit-nor 32bit-logical-nor) (bit-andc1 32bit-logical-andc1) (bit-andc2 32bit-logical-andc2) (bit-orc1 32bit-logical-orc1) (bit-orc2 32bit-logical-orc2))) (destructuring-bind (bitfun wordfun) x (deftransform bitfun ((bit-array-1 bit-array-2 result-bit-array) '(simple-bit-vector simple-bit-vector simple-bit-vector) '* :eval-name t :node node :policy (>= speed space)) `(progn ,@(unless (policy node (zerop safety)) '((unless (= (length bit-array-1) (length bit-array-2) (length result-bit-array)) (error (intl:gettext "Argument and/or result bit arrays not the same length:~ ~% ~S~% ~S ~% ~S") bit-array-1 bit-array-2 result-bit-array)))) (let ((length (length result-bit-array))) (if (= length 0) ;; We avoid doing anything to 0-length ;; bit-vectors, or rather, the memory that ;; follows them. Other divisible-by-32 cases ;; are handled by the (1- length), below. ;; CSR, 2002-04-24 result-bit-array (do ((index vm:vector-data-offset (1+ index)) (end-1 (+ vm:vector-data-offset ;; bit-vectors of length 1-32 ;; need precisely one (SETF ;; %RAW-BITS), done in the ;; epilogue. - CSR, 2002-04-24 (truncate (truly-the index (1- length)) vm:word-bits)))) ((= index end-1) (setf (%raw-bits result-bit-array index) (,wordfun (%raw-bits bit-array-1 index) (%raw-bits bit-array-2 index))) result-bit-array) (declare (optimize (speed 3) (safety 0)) (type index index end-1)) (setf (%raw-bits result-bit-array index) (,wordfun (%raw-bits bit-array-1 index) (%raw-bits bit-array-2 index)))))))))) (deftransform bit-not ((bit-array result-bit-array) (simple-bit-vector simple-bit-vector) * :node node :policy (>= speed space)) `(progn ,@(unless (policy node (zerop safety)) '((unless (= (length bit-array) (length result-bit-array)) (error (intl:gettext "Argument and result bit arrays not the same length:~ ~% ~S~% ~S") bit-array result-bit-array)))) (let ((length (length result-bit-array))) (if (= length 0) ;; We avoid doing anything to 0-length bit-vectors, or ;; rather, the memory that follows them. Other ;; divisible-by-32 cases are handled by the (1- length), ;; below. CSR, 2002-04-24 result-bit-array (do ((index vm:vector-data-offset (1+ index)) (end-1 (+ vm:vector-data-offset ;; bit-vectors of length 1-32 need precisely ;; one (SETF %RAW-BITS), done in the epilogue. (truncate (truly-the index (1- length)) vm:word-bits)))) ((= index end-1) (setf (%raw-bits result-bit-array index) (32bit-logical-not (%raw-bits bit-array index))) result-bit-array) (declare (optimize (speed 3) (safety 0)) (type index index end-1)) (setf (%raw-bits result-bit-array index) (32bit-logical-not (%raw-bits bit-array index)))))))) (deftransform count ((item sequence) (bit simple-bit-vector) * :policy (>= speed space)) `(let ((length (length sequence))) (if (zerop length) 0 (multiple-value-bind (nwords extra) (truncate (truly-the index length) vm:word-bits) ;; This loop counts the number of 1 bits in whole words (do ((index vm:vector-data-offset (1+ index)) (count 0) (end (+ vm:vector-data-offset nwords))) ((= index end) (let ((ones ;; Count the number of one bits in the last ;; word, if any, masking off any junk bits. (if (zerop extra) count (let* ((bits (ldb (byte extra ,(ecase (c:backend-byte-order c:*target-backend*) (:little-endian 0) (:big-endian '(- vm:word-bits extra)))) (%raw-bits sequence index)))) (incf count (logcount bits)))))) ;; If we're counting ones, the we're done. If we're ;; counting zeroes, we need to subtract the number ;; of ones from the length, obviously. ,(if (constant-continuation-p item) (if (zerop (continuation-value item)) '(- length ones) 'ones) '(if (zerop item) (- length ones) ones)))) (declare (type index index count end) (optimize (speed 3) (safety 0))) (incf count (logcount (%raw-bits sequence index)))))))) ;;;; Primitive translator for byte-blt (def-primitive-translator byte-blt (src src-start dst dst-start dst-end) `(let ((src ,src) (src-start (* ,src-start vm:byte-bits)) (dst ,dst) (dst-start (* ,dst-start vm:byte-bits)) (dst-end (* ,dst-end vm:byte-bits))) (let ((length (- dst-end dst-start))) (etypecase src (system-area-pointer (etypecase dst (system-area-pointer (system-area-copy src src-start dst dst-start length)) ((simple-unboxed-array (*)) (copy-from-system-area src src-start dst (+ dst-start vector-data-bit-offset) length)))) ((simple-unboxed-array (*)) (etypecase dst (system-area-pointer (copy-to-system-area src (+ src-start vector-data-bit-offset) dst dst-start length)) ((simple-unboxed-array (*)) (bit-bash-copy src (+ src-start vector-data-bit-offset) dst (+ dst-start vector-data-bit-offset) length)))))))) ;;;; SXHASH: ;;; Should be in VM: (defconstant sxhash-bits-byte (byte 29 0)) (defconstant sxmash-total-bits 29) (defconstant sxmash-rotate-bits 9) (deftransform sxhash ((s-expr) (integer)) '(ldb sxhash-bits-byte s-expr)) (deftransform sxhash ((s-expr) (simple-string)) '(%sxhash-simple-string s-expr)) #-(or sparc x86 amd64 ppc) (deftransform sxhash ((s-expr) (symbol)) '(%sxhash-simple-string (symbol-name s-expr))) #+(or sparc x86 amd64 ppc) (deftransform sxhash ((s-expr) (symbol)) ;; Pick off the constant case first. (Important!) (if (constant-continuation-p s-expr) (sxhash (continuation-value s-expr)) '(let ((result (symbol-hash s-expr))) ;; A 0 in the symbol-hash slot means uninitialized. We should ;; probably use -1 instead, once we make sure that NIL doesn't ;; have a negative hash value. (if (<= result 0) (let ((sxhash (%sxhash-simple-string (symbol-name s-expr)))) ;; If 0 is the uninitialized indicator, should we make ;; sure we never store 0 into this slot? It would be ;; pretty bad if it that happens. (%set-symbol-hash s-expr sxhash) sxhash) result)))) (deftransform sxhash ((s-expr) (single-float)) '(let ((bits (single-float-bits (+ 0f0 s-expr)))) (ldb sxhash-bits-byte (logxor (ash bits (- sxmash-rotate-bits)) bits)))) (deftransform sxhash ((s-expr) (double-float)) '(let* ((lo (double-float-low-bits (+ 0d0 s-expr))) (hi (double-float-high-bits (+ 0d0 s-expr)))) (ldb sxhash-bits-byte (logxor (ash lo (- sxmash-rotate-bits)) lo (ldb sxhash-bits-byte (logxor (ash hi (- sxmash-rotate-bits)) hi)))))) #+long-float (deftransform sxhash ((s-expr) (long-float)) '(let* ((lo (long-float-low-bits s-expr)) #+sparc (mid (long-float-mid-bits s-expr)) (hi (long-float-high-bits s-expr)) (exp (long-float-exp-bits s-expr))) (ldb sxhash-bits-byte (logxor (ash lo (- sxmash-rotate-bits)) lo #+sparc (ash mid (- sxmash-rotate-bits)) #+sparc mid (ash hi (- sxmash-rotate-bits)) hi (ldb sxhash-bits-byte (logxor (ash exp (- sxmash-rotate-bits)) exp)))))) ;;;; Float EQL transforms. (deftransform eql ((x y) (single-float single-float)) '(= (single-float-bits x) (single-float-bits y))) (deftransform eql ((x y) (double-float double-float)) '(and (= (double-float-low-bits x) (double-float-low-bits y)) (= (double-float-high-bits x) (double-float-high-bits y)))) ;;; There are two different ways the multiplier can be recoded. The ;;; more obvious is to shift X by the correct amount for each bit set ;;; in Y and to sum the results. But if there is a string of bits that ;;; are all set, you can add X shifted by one more then the bit ;;; position of the first set bit and subtract X shifted by the bit ;;; position of the last set bit. We can't use this second method when ;;; the high order bit is bit 31 because shifting by 32 doesn't work ;;; too well. (defun strength-reduce-constant-multiply (arg num) (declare (type (unsigned-byte 32) num)) (let ((adds 0) (shifts 0) (result nil) first-one) (labels ((add (next-factor) (setf result (if result (progn (incf adds) `(+ ,result ,next-factor)) next-factor)))) (declare (inline add)) (dotimes (bitpos 32) (if first-one (when (not (logbitp bitpos num)) (add (if (= (1+ first-one) bitpos) ;; There is only a single bit in the string. (progn (incf shifts) `(ash ,arg ,first-one)) ;; There are at least two. (progn (incf adds) (incf shifts 2) `(- (ash ,arg ,bitpos) (ash ,arg ,first-one))))) (setf first-one nil)) (when (logbitp bitpos num) (setf first-one bitpos)))) (when first-one (cond ((= first-one 31)) ((= first-one 30) (incf shifts) (add `(ash ,arg 30))) (t (incf shifts 2) (incf adds) (add `(- (ash ,arg 31) (ash ,arg ,first-one))))) (incf shifts) (add `(ash ,arg 31)))) (values (if (plusp adds) `(logand ,result #.(1- (ash 1 32))) ; using modular arithmetic result) adds shifts))) ;;; Support routines for division by multiplication. ;; Truncating division by multiplication ;; ;; This is taken from Hacker's Delight, by Henry S. Warren. This ;; book describes how to do a truncating division by doing a ;; multiplication instead. ;; ;; We refer the reader to that book for a full description and proof ;; of the algorithm. We summarize the basic ideas here. ;; ;; Let W be the word size in bits and d be the known divisor, 2 <= d ;; < 2^(W-1). We wish to find the least integer m and integer p such ;; that ;; ;; floor(m*n/2^p) = floor(n/d) for 0 <= n < 2^(W-1) ;; ;; and ;; ;; floor(m*n/2^p) + 1 = floor(n/d) for -2^(W-1) <= n <= -1 ;; ;; for 0 <= m < 2^W and p >= W. ;; ;; This is found by the following algorithm. ;; ;; Compute ;; ;; nc = floor(2^(W-1)/d)*d - 1 = 2^(W-1) - rem(2^(W-1), d) - 1. ;; ;; Then find p >= W such that ;; ;; 2^p > nc * (d - rem(2^p, d) ;; ;; This gives ;; ;; m = (2^p - d - rem(2^p, d))/d ;; ;; From m we compute the desired multiplier, M, because in some cases ;; m will not fit in a signed W-bit word. Hence, ;; ;; { m, if 0 <= m < 2^(W-1) ;; M = { ;; { m - 2^W, if 2^(W-1) <= m < 2^W ;; ;; Then the basic algorithm is to compute ;; ;; floor(m*n/2^p) = floor((m*n/2^W)/2^(p-W)) ;; ;; When m is too large, we compute ;; ;; (m*n/2^W) = ((m - 2^W + 2^W)*n/2^W) ;; = (m - 2^W)*n/2^W + n ;; = M*n/2^W + n ;; and (m - 2^W) fits in a W-bit word. ;; ;; And we're done. ;; ;; For example: ;; ;; d M s = p - W ;; ------------------------------------ ;; 3 #x55555556 0 ;; 5 #x66666667 1 ;; 7 #x-6DB6DB6D 2 ;; 100 #x51EB851F 5 ;; ;; Finally, we note that if n is negative, we can easily add 1 to ;; floor(m*n/p) without branches. Let t = n >> (- (W - 1)). That ;; is, t = -1 if n is negative and t = 0 if n is positive. ;; ;; Then subtract t from floor(m*n/p). (Note that the example machine ;; code in Hacker's delight is wrong. It adds t instead of ;; subtracting t. ;; Find the magic number for the divisor DIVISOR assuming a word size ;; of WORD-WIDTH bits. We return the (signed) magic number M and s = ;; p - W. (defun find-signed-reciprocal (divisor &optional (word-width vm:word-bits)) (let ((nc (1- (* divisor (floor (ash 1 (1- word-width)) divisor))))) ;; Find p (do ((p word-width (1+ p))) ((> (ash 1 p) (* nc (- divisor (rem (ash 1 p) divisor)))) (let ((m (/ (- (+ (ash 1 p) divisor) (rem (ash 1 p) divisor)) divisor))) (values (if (< m (ash 1 (1- word-width))) m (- m (ash 1 word-width))) (- p word-width)))) ))) ;; Unsigned division is a bit more complicated. We can't just use ;; the above results to get the correct unsigned division. ;; ;; Using the same notation, we want to find m and p such that ;; ;; floor(m*n/2^p) = floor(n/d) for 0 <= n < 2^W. ;; ;; with 0 <= m < 2^(W+1) and p >= W. ;; ;; First compute ;; ;; nc = floor(2^W/d)*d - 1 = 2^W - rem(2^W,d) - 1 ;; ;; Then find p such that ;; ;; 2^p > nc * (d - 1 - rem(2^p - 1, d)) ;; ;; and m is ;; ;; m = (2^p + d - 1 - rem(2^p - 1, d))/d ;; ;; If m fits in a word, the multiplier M = m. However, if m cannot ;; fit in a word, we set the multiplier M to be m - 2^W, which needs ;; to be adjusted. ;; ;; So, ;; floor(m*n/2^W/2^s) = floor((m - 2^W + 2^W)*n/2^W/2^s) ;; = floor([(m - 2^W)*n/2^W + n]/2^s) ;; = floor([M*n/2^W + n]/2^s) ;; ;; We would be done, except the sum can overflow. If the architecture ;; has an instruction that can shift the carry bit into the MSB during ;; a right shift, then we are done. If the architecture does not, we ;; can use the following approach. ;; ;; floor((q+n)/2^p) = floor(z/2^(p-1)), p >= 1 ;; ;; where ;; ;; z = floor((n-q)/2) + q ;; ;; This requires that p >= 1, but it can be shown that if d > 1, and ;; if m >= 2^W, then p >= 1. ;; ;; Some examples ;; ;; d M s = p - W overflow ;; ------------------------------------ ;; 3 #xaaaaaaab 1 NIL ;; 5 #xcccccccd 2 NIL ;; 7 #x24924925 3 T ;; 100 #x51eb851f 5 NIL ;; ;; where the overflow column indicates if we m is too large to fit in ;; a word ;; Compute M, s, and overflow as indicated above. (defun find-unsigned-reciprocal (divisor &optional (word-width vm:word-bits)) (let ((nc (1- (* divisor (floor (ash 1 word-width) divisor))))) ;; Find p (do ((p word-width (1+ p))) ((> (ash 1 p) (* nc (- divisor 1 (rem (1- (ash 1 p)) divisor)))) (let* ((m (/ (- (+ (ash 1 p) divisor) (rem (ash 1 p) divisor)) divisor)) (overflowp (>= m (ash 1 word-width)))) (values (if overflowp (- m (ash 1 word-width)) m) (- p word-width) overflowp))))))