vm-tran.lisp 25.1 KB
Newer Older
wlott's avatar
wlott committed
1
2
3
;;; -*- Package: C; Log: C.Log -*-
;;;
;;; **********************************************************************
ram's avatar
ram committed
4
5
6
7
;;; 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
8
  "$Header: src/compiler/generic/vm-tran.lisp $")
ram's avatar
ram committed
9
;;;
wlott's avatar
wlott committed
10
11
12
13
14
15
;;; **********************************************************************
;;;
;;;    This file contains impelemtentation-dependent transforms.
;;;
;;; Written by Rob MacLachlan
;;;
wlott's avatar
wlott committed
16
(in-package "C")
17
(intl:textdomain "cmucl")
wlott's avatar
wlott committed
18
19
20
21
22

;;; 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.
;;;
23
(def-source-transform short-float-p (x) `(single-float-p ,x))
dtc's avatar
dtc committed
24
#-long-float
25
(def-source-transform long-float-p (x) `(double-float-p ,x))
wlott's avatar
wlott committed
26
27
28
29
30

(def-source-transform compiled-function-p (x)
  `(functionp ,x))

(def-source-transform char-int (x)
wlott's avatar
wlott committed
31
  `(char-code ,x))
wlott's avatar
wlott committed
32

33
#-(or sparc ppc)
34
35
(deftransform abs ((x) (rational))
  '(if (< x 0) (- x) x))
wlott's avatar
wlott committed
36

37
38
39
40
41
42
43
#+(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))))

44
45
46
47
48
49
50
51
;;; 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)))

52

pw's avatar
pw committed
53
;;;; Character support.
54
55
56
57
58
59

;;; There are really only base-chars.
;;;
(def-source-transform characterp (obj)
  `(base-char-p ,obj))

60
61

;;;; Transforms for data-vector-ref for strange array types.
62
63
64
65
66
67
68

(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)))
69
      (when (and (consp dims) (= (length dims) 1))
70
	(give-up))
71
      (let* ((el-type (array-type-specialized-element-type array-type))
72
	     (declared-type (array-type-element-type array-type))
73
74
75
76
77
78
	     (total-size (if (or (atom dims) (member '* dims))
			     '*
			     (reduce #'* dims)))
	     (vector-type `(simple-array ,(type-specifier el-type)
					 (,total-size))))
	(if (atom dims)
79
80
81
82
83
84
85
86
87
88
	    `(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)))))))
89

90
91
92
93
94
95
96
97
98
(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))
99
	   (el-type (array-type-specialized-element-type array-type))
100
	   (declared-type (array-type-element-type array-type))
101
102
103
104
105
106
107
108
	   (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)
109
110
	     (the ,(type-specifier declared-type)
	       (data-vector-ref (truly-the ,vector-type vector) index)))
111
112
113
114
	  `(multiple-value-bind (vector index)
	       (if (array-header-p array)
		   (%with-array-data array index nil)
		   (values array index))
115
116
	     (the ,(type-specifier declared-type)
	       (data-vector-ref (truly-the ,vector-type vector) index)))))))
117

118
119
120
121
122
123
(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)))
124
      (when (and (consp dims) (= (length dims) 1))
125
	(give-up))
126
      (let* ((el-type (array-type-element-type array-type))
127
	     (declared-type (array-type-element-type array-type))
128
129
130
131
132
133
134
135
136
137
138
	     (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
139
			      (the ,(type-specifier declared-type) new-value))
140
141
142
	    `(data-vector-set (truly-the ,vector-type
					 (%array-data-vector array))
			      index
143
			      (the ,(type-specifier declared-type) new-value)))))))
144

145
146
147
148
149
150
151
152
153
154
(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))
155
	   (declared-type (array-type-element-type array-type))
156
157
158
159
160
161
162
163
164
165
	   (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
166
			      (the ,(type-specifier declared-type) new-value)))
167
168
169
170
171
172
	  `(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
173
			      (the ,(type-specifier declared-type) new-value)))))))
174

175
176
177

;;; Transforms for getting at arrays of unsigned-byte n when n < 8.

178
#+nil
179
180
(macrolet
    ((frob (type bits)
181
182
183
184
185
186
187
       (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
188
189
190
			 (:little-endian '(byte ,bits (* bit ,bits)))
			 (:big-endian '(byte ,bits (- vm:word-bits
						      (* (1+ bit) ,bits)))))
191
192
193
194
195
196
		      (%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
197
			       (:little-endian '(byte ,bits (* bit ,bits)))
198
			       (:big-endian
199
200
				'(byte ,bits (- vm:word-bits
						(* (1+ bit) ,bits)))))
201
202
			    (%raw-bits vector (+ word vm:vector-data-offset)))
		       new-value)))))))
203
204
205
  (frob simple-bit-vector 1)
  (frob (simple-array (unsigned-byte 2) (*)) 2)
  (frob (simple-array (unsigned-byte 4) (*)) 4))
206
207
208
209
210


;;;; Simple string transforms:

(defconstant vector-data-bit-offset (* vm:vector-data-offset vm:word-bits))
211
(defconstant vector-data-byte-offset (* vm:vector-data-offset vm:word-bytes))
212
213
214

(deftransform subseq ((string start &optional (end nil))
		      (simple-string t &optional t))
215
216
  '(let* ((len (length string))
	  (end (if end (min end len) len))
217
218
219
	  (start (min start end))
	  (size (- end start))
	  (result (make-string size)))
220
     (declare (optimize (safety 0)))
221
222
223
224
225
226
227
228
     (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))
229
230

(deftransform copy-seq ((seq) (simple-string))
231
232
  '(let* ((len (length seq))
	  (res (make-string len)))
ram's avatar
ram committed
233
     (declare (optimize (safety 0)))
234
235
236
237
238
     (byte-bash-copy seq
		     vector-data-byte-offset
		     res
		     vector-data-byte-offset
		     (the vm::offset (* len vm:char-bytes)))
239
     res))
240
241
242
243

(deftransform replace ((string1 string2 &key (start1 0) (start2 0)
				end1 end2)
		       (simple-string simple-string &rest t))
Raymond Toy's avatar
Raymond Toy committed
244
245
246
247
248
249
250
251
252
253
254
255
256
   '(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)))
257
	(vm::byte-bash-copy string2
Raymond Toy's avatar
Raymond Toy committed
258
		       (the vm::offset
259
260
			    (+ (the vm::offset (* start2 vm:char-bytes))
			       vector-data-byte-offset))
Raymond Toy's avatar
Raymond Toy committed
261
262
		       string1
		       (the vm::offset
263
264
			    (+ (the vm::offset (* start1 vm:char-bytes))
			       vector-data-byte-offset))
Raymond Toy's avatar
Raymond Toy committed
265
266
267
268
269
		       (the vm::offset
			    (* (min (the vm::offset (- (or end1 (length string1))
						       start1))
				    (the vm::offset (- (or end2 (length string2))
						       start2)))
270
			       vm:char-bytes)))
Raymond Toy's avatar
Raymond Toy committed
271
	string1)))
272

273
274
275
276
277
;; 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.
278
279
280

(deftransform concatenate ((rtype &rest sequences)
			   (t &rest simple-string)
281
282
			   simple-string
			   :policy (< safety 3))
283
284
285
286
287
288
289
290
291
  (collect ((lets)
	    (forms)
	    (all-lengths)
	    (args))
    (dolist (seq sequences)
      (declare (ignore seq))
      (let ((n-seq (gensym))
	    (n-length (gensym)))
	(args n-seq)
292
	(lets `(,n-length (the index (* (length ,n-seq) vm:char-bytes))))
293
	(all-lengths n-length)
294
	(forms `((byte-bash-copy ,n-seq vector-data-byte-offset
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
		  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)))
313
						    vm:char-bytes))))
314
		 (declare (type index ,@(all-lengths)))
315
		 (let ((start vector-data-byte-offset))
316
317
318
319
		   ,@(nestify (forms)))
		 res))))
	result))))

320
321
322
323
324
325
326

;;;; Bit vector hackery:


;;; SIMPLE-BIT-VECTOR bit-array operations are transformed to a word loop that
;;; does 32 bits at a time.
;;;
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
(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))
346
347
		 (error (intl:gettext "Argument and/or result bit arrays not the same length:~
			 ~%  ~S~%  ~S  ~%  ~S")
348
			bit-array-1 bit-array-2 result-bit-array))))
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
	 (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))))))))))
375
376

(deftransform bit-not
377
	      ((bit-array result-bit-array)
378
379
380
381
	       (simple-bit-vector simple-bit-vector) *
	       :node node  :policy (>= speed space))
  `(progn
     ,@(unless (policy node (zerop safety))
382
	 '((unless (= (length bit-array)
383
		      (length result-bit-array))
384
385
	     (error (intl:gettext "Argument and result bit arrays not the same length:~
	     	     ~%  ~S~%  ~S")
386
		    bit-array result-bit-array))))
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
    (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))))))))
408

409
410
411
(deftransform count ((item sequence) (bit simple-bit-vector) *
                     :policy (>= speed space))
  `(let ((length (length sequence)))
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
     (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))))))))
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462

;;;; 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 (*))
463
464
465
	     (copy-from-system-area src src-start
				    dst (+ dst-start vector-data-bit-offset)
				    length))))
466
467
468
	 ((simple-unboxed-array (*))
	  (etypecase dst
	    (system-area-pointer
469
470
471
	     (copy-to-system-area src (+ src-start vector-data-bit-offset)
				  dst dst-start
				  length))
472
	    ((simple-unboxed-array (*))
473
474
475
	     (bit-bash-copy src (+ src-start vector-data-bit-offset)
			    dst (+ dst-start vector-data-bit-offset)
			    length))))))))
476
477
478
479
480

;;;; SXHASH:

;;; Should be in VM:

481
482
483
(defconstant sxhash-bits-byte (byte 29 0))
(defconstant sxmash-total-bits 29)
(defconstant sxmash-rotate-bits 9)
484
485
486
487
488
489
490

(deftransform sxhash ((s-expr) (integer))
  '(ldb sxhash-bits-byte s-expr))

(deftransform sxhash ((s-expr) (simple-string))
  '(%sxhash-simple-string s-expr))

491
#-(or sparc x86 amd64 ppc)
492
(deftransform sxhash ((s-expr) (symbol))
ram's avatar
ram committed
493
  '(%sxhash-simple-string (symbol-name s-expr)))
494

495
#+(or sparc x86 amd64 ppc)
496
(deftransform sxhash ((s-expr) (symbol))
497
  ;; Pick off the constant case first. (Important!)
498
499
500
  (if (constant-continuation-p s-expr)
      (sxhash (continuation-value s-expr))
      '(let ((result (symbol-hash s-expr)))
501
502
503
	;; 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.
504
505
	(if (<= result 0)
	    (let ((sxhash (%sxhash-simple-string (symbol-name s-expr))))
506
	      ;; If 0 is the uninitialized indicator, should we make
507
508
	      ;; sure we never store 0 into this slot?  It would be
	      ;; pretty bad if it that happens.
509
510
511
512
513
	      (%set-symbol-hash s-expr sxhash)
	      sxhash)
	    result))))


514
515

(deftransform sxhash ((s-expr) (single-float))
516
  '(let ((bits (single-float-bits (+ 0f0 s-expr))))
517
     (ldb sxhash-bits-byte
518
	  (logxor (ash bits (- sxmash-rotate-bits)) bits))))
519
520

(deftransform sxhash ((s-expr) (double-float))
521
522
  '(let* ((lo (double-float-low-bits (+ 0d0 s-expr)))
	  (hi (double-float-high-bits (+ 0d0 s-expr))))
523
     (ldb sxhash-bits-byte
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
	  (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))))))
540
541
542
543
544
545
546
547
548
549


;;;; 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))))
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600

;;; 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)))
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768


;;; 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))))))