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.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.47 1997/02/05 15:41:57 pw 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 :when :both)
(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.")))))
;;;; List hackery:
;;;
;;; Translate CxxR into car/cdr combos.
(defun source-transform-cxr (form)
(if (or (byte-compiling) (/= (length form) 2))
(values nil t)
(let ((name (symbol-name (car form))))
(do ((i (- (length name) 2) (1- i))
(res (cadr form)
`(,(ecase (char name i)
(#\A 'car)
(#\D 'cdr))
,res)))
((zerop i) res)))))
(do ((i 2 (1+ i))
(b '(1 0) (cons i b)))
((= i 5))
(dotimes (j (ash 1 i))
(setf (info function source-transform
(intern (format nil "C~{~:[A~;D~]~}R"
(mapcar #'(lambda (x) (logbitp x j)) b))))
#'source-transform-cxr)))
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
;;;
;;; 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)
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
(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.
;;;
(def-source-transform numerator (num)
(once-only ((n-num `(the rational ,num)))
`(if (ratiop ,n-num)
(%numerator ,n-num)
,n-num)))
;;;
(def-source-transform denominator (num)
(once-only ((n-num `(the rational ,num)))
`(if (ratiop ,n-num)
(%denominator ,n-num)
1)))
;;;
(def-source-transform realpart (num)
(once-only ((n-num num))
`(if (complexp ,n-num)
(%realpart ,n-num)
,n-num)))
;;;
(def-source-transform imagpart (num)
(once-only ((n-num num))
`(cond ((complexp ,n-num)
(%imagpart ,n-num))
((floatp ,n-num)
(float 0 ,n-num))
(t
0))))
;;;; 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))))
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
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
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
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
;;; Derive-Real-Type -- Internal
;;;
;;; Same as derive-integer-type except it can handle float types.
;;; This also contains derive-integer-type as a special case.
;;;
#+propagate-float-type
(defun derive-real-type (x y fun)
(declare (type continuation x y) (type function fun))
(let ((x (continuation-type x))
(y (continuation-type y)))
(derive-real-numeric-or-union-type x y fun)))
#+propagate-float-type
(defun derive-real-numeric-or-union-type (x y fun)
(cond ((union-type-p x)
(let ((new-union '()))
(dolist (type (union-type-types x))
(setf new-union (cons (derive-real-numeric-or-union-type
type y fun) new-union)))
(make-union-type (derive-merged-union-types new-union))))
((union-type-p y)
(let ((new-union '()))
(dolist (type (union-type-types y))
(setf new-union (cons (derive-real-numeric-or-union-type
x type fun) new-union)))
(make-union-type (derive-merged-union-types new-union))))
((and (numeric-type-p x) (numeric-type-p y))
(derive-simple-real-type x y fun))
(t
(numeric-contagion x y))))
#+propagate-float-type
(defun merge-types-aux (tlist)
;; Merge the first interval in the list with the rest of
;; intervals in the list. The list of intervals MUST be
;; sorted in ascending order of lower limits.
(let* ((cur (first tlist))
(res (list cur)))
(multiple-value-bind (cur-lo cur-hi)
(extract-bounds cur)
(declare (ignore cur-lo))
(dolist (type (rest tlist)
res)
(multiple-value-bind (type-lo type-hi)
(extract-bounds type)
(cond ((not (bound-< type-lo cur-hi))
;; Left limit of the current interval lies
;; within our interval, so merge these two
;; intervals into our interval.
(setf (numeric-type-high cur)
(nilify-bound (max-bound cur-hi type-hi))))
(t
;; Otherwise, we can't merge these two intervals
(setf res (cons type res)))))))))
#+propagate-float-type
(defun merge-types (ilist &optional (result '()))
;; Compare the first element with the rest to merge
;; whatever we can into the first element. The first
;; element is totally merged, so we only need to consider
;; whatever is left.
(cond ((null ilist)
result)
((cdr ilist)
(let ((new-types (merge-types-aux ilist)))
(merge-types (rest new-types) (cons (first new-types) result))))
(t
(cons (first ilist) result))))
#+propagate-float-type
(defun derive-merged-union-types (types)
(labels ((interval-< (a b)
(multiple-value-bind (a-lo a-hi)
(extract-bounds a)
(declare (ignore a-hi))
(multiple-value-bind (b-lo b-hi)
(extract-bounds b)
(declare (ignore b-hi))
(bound-< a-lo b-lo)))))
(merge-types (sort types #'interval-<))))
#+propagate-float-type
(defun derive-simple-real-type (x y fun)
(declare (type numeric-type x y) (type function fun))
(cond ((and (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)))
((and (numeric-type-p x) (numeric-type-p y)
(eq (numeric-type-class x) 'float)
(eq (numeric-type-class y) 'float)
(eq (numeric-type-complexp x) :real)
(eq (numeric-type-complexp y) :real)
(eq (numeric-type-format x) (numeric-type-format y)))
;; We have two floats of some kind. We will handle float
;; contagion here instead of using the general
;; numeric-contagion which loses the bounds on the numbers,
;; if any.
(multiple-value-bind (low high)
(funcall fun x y)
(make-numeric-type
:class 'float
:format (float-format-max (numeric-type-format x)
(numeric-type-format y))
:complexp :real
:low low :high high)))
(t
(numeric-contagion x y))))
;;;; Helper methods for dealing with inclusive and exclusive bounds.
;;; Return the value of a bound. Ignore the issue if the bound is
;;; inclusive or exclusive. If no bound is given, return nil (which
;;; is the bound value).
(defun bound-value (bnd)
(if (consp bnd)
(car bnd)
bnd))
;;; Take a numeric argument and extract the bounds. If any bound is
;;; not given (nil), return the appropriate infinity instead.
(defun extract-bounds (arg)
(let ((lo (numeric-type-low arg))
(hi (numeric-type-high arg)))
;; Replace nil values with the appropriate bound
(values (or lo 'neg-inf)
(or hi 'pos-inf))))
;;; Convert a bound from extract-bounds to be either the bound or nil.
(defun nilify-bound (b)
(if (symbolp b)
nil
b))
(defun set-bound (val exclusive)
(if (and (floatp val)
(float-infinity-p val))
nil
(if exclusive
`(,val)
val)))
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
(defun bound-< (x y)
(cond ((eq x 'pos-inf)
nil)
((eq x 'neg-inf)
(not (eq y 'neg-inf)))
(t
;; x is some number
(if (symbolp y)
(not (bound-< y x))
;; Both x and y are numbers
(let ((xbnd (bound-value x))
(ybnd (bound-value y)))
(or (< xbnd ybnd)
;; If the bounds are equal, we need to check if the
;; bounds are exclusive. The result is true if x is
;; an inclusive bound but y is not.
(and (= xbnd ybnd)
(numberp x)
(consp y))))))))
;;; Determine if a bound is less than zero
(defun bound-minusp (b)
(bound-< b 0))
;;; Determine if a bound is greater than zero
(defun bound-plusp (b)
(not (bound-< b 0)))
;;; Find the sign of a bound
(defun bound-sign (x)
(cond ((eq x 'neg-inf)
-1)
((eq x 'pos-inf)
1)
(t
(signum (bound-value x)))))
;;; Compute the product of two bounds
(defun bound-prod (x y)
(cond ((or (symbolp x) (symbolp y))
;; One of the numbers is infinity. The result is also infinity.
(if (minusp (* (bound-sign x) (bound-sign y)))
'neg-inf
'pos-inf))
(t
;; The limits are numbers.
(let ((res (* (bound-value x) (bound-value y))))
(set-bound res (or (consp x) (consp y)))))))
;;; Compute the quotient of two bounds
(defun bound-quot (x y)
(cond ((symbolp x)
;; Infinity divided by anything will be infinity
(bound-prod x y))
((symbolp y)
;; A number divided by infinity is always 0
0)
(t
;; At this point we have the ratio of two numbers. Watch out
;; for division by zero!
(cond ((zerop (bound-value y))
(if (bound-minusp x)
'neg-inf
'pos-inf))
(t
(let ((res (/ (bound-value x) (bound-value y))))
(set-bound res (or (consp x) (consp y)))))))))
;;; Compute the absolute value of a bound.
(defun bound-abs (x)
(if (symbolp x)
'pos-inf
(set-bound (abs (bound-value x)) (consp x))))
;;; Given a list of float bounds, find the maximum. If the maximum is
;;; infinity, return nil instead.
(defun max-bound (x y)
(if (bound-< x y)
y
x))
(defun min-bound (x y)
(if (bound-< x y)
x
y))
(defun max-bound-list (lst)
(nilify-bound (reduce #'max-bound lst)))
(defun min-bound-list (lst)
(nilify-bound (reduce #'min-bound lst)))
#-propagate-float-type
(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)))))))
#+propagate-float-type
(defoptimizer (+ derive-type) ((x y))
(derive-real-type
x y
#'(lambda (x y)
(labels ((frob (x y)
(if (and x y)
(set-bound (+ (bound-value x) (bound-value y))
(or (consp x) (consp y)))
nil)))
#|
(debug:backtrace)
(format t "~%+-derive: ~s ~s~%" x y)
(format t "to ~s ~s~%"
(frob (numeric-type-low x) (numeric-type-low y))
(frob (numeric-type-high x) (numeric-type-high y)))
|#
(values (frob (numeric-type-low x) (numeric-type-low y))
(frob (numeric-type-high x) (numeric-type-high y)))))))
#-propagate-float-type
(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)))))))
#+propagate-float-type
(defoptimizer (- derive-type) ((x y))
(derive-real-type
x y
#'(lambda (x y)
(labels ((frob (x y)
(if (and x y)
(set-bound (- (bound-value x) (bound-value y))
(or (consp x) (consp y)))
nil)))
(values (frob (numeric-type-low x) (numeric-type-high y))
(frob (numeric-type-high x) (numeric-type-low y)))))))
#-propagate-float-type
(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))))))))
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
#+propagate-float-type
(defoptimizer (* derive-type) ((x y))
(let ((same-arg (same-leaf-ref-p x y)))
(derive-real-type
x y
#'(lambda (x y)
(multiple-value-bind (x-low x-high)
(extract-bounds x)
(cond (same-arg
(let ((new-limits (list (bound-prod x-low x-low)
(bound-prod x-high x-high))))
;; There are two cases to handle: 0 is in
;; the range and 0 is not.
(cond ((and (bound-minusp x-low)
(bound-plusp x-high))
;; The low limit is 0 and the high
;; is the max of the square of the
;; bounds.
(values 0
(max-bound-list new-limits)))
(t
;; Since zero is not within the
;; range, the answer is obvious
(values (min-bound-list new-limits)
(max-bound-list new-limits))))))
(t
(multiple-value-bind (y-low y-high)
(extract-bounds y)
(let ((new-limits (list (bound-prod x-low y-low)
(bound-prod x-low y-high)
(bound-prod x-high y-low)
(bound-prod x-high y-high))))
(values (min-bound-list new-limits)
(max-bound-list new-limits)))))))))))
#-propagate-float-type
(defoptimizer (/ derive-type) ((x y))
(numeric-contagion (continuation-type x) (continuation-type y)))
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
#+propagate-float-type
(defoptimizer (/ derive-type) ((top bot))
;; We only handle the case where both of the arguments are
;; floats. Otherwise, the general numeric contagion holds.
(let ((x-num (continuation-type top))
(y-num (continuation-type bot)))
(if (not (and (numeric-type-p x-num) (numeric-type-p y-num)
(eq (numeric-type-complexp x-num) :real)
(eq (numeric-type-complexp y-num) :real)
(eq (numeric-type-class x-num) 'float)
(eq (numeric-type-class y-num) 'float)))
(numeric-contagion x-num y-num)
(derive-real-type
top bot
#'(lambda (x y)
(multiple-value-bind (y-low y-high)
(extract-bounds y)
(cond ((and (bound-minusp y-low)
(bound-plusp y-high))
;; If 0 is within the bounds of y, the result is
;; clear: any float is possible for the quotient.
(values nil nil))
(t
(multiple-value-bind (x-low x-high)
(extract-bounds x)
(let ((new-limits (list (bound-quot x-low y-low)
(bound-quot x-low y-high)
(bound-quot x-high y-low)
(bound-quot x-high y-high))))
(values (min-bound-list new-limits)
(max-bound-list new-limits))))))))))))
(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))))
#+propagate-float-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))
(flet ((negate-bound (b)
(set-bound (- (bound-value b)) (consp b))))
(derive-real-type num num (frob negate-bound))))
(defoptimizer (lognot derive-type) ((int))
(derive-integer-type int int (frob lognot))))
#-propagate-float-type
(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))))
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
#+propagate-float-type
(defoptimizer (abs derive-type) ((num))
(let ((type (continuation-type num)))
(when (numeric-type-p type)
(cond ((eq (numeric-type-complexp type) :complex)
;; The absolute value of a complex number is always a
;; non-negative float.
(make-numeric-type :class 'float
:format (elfun-float-format (numeric-type-format type))
:complexp :real
:low 0
:high nil))
((eq (numeric-type-complexp type) :real)
;; The absolute value of a real number is a non-negative
;; real of the same type.
(let ((lo (numeric-type-low type))
(hi (numeric-type-high type)))
(make-numeric-type :class (numeric-type-class type)
:format (numeric-type-format type)
:complexp :real
:low (cond ((and hi (minusp (bound-value hi)))
(bound-abs hi))
(lo
(set-bound (max 0 (bound-value lo))
(consp lo)))
(t
0))
:high (if (and hi lo)
(max-bound-list (list (bound-abs hi)
(bound-abs lo)))
nil))))))))
(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*)))
#+propagate-float-type
(progn
(defoptimizer (truncate derive-type) ((number divisor))
(let ((number-type (continuation-type number))
(divisor-type (continuation-type divisor))
(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)))
(setf number-low (if (consp number-low)
(car number-low)
number-low))
(setf number-high (if (consp number-high)
(car number-high)
number-high))
(setf divisor-low (if (consp divisor-low)
(car divisor-low)
divisor-low))
(setf divisor-high (if (consp divisor-high)
(car divisor-high)
divisor-high))
(if (and (csubtypep number-type (specifier-type 'integer))
(csubtypep divisor-type (specifier-type 'integer)))
;; If both the number and the divisor are integers of
;; some type, then both results of truncate are
;; integers. Figure out the appropriate ranges of the
;; results.
`(values
,(integer-truncate-derive-type number-low number-high
divisor-low divisor-high
divisor-type)
,(integer-rem-derive-type number-low number-high
divisor-low divisor-high)))
;; Otherwise, the first result of truncate is an integer
;; and the second result is a float of some type.
;; Figure out the ranges of the results and their
;; appropriate types.
`(values
,(integer-truncate-derive-type number-low number-high
divisor-low divisor-high
divisor-type)
,(real-rem-derive-type number-low number-high
divisor-low divisor-high
number-type
divisor-type)))))
*universal-type*)))
(defoptimizer (%unary-truncate derive-type) ((number))
(let ((number-type (continuation-type number)))
(if (and (numeric-type-p number-type)
(csubtypep number-type (specifier-type 'real)))
(let ((number-low (numeric-type-low number-type))
(number-high (numeric-type-high number-type))
(divisor (make-numeric-type
:class 'integer
:low 1
:high 1)))
(setf number-low (if (consp number-low)
(car number-low)
number-low))
(setf number-high (if (consp number-high)
(car number-high)
number-high))
(specifier-type `,(integer-truncate-derive-type
number-low number-high 1 1 divisor)))
;;; 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
;;;
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
(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)))))
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
(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
'*))))
#+propagate-float-type
(progn
(defun integer-truncate-derive-type
(number-low number-high divisor-low divisor-high divisor-type)
;; 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.
(macrolet ((maybe* (form)
;; return result of form or * if overflow occurs
`(handler-case ,form
(arithmetic-error () '*))))