Newer
Older
;;; -*- 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.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.38 1992/08/05 00:27:15 ram Exp $")
;;; **********************************************************************
;;;
;;; This file contains macro-like source transformations which convert
;;; uses of certain functions into the canonical form desired within the
;;; compiler. ### and other IR1 transforms and stuff. Some code adapted from
;;; CLC, written by Wholey and Fahlman.
;;;
;;; Written by Rob MacLachlan
;;;
;;; Source transform for Not, Null -- Internal
;;;
;;; Convert into an IF so that IF optimizations will eliminate redundant
;;; negations.
;;;
(def-source-transform not (x) `(if ,x nil t))
(def-source-transform null (x) `(if ,x nil t))
;;; Source transform for Endp -- Internal
;;;
;;; Endp is just NULL with a List assertion.
;;;
(def-source-transform endp (x) `(null (the list ,x)))
;;; We turn Identity into Prog1 so that it is obvious that it just returns the
;;; first value of its argument. Ditto for Values with one arg.
(def-source-transform identity (x) `(prog1 ,x))
(def-source-transform values (x) `(prog1 ,x))
;;; CONSTANTLY source transform -- Internal
;;;
;;; Bind the values and make a closure that returns them.
;;;
(def-source-transform constantly (value &rest values)
(let ((temps (loop repeat (1+ (length values))
collect (gensym)))
(dum (gensym)))
`(let ,(loop for temp in temps and
value in (list* value values)
collect `(,temp ,value))
#'(lambda (&rest ,dum)
(declare (ignore ,dum))
(values ,@temps)))))
;;; COMPLEMENT IR1 transform -- Internal
;;;
;;; If the function has a known number of arguments, then return a lambda
;;; with the appropriate fixed number of args. If the destination is a
;;; FUNCALL, then do the &REST APPLY thing, and let MV optimization figure
;;; things out.
;;;
(deftransform complement ((fun) * * :node node)
(multiple-value-bind (min max)
(function-type-nargs (continuation-type fun))
(cond
((and min (eql min max))
(let ((dums (loop repeat min collect (gensym))))
`#'(lambda ,dums (not (funcall fun ,@dums)))))
((let* ((cont (node-cont node))
(dest (continuation-dest cont)))
(and (combination-p dest)
(eq (combination-fun dest) cont)))
'#'(lambda (&rest args)
(not (apply fun args))))
(t
(give-up "Function doesn't have fixed argument count.")))))
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
;;;; List hackery:
;;;
;;; Translate CxxR into car/cdr combos.
(def-source-transform caar (x) `(car (car ,x)))
(def-source-transform cadr (x) `(car (cdr ,x)))
(def-source-transform cdar (x) `(cdr (car ,x)))
(def-source-transform cddr (x) `(cdr (cdr ,x)))
(def-source-transform caaar (x) `(car (car (car ,x))))
(def-source-transform caadr (x) `(car (car (cdr ,x))))
(def-source-transform cadar (x) `(car (cdr (car ,x))))
(def-source-transform caddr (x) `(car (cdr (cdr ,x))))
(def-source-transform cdaar (x) `(cdr (car (car ,x))))
(def-source-transform cdadr (x) `(cdr (car (cdr ,x))))
(def-source-transform cddar (x) `(cdr (cdr (car ,x))))
(def-source-transform cdddr (x) `(cdr (cdr (cdr ,x))))
(def-source-transform caaaar (x) `(car (car (car (car ,x)))))
(def-source-transform caaadr (x) `(car (car (car (cdr ,x)))))
(def-source-transform caadar (x) `(car (car (cdr (car ,x)))))
(def-source-transform caaddr (x) `(car (car (cdr (cdr ,x)))))
(def-source-transform cadaar (x) `(car (cdr (car (car ,x)))))
(def-source-transform cadadr (x) `(car (cdr (car (cdr ,x)))))
(def-source-transform caddar (x) `(car (cdr (cdr (car ,x)))))
(def-source-transform cadddr (x) `(car (cdr (cdr (cdr ,x)))))
(def-source-transform cdaaar (x) `(cdr (car (car (car ,x)))))
(def-source-transform cdaadr (x) `(cdr (car (car (cdr ,x)))))
(def-source-transform cdadar (x) `(cdr (car (cdr (car ,x)))))
(def-source-transform cdaddr (x) `(cdr (car (cdr (cdr ,x)))))
(def-source-transform cddaar (x) `(cdr (cdr (car (car ,x)))))
(def-source-transform cddadr (x) `(cdr (cdr (car (cdr ,x)))))
(def-source-transform cdddar (x) `(cdr (cdr (cdr (car ,x)))))
(def-source-transform cddddr (x) `(cdr (cdr (cdr (cdr ,x)))))
;;;
;;; Turn First..Fourth and Rest into the obvious synonym, assuming whatever is
;;; right for them is right for us. Fifth..Tenth turn into Nth, which can be
;;; expanded into a car/cdr later on if policy favors it.
(def-source-transform first (x) `(car ,x))
(def-source-transform rest (x) `(cdr ,x))
(def-source-transform second (x) `(cadr ,x))
(def-source-transform third (x) `(caddr ,x))
(def-source-transform fourth (x) `(cadddr ,x))
(def-source-transform fifth (x) `(nth 4 ,x))
(def-source-transform sixth (x) `(nth 5 ,x))
(def-source-transform seventh (x) `(nth 6 ,x))
(def-source-transform eighth (x) `(nth 7 ,x))
(def-source-transform ninth (x) `(nth 8 ,x))
(def-source-transform tenth (x) `(nth 9 ,x))
;;;
;;; Translate RPLACx to LET and SETF.
(def-source-transform rplaca (x y)
(once-only ((n-x x))
`(progn
(setf (car ,n-x) ,y)
,n-x)))
;;;
(def-source-transform rplacd (x y)
(once-only ((n-x x))
`(progn
(setf (cdr ,n-x) ,y)
,n-x)))
(def-source-transform nth (n l) `(car (nthcdr ,n ,l)))
(defvar *default-nthcdr-open-code-limit* 6)
(defvar *extreme-nthcdr-open-code-limit* 20)
(deftransform nthcdr ((n l) (unsigned-byte t) * :node node)
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
(unless (constant-continuation-p n) (give-up))
(let ((n (continuation-value n)))
(when (> n
(if (policy node (= speed 3) (= space 0))
*extreme-nthcdr-open-code-limit*
*default-nthcdr-open-code-limit*))
(give-up))
(labels ((frob (n)
(if (zerop n)
'l
`(cdr ,(frob (1- n))))))
(frob n))))
;;;; ARITHMETIC and NUMEROLOGY.
(def-source-transform plusp (x) `(> ,x 0))
(def-source-transform minusp (x) `(< ,x 0))
(def-source-transform zerop (x) `(= ,x 0))
(def-source-transform 1+ (x) `(+ ,x 1))
(def-source-transform 1- (x) `(- ,x 1))
(def-source-transform oddp (x) `(not (zerop (logand ,x 1))))
(def-source-transform evenp (x) `(zerop (logand ,x 1)))
;;; Note that all the integer division functions are available for inline
;;; expansion.
(macrolet ((frob (fun)
`(def-source-transform ,fun (x &optional (y nil y-p))
(declare (ignore y))
(if y-p
(values nil t)
`(,',fun ,x 1)))))
(frob truncate)
(frob round))
(def-source-transform lognand (x y) `(lognot (logand ,x ,y)))
(def-source-transform lognor (x y) `(lognot (logior ,x ,y)))
(def-source-transform logandc1 (x y) `(logand (lognot ,x) ,y))
(def-source-transform logandc2 (x y) `(logand ,x (lognot ,y)))
(def-source-transform logorc1 (x y) `(logior (lognot ,x) ,y))
(def-source-transform logorc2 (x y) `(logior ,x (lognot ,y)))
(def-source-transform logtest (x y) `(not (zerop (logand ,x ,y))))
(def-source-transform logbitp (index integer)
`(not (zerop (logand (ash 1 ,index) ,integer))))
(def-source-transform byte (size position) `(cons ,size ,position))
(def-source-transform byte-size (spec) `(car ,spec))
(def-source-transform byte-position (spec) `(cdr ,spec))
(def-source-transform ldb-test (bytespec integer)
`(not (zerop (mask-field ,bytespec ,integer))))
;;; With the ratio and complex accessors, we pick off the "identity" case, and
;;; use a primitive to handle the cell access case.
;;;
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
(def-source-transform numerator (num)
(once-only ((n-num `(the rational ,num)))
`(if (ratiop ,n-num)
(%primitive numerator ,n-num)
,n-num)))
;;;
(def-source-transform denominator (num)
(once-only ((n-num `(the rational ,num)))
`(if (ratiop ,n-num)
(%primitive denominator ,n-num)
1)))
;;;
(def-source-transform realpart (num)
(once-only ((n-num num))
`(if (complexp ,n-num)
(%primitive realpart ,n-num)
,n-num)))
;;;
(def-source-transform imagpart (num)
(once-only ((n-num num))
`(cond ((complexp ,n-num)
(%primitive imagpart ,n-num))
((floatp ,n-num)
(float 0 ,n-num))
(t
0))))
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
;;;; Numeric Derive-Type methods:
;;; Derive-Integer-Type -- Internal
;;;
;;; Utility for defining derive-type methods of integer operations. If the
;;; types of both X and Y are integer types, then we compute a new integer type
;;; with bounds determined Fun when applied to X and Y. Otherwise, we use
;;; Numeric-Contagion.
;;;
(defun derive-integer-type (x y fun)
(declare (type continuation x y) (type function fun))
(let ((x (continuation-type x))
(y (continuation-type y)))
(if (and (numeric-type-p x) (numeric-type-p y)
(eq (numeric-type-class x) 'integer)
(eq (numeric-type-class y) 'integer)
(eq (numeric-type-complexp x) :real)
(eq (numeric-type-complexp y) :real))
(multiple-value-bind (low high)
(funcall fun x y)
(make-numeric-type :class 'integer :complexp :real
:low low :high high))
(numeric-contagion x y))))
(defoptimizer (+ derive-type) ((x y))
(derive-integer-type
x y
#'(lambda (x y)
(flet ((frob (x y)
(if (and x y)
(+ x y)
nil)))
(values (frob (numeric-type-low x) (numeric-type-low y))
(frob (numeric-type-high x) (numeric-type-high y)))))))
(defoptimizer (- derive-type) ((x y))
(derive-integer-type
x y
#'(lambda (x y)
(flet ((frob (x y)
(if (and x y)
(- x y)
nil)))
(values (frob (numeric-type-low x) (numeric-type-high y))
(frob (numeric-type-high x) (numeric-type-low y)))))))
(defoptimizer (* derive-type) ((x y))
(derive-integer-type
x y
#'(lambda (x y)
(let ((x-low (numeric-type-low x))
(x-high (numeric-type-high x))
(y-low (numeric-type-low y))
(y-high (numeric-type-high y)))
(cond ((not (and x-low y-low))
(values nil nil))
((or (minusp x-low) (minusp y-low))
(if (and x-high y-high)
(let ((max (* (max (abs x-low) (abs x-high))
(max (abs y-low) (abs y-high)))))
(values (- max) max))
(values nil nil)))
(t
(values (* x-low y-low)
(if (and x-high y-high)
(* x-high y-high)
nil))))))))
(defoptimizer (/ derive-type) ((x y))
(numeric-contagion (continuation-type x) (continuation-type y)))
(or (let ((n-type (continuation-type n)))
(when (numeric-type-p n-type)
(let ((n-low (numeric-type-low n-type))
(n-high (numeric-type-high n-type)))
(if (constant-continuation-p shift)
(let ((shift (continuation-value shift)))
(make-numeric-type :class 'integer :complexp :real
:low (when n-low
#+new-compiler
(ash n-low shift)
;; ### fuckin' bignum bug.
#-new-compiler
(* n-low (ash 1 shift)))
:high (when n-high (ash n-high shift))))
(let ((s-type (continuation-type shift)))
(when (numeric-type-p s-type)
(let ((s-low (numeric-type-low s-type))
(s-high (numeric-type-high s-type)))
(if (and s-low s-high (<= s-low 32) (<= s-high 32))
(make-numeric-type :class 'integer :complexp :real
:low (when n-low
(min (ash n-low s-high)
(ash n-low s-low)))
:high (when n-high
(max (ash n-high s-high)
(ash n-high s-low))))
(make-numeric-type :class 'integer
:complexp :real)))))))))
*universal-type*))
(macrolet ((frob (fun)
`#'(lambda (type type2)
(declare (ignore type2))
(let ((lo (numeric-type-low type))
(hi (numeric-type-high type)))
(values (if hi (,fun hi) nil) (if lo (,fun lo) nil))))))
(defoptimizer (%negate derive-type) ((num))
(derive-integer-type num num (frob -)))
(defoptimizer (lognot derive-type) ((int))
(derive-integer-type int int (frob lognot))))
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
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
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
(defoptimizer (abs derive-type) ((num))
(let ((type (continuation-type num)))
(if (and (numeric-type-p type)
(eq (numeric-type-class type) 'integer)
(eq (numeric-type-complexp type) :real))
(let ((lo (numeric-type-low type))
(hi (numeric-type-high type)))
(make-numeric-type :class 'integer :complexp :real
:low (cond ((and hi (minusp hi))
(abs hi))
(lo
(max 0 lo))
(t
0))
:high (if (and hi lo)
(max (abs hi) (abs lo))
nil)))
(numeric-contagion type type))))
(defoptimizer (truncate derive-type) ((number divisor))
(let ((number-type (continuation-type number))
(divisor-type (continuation-type divisor))
(integer-type (specifier-type 'integer)))
(if (and (numeric-type-p number-type)
(csubtypep number-type integer-type)
(numeric-type-p divisor-type)
(csubtypep divisor-type integer-type))
(let ((number-low (numeric-type-low number-type))
(number-high (numeric-type-high number-type))
(divisor-low (numeric-type-low divisor-type))
(divisor-high (numeric-type-high divisor-type)))
(values-specifier-type
`(values ,(integer-truncate-derive-type number-low number-high
divisor-low divisor-high)
,(integer-rem-derive-type number-low number-high
divisor-low divisor-high))))
*universal-type*)))
;;; NUMERIC-RANGE-INFO -- internal.
;;;
;;; Derive useful information about the range. Returns three values:
;;; - '+ if its positive, '- negative, or nil if it overlaps 0.
;;; - The abs of the minimal value (i.e. closest to 0) in the range.
;;; - The abs of the maximal value if there is one, or nil if it is unbounded.
;;;
(defun numeric-range-info (low high)
(cond ((and low (not (minusp low)))
(values '+ low high))
((and high (not (plusp high)))
(values '- (- high) (if low (- low) nil)))
(t
(values nil 0 (and low high (max (- low) high))))))
;;; INTEGER-TRUNCATE-DERIVE-TYPE -- internal
;;;
(defun integer-truncate-derive-type
(number-low number-high divisor-low divisor-high)
;; The result cannot be larger in magnitude than the number, but the sign
;; might change. If we can determine the sign of either the number or
;; the divisor, we can eliminate some of the cases.
(multiple-value-bind
(number-sign number-min number-max)
(numeric-range-info number-low number-high)
(multiple-value-bind
(divisor-sign divisor-min divisor-max)
(numeric-range-info divisor-low divisor-high)
(when (and divisor-max (zerop divisor-max))
;; We've got a problem: guarenteed division by zero.
(return-from integer-truncate-derive-type t))
(when (zerop divisor-min)
;; We'll assume that they arn't going to divide by zero.
(incf divisor-min))
(cond ((and number-sign divisor-sign)
;; We know the sign of both.
(if (eq number-sign divisor-sign)
;; Same sign, so the result will be positive.
`(integer ,(if divisor-max
(truncate number-min divisor-max)
0)
,(if number-max
(truncate number-max divisor-min)
'*))
;; Different signs, the result will be negative.
`(integer ,(if number-max
(- (truncate number-max divisor-min))
'*)
,(if divisor-max
(- (truncate number-min divisor-max))
0))))
((eq divisor-sign '+)
;; The divisor is positive. Therefore, the number will just
;; become closer to zero.
`(integer ,(if number-low
(truncate number-low divisor-min)
'*)
,(if number-high
(truncate number-high divisor-min)
'*)))
((eq divisor-sign '-)
;; The divisor is negative. Therefore, the absolute value of
;; the number will become closer to zero, but the sign will also
;; change.
`(integer ,(if number-high
(- (truncate number-high divisor-min))
'*)
,(if number-low
(- (truncate number-low divisor-min))
'*)))
;; The divisor could be either positive or negative.
(number-max
;; The number we are dividing has a bound. Divide that by the
;; smallest posible divisor.
(let ((bound (truncate number-max divisor-min)))
`(integer ,(- bound) ,bound)))
(t
;; The number we are dividing is unbounded, so we can't tell
;; anything about the result.
'integer)))))
(defun integer-rem-derive-type
(number-low number-high divisor-low divisor-high)
(if (and divisor-low divisor-high)
;; We know the range of the divisor, and the remainder must be smaller
;; than the divisor. We can tell the sign of the remainer if we know
;; the sign of the number.
(let ((divisor-max (1- (max (abs divisor-low) (abs divisor-high)))))
`(integer ,(if (or (null number-low)
(minusp number-low))
(- divisor-max)
0)
,(if (or (null number-high)
(plusp number-high))
divisor-max
0)))
;; The divisor is potentially either very positive or very negative.
;; Therefore, the remainer is unbounded, but we might be able to tell
;; something about the sign from the number.
`(integer ,(if (and number-low (not (minusp number-low)))
;; The number we are dividing is positive. Therefore,
;; the remainder must be positive.
0
'*)
,(if (and number-high (not (plusp number-high)))
;; The number we are dividing is negative. Therefore,
;; the remainder must be negative.
0
'*))))
(defoptimizer (random derive-type) ((bound &optional state))
(let ((type (continuation-type bound)))
(when (numeric-type-p type)
(let ((class (numeric-type-class type))
(high (numeric-type-high type))
(format (numeric-type-format type)))
:format format
:low (coerce 0 (or format class 'real))
:high (cond ((not high) nil)
((eq class 'integer) (max (1- high) 0))
((or (consp high) (zerop high)) high)
(t `(,high))))))))
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
;;;; Logical derive-type methods:
;;; Integer-Type-Length -- Internal
;;;
;;; Return the maximum number of bits an integer of the supplied type can take
;;; up, or NIL if it is unbounded. The second (third) value is T if the
;;; integer can be positive (negative) and NIL if not. Zero counts as
;;; positive.
;;;
(defun integer-type-length (type)
(if (numeric-type-p type)
(let ((min (numeric-type-low type))
(max (numeric-type-high type)))
(values (and min max (max (integer-length min) (integer-length max)))
(or (null max) (not (minusp max)))
(or (null min) (minusp min))))
(values nil t t)))
(defoptimizer (logand derive-type) ((x y))
(multiple-value-bind
(x-len x-pos x-neg)
(integer-type-length (continuation-type x))
(declare (ignore x-pos))
(multiple-value-bind
(y-len y-pos y-neg)
(integer-type-length (continuation-type y))
(declare (ignore y-pos))
(if (not x-neg)
;; X must be positive.
(if (not y-neg)
;; The must both be positive.
(cond ((or (null x-len) (null y-len))
(specifier-type 'unsigned-byte))
((or (zerop x-len) (zerop y-len))
(specifier-type '(integer 0 0)))
(t
(specifier-type `(unsigned-byte ,(min x-len y-len)))))
;; X is positive, but Y might be negative.
(cond ((null x-len)
(specifier-type 'unsigned-byte))
((zerop x-len)
(specifier-type '(integer 0 0)))
(t
(specifier-type `(unsigned-byte ,x-len)))))
;; X might be negative.
(if (not y-neg)
;; Y must be positive.
(cond ((null y-len)
(specifier-type 'unsigned-byte))
((zerop y-len)
(specifier-type '(integer 0 0)))
(t
(specifier-type
`(unsigned-byte ,y-len))))
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
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
;; Either might be negative.
(if (and x-len y-len)
;; The result is bounded.
(specifier-type `(signed-byte ,(1+ (max x-len y-len))))
;; We can't tell squat about the result.
(specifier-type 'integer)))))))
(defoptimizer (logior derive-type) ((x y))
(multiple-value-bind
(x-len x-pos x-neg)
(integer-type-length (continuation-type x))
(multiple-value-bind
(y-len y-pos y-neg)
(integer-type-length (continuation-type y))
(cond
((and (not x-neg) (not y-neg))
;; Both are positive.
(specifier-type `(unsigned-byte ,(if (and x-len y-len)
(max x-len y-len)
'*))))
((not x-pos)
;; X must be negative.
(if (not y-pos)
;; Both are negative. The result is going to be negative and be
;; the same length or shorter than the smaller.
(if (and x-len y-len)
;; It's bounded.
(specifier-type `(integer ,(ash -1 (min x-len y-len)) -1))
;; It's unbounded.
(specifier-type '(integer * -1)))
;; X is negative, but we don't know about Y. The result will be
;; negative, but no more negative than X.
(specifier-type
`(integer ,(or (numeric-type-low (continuation-type x)) '*)
-1))))
(t
;; X might be either positive or negative.
(if (not y-pos)
;; But Y is negative. The result will be negative.
(specifier-type
`(integer ,(or (numeric-type-low (continuation-type y)) '*)
-1))
;; We don't know squat about either. It won't get any bigger.
(if (and x-len y-len)
;; Bounded.
(specifier-type `(signed-byte ,(1+ (max x-len y-len))))
;; Unbounded.
(specifier-type 'integer))))))))
(defoptimizer (logxor derive-type) ((x y))
(multiple-value-bind
(x-len x-pos x-neg)
(integer-type-length (continuation-type x))
(multiple-value-bind
(y-len y-pos y-neg)
(integer-type-length (continuation-type y))
(cond
((or (and (not x-neg) (not y-neg))
(and (not x-pos) (not y-pos)))
;; Either both are negative or both are positive. The result will be
;; positive, and as long as the longer.
(specifier-type `(unsigned-byte ,(if (and x-len y-len)
(max x-len y-len)
'*))))
((or (and (not x-pos) (not y-neg))
(and (not y-neg) (not y-pos)))
;; Either X is negative and Y is positive of vice-verca. The result
;; will be negative.
(specifier-type `(integer ,(if (and x-len y-len)
(ash -1 (max x-len y-len))
'*)
-1)))
;; We can't tell what the sign of the result is going to be. All we
;; know is that we don't create new bits.
((and x-len y-len)
(specifier-type `(signed-byte ,(1+ (max x-len y-len)))))
(t
(specifier-type 'integer))))))
;;;; Miscellaneous derive-type methods:
(defoptimizer (values derive-type) ((&rest values))
(values-specifier-type
`(values ,@(mapcar #'(lambda (x)
(type-specifier (continuation-type x)))
values))))
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
;;;; Byte operations:
;;;
;;; We try to turn byte operations into simple logical operations. First,
;;; we convert byte specifiers into separate size and position arguments passed
;;; to internal %FOO functions. We then attempt to transform the %FOO
;;; functions into boolean operations when the size and position are constant
;;; and the operands are fixnums.
;;; With-Byte-Specifier -- Internal
;;;
;;; Evaluate body with Size-Var and Pos-Var bound to expressions that
;;; evaluate to the Size and Position of the byte-specifier form Spec. We may
;;; wrap a let around the result of the body to bind some variables.
;;;
;;; If the spec is a Byte form, then bind the vars to the subforms.
;;; otherwise, evaluate Spec and use the Byte-Size and Byte-Position. The goal
;;; of this transformation is to avoid consing up byte specifiers and then
;;; immediately throwing them away.
;;;
(defmacro with-byte-specifier ((size-var pos-var spec) &body body)
(once-only ((spec `(macroexpand ,spec))
(temp '(gensym)))
`(if (and (consp ,spec)
(eq (car ,spec) 'byte)
(= (length ,spec) 3))
(let ((,size-var (second ,spec))
(,pos-var (third ,spec)))
,@body)
(let ((,size-var `(byte-size ,,temp))
(,pos-var `(byte-position ,,temp)))
`(let ((,,temp ,,spec))
,,@body)))))
(def-source-transform ldb (spec int)
(with-byte-specifier (size pos spec)
`(%ldb ,size ,pos ,int)))
(def-source-transform dpb (newbyte spec int)
(with-byte-specifier (size pos spec)
`(%dpb ,newbyte ,size ,pos ,int)))
(def-source-transform mask-field (spec int)
(with-byte-specifier (size pos spec)
`(%mask-field ,size ,pos ,int)))
(def-source-transform deposit-field (newbyte spec int)
(with-byte-specifier (size pos spec)
`(%deposit-field ,newbyte ,size ,pos ,int)))
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
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
(defoptimizer (%ldb derive-type) ((size posn num))
(let ((size (continuation-type size)))
(if (and (numeric-type-p size)
(csubtypep size (specifier-type 'integer)))
(let ((size-high (numeric-type-high size)))
(if (and size-high (<= size-high vm:word-bits))
(specifier-type `(unsigned-byte ,size-high))
(specifier-type 'unsigned-byte)))
*universal-type*)))
(defoptimizer (%mask-field derive-type) ((size posn num))
(let ((size (continuation-type size))
(posn (continuation-type posn)))
(if (and (numeric-type-p size)
(csubtypep size (specifier-type 'integer))
(numeric-type-p posn)
(csubtypep posn (specifier-type 'integer)))
(let ((size-high (numeric-type-high size))
(posn-high (numeric-type-high posn)))
(if (and size-high posn-high
(<= (+ size-high posn-high) vm:word-bits))
(specifier-type `(unsigned-byte ,(+ size-high posn-high)))
(specifier-type 'unsigned-byte)))
*universal-type*)))
(defoptimizer (%dpb derive-type) ((newbyte size posn int))
(let ((size (continuation-type size))
(posn (continuation-type posn))
(int (continuation-type int)))
(if (and (numeric-type-p size)
(csubtypep size (specifier-type 'integer))
(numeric-type-p posn)
(csubtypep posn (specifier-type 'integer))
(numeric-type-p int)
(csubtypep int (specifier-type 'integer)))
(let ((size-high (numeric-type-high size))
(posn-high (numeric-type-high posn))
(high (numeric-type-high int))
(low (numeric-type-low int)))
(if (and size-high posn-high high low
(<= (+ size-high posn-high) vm:word-bits))
(specifier-type
(list (if (minusp low) 'signed-byte 'unsigned-byte)
(max (integer-length high)
(integer-length low)
(+ size-high posn-high))))
*universal-type*))
*universal-type*)))
(defoptimizer (%deposit-field derive-type) ((newbyte size posn int))
(let ((size (continuation-type size))
(posn (continuation-type posn))
(int (continuation-type int)))
(if (and (numeric-type-p size)
(csubtypep size (specifier-type 'integer))
(numeric-type-p posn)
(csubtypep posn (specifier-type 'integer))
(numeric-type-p int)
(csubtypep int (specifier-type 'integer)))
(let ((size-high (numeric-type-high size))
(posn-high (numeric-type-high posn))
(high (numeric-type-high int))
(low (numeric-type-low int)))
(if (and size-high posn-high high low
(<= (+ size-high posn-high) vm:word-bits))
(specifier-type
(list (if (minusp low) 'signed-byte 'unsigned-byte)
(max (integer-length high)
(integer-length low)
(+ size-high posn-high))))
*universal-type*))
*universal-type*)))
(deftransform %ldb ((size posn int)
(fixnum fixnum integer)
(unsigned-byte #.vm:word-bits))
`(logand (ash int (- posn))
(ash ,(1- (ash 1 vm:word-bits))
(- size ,vm:word-bits))))
(deftransform %mask-field ((size posn int)
(fixnum fixnum integer)
(unsigned-byte #.vm:word-bits))
`(logand int
(ash (ash ,(1- (ash 1 vm:word-bits))
(- size ,vm:word-bits))
posn)))
;;; Note: for %dpb and %deposit-field, we can't use (or (signed-byte n)
;;; (unsigned-byte n)) as the result type, as that would allow result types
;;; that cover the range -2^(n-1) .. 1-2^n, instead of allowing result types
;;; of (unsigned-byte n) and result types of (signed-byte n).
(deftransform %dpb ((new size posn int)
*
(unsigned-byte #.vm:word-bits))
`(let ((mask (ldb (byte size 0) -1)))
(logior (ash (logand new mask) posn)
(logand int (lognot (ash mask posn))))))
(deftransform %dpb ((new size posn int)
*
(signed-byte #.vm:word-bits))
`(let ((mask (ldb (byte size 0) -1)))
(logior (ash (logand new mask) posn)
(logand int (lognot (ash mask posn))))))
(deftransform %deposit-field ((new size posn int)
*
(unsigned-byte #.vm:word-bits))
`(let ((mask (ash (ldb (byte size 0) -1) posn)))
(logior (logand new mask)
(logand int (lognot mask)))))
(deftransform %deposit-field ((new size posn int)
*
(signed-byte #.vm:word-bits))
`(let ((mask (ash (ldb (byte size 0) -1) posn)))
(logior (logand new mask)
(logand int (lognot mask)))))
;;;; Funny function stubs:
;;;
;;; These functions are the result of compiler transformations. We never
;;; actually compile a call to these functions, but we need to have a
;;; definition to allow constant folding.
;;;
(defun %negate (x) (%primitive negate x))
(defun %ldb (s p i) (%primitive ldb s p i))
(defun %dpb (n s p i) (%primitive dpb n s p i))
(defun %mask-field (s p i) (%primitive mask-field s p i))
(defun %deposit-field (n s p i) (%primitive deposit-field n s p i))
;;; COMMUTATIVE-ARG-SWAP -- Internal
;;;
;;; If a constant appears as the first arg, swap the args.
;;;
(deftransform commutative-arg-swap ((x y) * * :defun-only t :node node)
(if (and (constant-continuation-p x)
(not (constant-continuation-p y)))
`(,(continuation-function-name (basic-combination-fun node))
y
,(continuation-value x))
(give-up)))
(dolist (x '(= char= + * logior logand logxor))
(%deftransform x '(function * *) #'commutative-arg-swap
"place constant arg last."))
;;; Handle the case of a constant boole-code.
;;;
(deftransform boole ((op x y))
(unless (constant-continuation-p op)
(give-up "BOOLE code is not a constant."))
(let ((control (continuation-value op)))
(case control
(#.boole-clr 0)
(#.boole-set -1)
(#.boole-1 'x)
(#.boole-2 'y)
(#.boole-c1 '(lognot x))
(#.boole-c2 '(lognot y))
(#.boole-and '(logand x y))
(#.boole-ior '(logior x y))
(#.boole-xor '(logxor x y))
(#.boole-eqv '(logeqv x y))
(#.boole-nand '(lognand x y))
(#.boole-nor '(lognor x y))
(#.boole-andc1 '(logandc1 x y))
(#.boole-andc2 '(logandc2 x y))
(#.boole-orc1 '(logorc1 x y))
(#.boole-orc2 '(logorc2 x y))
(t
(abort-transform "~S illegal control arg to BOOLE." control)))))
;;;; Convert multiply/divide to shifts.
;;; If arg is a constant power of two, turn * into a shift.
;;;
(deftransform * ((x y) (integer integer))
(unless (constant-continuation-p y) (give-up))
(let* ((y (continuation-value y))
(y-abs (abs y))
(len (1- (integer-length y-abs))))
(unless (= y-abs (ash 1 len)) (give-up))
(if (minusp y)
`(- (ash x ,len))
`(ash x ,len))))
;;; If both arguments and the result are (unsigned-byte 32), try to come up
;;; with a ``better'' multiplication using multiplier recoding. 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.
;;;
(deftransform * ((x y)
((unsigned-byte 32) (unsigned-byte 32))
(unsigned-byte 32))
"recode as shift and add"
(unless (constant-continuation-p y)
(give-up))
(let ((y (continuation-value y))
(result nil)
(first-one nil))
(labels ((tub32 (x) `(truly-the (unsigned-byte 32) ,x))
(add (next-factor)
(setf result
(tub32
(if result
`(+ ,result ,(tub32 next-factor))
next-factor)))))
(declare (inline add))
(dotimes (bitpos 32)
(if first-one
(when (not (logbitp bitpos y))
(add (if (= (1+ first-one) bitpos)
;; There is only a single bit in the string.
`(ash x ,first-one)
;; There are at least two.
`(- ,(tub32 `(ash x ,bitpos))
,(tub32 `(ash x ,first-one)))))
(setf first-one nil))
(when (logbitp bitpos y)
(setf first-one bitpos))))
(when first-one
(cond ((= first-one 31))
((= first-one 30)
(add '(ash x 30)))
(t
(add `(- ,(tub32 '(ash x 31)) ,(tub32 `(ash x ,first-one))))))
(add '(ash x 31))))
(or result 0)))
;;; If arg is a constant power of two, turn floor into a shift and mask.
;;; If ceiling, add in (1- (abs y)) and then do floor.
;;;
(flet ((frob (y ceil-p)
(unless (constant-continuation-p y) (give-up))
(let* ((y (continuation-value y))
(y-abs (abs y))
(len (1- (integer-length y-abs))))
(unless (= y-abs (ash 1 len)) (give-up))
(let ((shift (- len))
(mask (1- y-abs)))
`(let ,(when ceil-p `((x (+ x ,(1- y-abs)))))
,(if (minusp y)
`(values (ash (- x) ,shift)
(- (logand (- x) ,mask)))