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.51 1997/06/05 00:33:16 dtc 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
;;;
;;; Propagate-float-type extension by Raymond Toy.
;;;
;;; 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)))
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
;;;
;;; 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)
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
176
177
(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)
#+propagate-float-type
(frob floor)
#+propagate-float-type
(frob ceiling))
(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))))
237
238
239
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
;;;; Interval arithmetic for computing bounds
;;;; (toy@rtp.ericsson.se)
;;;;
;;;; This is a set of routines for operating on intervals. It
;;;; implements a simple interval arithmetic package. Although CMUCL
;;;; has an interval type in numeric-type, we choose to use our own
;;;; for two reasons:
;;;;
;;;; 1. This package is simpler than numeric-type
;;;;
;;;; 2. It makes debugging much easier because you can just strip
;;;; out these routines and test them independently of CMUCL. (A
;;;; big win!)
;;;;
;;;; One disadvantage is a probable increase in consing because we
;;;; have to create these new interval structures even though
;;;; numeric-type has everything we want to know. Reason 2 wins for
;;;; now.
#+propagate-float-type
(progn
(defun elfun-float-format (format)
(if format
(if (eq format 'double-float)
'double-float
'single-float)))
;;; The basic interval type. It can handle open and closed intervals.
;;; A bound is open if it is a list containing a number, just like
;;; Lisp says. NIL means unbounded.
pw
committed
(defstruct (interval
(:constructor %make-interval))
pw
committed
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
(defun make-interval (&key low high)
(labels ((normalize-bound (val)
(cond ((and (floatp val)
(float-infinity-p val))
;; Handle infinities
nil)
((or (numberp val)
(eq val nil))
;; Handle any closed bounds
val)
((listp val)
;; We have an open bound. Normalize the numeric
;; bound. If the normalized bound is still a number
;; (not nil), keep the bound open. Otherwise, the
;; bound is really unbounded, so drop the openness.
(let ((new-val (normalize-bound (first val))))
(when new-val
;; Bound exists, so keep it open still
(list new-val))))
(t
(error "Unknown bound type in make-interval!")))))
(%make-interval :low (normalize-bound low)
:high (normalize-bound high))))
(defmacro without-over/under-flow-traps (&body body)
"Executes BODY with traps on overflow, underflow, and divide-by-zero
turned off"
(let ((modes (gensym)))
`(let ((,modes (ext:get-floating-point-modes)))
(unwind-protect
(progn
(ext:set-floating-point-modes :traps '(:invalid))
,@body)
(apply #'ext:set-floating-point-modes ,modes)))))
(proclaim '(inline bound-value set-bound bound-func))
;;; Extract the numeric value of a bound. Return NIL, if X is NIL.
(defun bound-value (x)
(if (consp x) (car x) x))
;;; Given a number X, create a form suitable as a bound for an
;;; interval. Make the bound open if OPEN-P is T. NIL remains NIL.
(defun set-bound (x open-p)
(if (and x open-p) (list x) x))
;;; Apply the function F to a bound X. If X is an open bound, then
;;; the result will be open. IF X is NIL, the result is NIL.
(defun bound-func (f x)
(and x
pw
committed
(without-over/under-flow-traps
(set-bound (funcall f (bound-value x)) (consp x)))))
;;; Apply a binary operator OP to two bounds X and Y. The result is
;;; NIL if either is NIL. Otherwise bound is computed and the result
;;; is open if either X or Y is open.
(defmacro bound-binop (op x y)
`(and ,x ,y
pw
committed
(without-over/under-flow-traps
(set-bound (,op (bound-value ,x)
(bound-value ,y))
(or (consp ,x) (consp ,y))))))
;;; NUMERIC-TYPE->INTERVAL
;;;
;;; Convert a numeric-type object to an interval object.
(defun numeric-type->interval (x)
(declare (type numeric-type x))
(make-interval :low (numeric-type-low x)
:high (numeric-type-high x)))
(defun copy-interval-limit (limit)
(if (numberp limit)
limit
(copy-list limit)))
(defun copy-interval (x)
(declare (type interval x))
(make-interval :low (copy-interval-limit (interval-low x))
:high (copy-interval-limit (interval-high x))))
;;; INTERVAL-SPLIT
;;;
;;; Given a point P contained in the interval X, split X into two
;;; interval at the point P. If JOIN-LOWER it T, then the left
;;; interval contains P. Otherwise, the right interval contains P.
;;; You can specify both to be T.
(defun interval-split (p x &optional close-lower close-upper)
(declare (type number p)
(type interval x))
(list (make-interval :low (copy-interval-limit (interval-low x))
:high (if close-lower p (list p)))
(make-interval :low (if close-upper (list p) p)
:high (copy-interval-limit (interval-high x)))))
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
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
(defun interval-closure (x)
(declare (type interval x))
(make-interval :low (bound-value (interval-low x))
:high (bound-value (interval-high x))))
;;; INTERVAL-RANGE-INFO
;;;
;;; For an interval X, if X >= 0, return '+. If X <= 0, return
;;; '-. Otherwise return NIL.
(defun interval-range-info (x)
(declare (type interval x))
(let ((lo (interval-low x))
(hi (interval-high x)))
(cond ((and lo (>= (bound-value lo) 0))
'+)
((and hi (<= (bound-value hi) 0))
'-)
(t
nil))))
;;; INTERVAL-BOUNDED-P
;;;
;;; Test to see if the interval X is bounded. HOW determines the
;;; test, and should be either ABOVE, BELOW, or BOTH.
(defun interval-bounded-p (x how)
(declare (type interval x))
(ecase how
('above
(interval-high x))
('below
(interval-low x))
('both
(and (interval-low x) (interval-high x)))))
;;; INTERVAL-CONTAINS-P
;;;
;;; See if the interval X contains the number P, taking into account
;;; that the interval might not be closed.
(defun interval-contains-p (p x)
(declare (type number p)
(type interval x))
;; Does the interval X contain the number P? This would be a lot
;; easier if all intervals were closed!
(let ((lo (interval-low x))
(hi (interval-high x)))
(cond ((and lo hi)
;; The interval is bounded
(if (<= (bound-value lo) p (bound-value hi))
;; P is definitely in the closure of the interval.
;; We just need to check the end points now.
(cond ((= p (bound-value lo))
(numberp lo))
((= p (bound-value hi))
(numberp hi))
(t t))
nil))
(hi
;; Interval with upper bound
(if (< p (bound-value hi))
t
(and (numberp hi) (= p hi))))
(lo
;; Interval with lower bound
(if (> p (bound-value lo))
t
(and (numberp lo) (= p lo))))
(t
;; Interval with no bounds
t))))
;;; INTERVAL-INTERSECT-P
;;;
;;; Determine if two intervals X and Y intersect. Return T if so. If
;;; CLOSED-INTERVALS-P is T, the treat the intervals as if they were
;;; closed. Otherwise the intervals are treated as they are.
;;;
;;; Thus if X = [0, 1) and Y = (1, 2), then they do not intersect
;;; because no element in X is in Y. However, if CLOSED-INTERVALS-P
;;; is T, then they do intersect because we use the closure of X = [0,
;;; 1] and Y = [1, 2] to determine intersection.
(defun interval-intersect-p (x y &optional closed-intervals-p)
(declare (type interval x y))
(let ((x-lo (interval-low x))
(x-hi (interval-high x))
(y-lo (interval-low y))
(y-hi (interval-high y)))
(labels ((test-number (p int)
;; Test if P is in the interval.
(when (interval-contains-p (bound-value p)
(interval-closure int))
(let ((lo (interval-low int))
(hi (interval-high int)))
;; Check for endpoints
(cond ((or (null lo) (null hi))
t)
((= (bound-value p) (bound-value lo))
(or closed-intervals-p
(not (and (consp p) (numberp lo)))))
((= (bound-value p) (bound-value hi))
(or closed-intervals-p
(not (and (numberp p) (consp hi)))))
(t t)))))
(test-lower-bound (p int)
;; P is a lower bound of an interval.
(if p
(test-number p int)
(not (interval-bounded-p int 'below))))
(test-upper-bound (p int)
;; P is an upper bound of an interval
(if p
(test-number p int)
(not (interval-bounded-p int 'above))))
)
(or (test-lower-bound x-lo y)
(test-upper-bound x-hi y)
(test-lower-bound y-lo x)
(test-upper-bound y-hi x)))))
;;; Are the two intervals adjacent? That is, is there a number
;;; between the two intervals that is not an element of either
;;; interval? If so, they are not adjacent. For example [0, 1) and
;;; [1, 2] are adjacent but [0, 1) and (1, 2] are not because 1 lies
;;; between both intervals.
(defun interval-adjacent-p (x y)
(declare (type interval x y))
(flet ((adjacent (lo hi)
;; Check to see if lo and hi are adjacent. If either is
;; nil, they can't be adjacent.
(when (and lo hi (= (bound-value lo) (bound-value hi)))
;; The bounds are equal. They are adjacent if one of
;; them is closed (a number). If both are open (consp),
;; then there is a number that lies between them.
(or (numberp lo) (numberp hi)))))
(or (adjacent (interval-low y) (interval-high x))
(adjacent (interval-low x) (interval-high y)))))
;;; INTERVAL-MERGE-PAIR
;;;
;;; If intervals X and Y intersect, return a new interval that is the
;;; union of the two. If they do not intersect, return NIL.
(defun interval-merge-pair (x y)
(declare (type interval x y))
;; If x and y intersect or are adjacent, create the union.
;; Otherwise return nil
(when (or (interval-intersect-p x y)
(interval-adjacent-p x y))
(flet ((select-bound (x1 x2 min-op max-op)
(let ((x1-val (bound-value x1))
(x2-val (bound-value x2)))
(cond ((and x1 x2)
;; Both bounds are finite. Select the right one.
(cond ((funcall min-op x1-val x2-val)
;; x1 definitely better
x1)
((funcall max-op x1-val x2-val)
;; x2 definitely better
x2)
(t
;; Bounds are equal. Select either
;; value and make it open only if
;; both were open.
(set-bound x1-val (and (consp x1) (consp x2))))))
(t
;; At least one bound is not finite. The
;; non-finite bound always wins.
nil)))))
(let* ((x-lo (copy-interval-limit (interval-low x)))
(x-hi (copy-interval-limit (interval-high x)))
(y-lo (copy-interval-limit (interval-low y)))
(y-hi (copy-interval-limit (interval-high y))))
547
548
549
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
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
(make-interval :low (select-bound x-lo y-lo #'< #'>)
:high (select-bound x-hi y-hi #'> #'<))))))
;;; Basic arithmetic operations on intervals
;;; INTERVAL-NEG
;;;
;;; The negative of an interval
(defun interval-neg (x)
(declare (type interval x))
(make-interval :low (bound-func #'- (interval-high x))
:high (bound-func #'- (interval-low x))))
;;; INTERVAL-ADD
;;;
;;; Add two intervals
(defun interval-add (x y)
(declare (type interval x y))
(make-interval :low (bound-binop + (interval-low x) (interval-low y))
:high (bound-binop + (interval-high x) (interval-high y))))
;;; INTERVAL-SUB
;;;
;;; Subtract two intervals
(defun interval-sub (x y)
(declare (type interval x y))
(make-interval :low (bound-binop - (interval-low x) (interval-high y))
:high (bound-binop - (interval-high x) (interval-low y))))
;;; INTERVAL-MUL
;;;
;;; Multiply two intervals
(defun interval-mul (x y)
(declare (type interval x y))
(flet ((bound-mul (x y)
(cond ((or (null x) (null y))
;; Multiply by infinity is infinity
nil)
((or (and (numberp x) (zerop x))
(and (numberp y) (zerop y)))
;; Multiply by closed zero is special. The result is
;; always a closed bound
0)
((or (and (floatp x) (float-infinity-p x))
(and (floatp y) (float-infinity-p y)))
;; Infinity times anything is infinity
nil)
(t
;; General multiply. The result is open if either is open.
(bound-binop * x y)))))
(let ((x-range (interval-range-info x))
(y-range (interval-range-info y)))
(cond ((null x-range)
;; Split x into two and multiply each separately
(destructuring-bind (x- x+)
(interval-split 0 x t t)
(interval-merge-pair (interval-mul x- y)
(interval-mul x+ y))))
((null y-range)
;; Split y into two and multiply each separately
(destructuring-bind (y- y+)
(interval-split 0 y t t)
(interval-merge-pair (interval-mul x y-)
(interval-mul x y+))))
((eq x-range '-)
(interval-neg (interval-mul (interval-neg x) y)))
((eq y-range '-)
(interval-neg (interval-mul x (interval-neg y))))
((and (eq x-range '+) (eq y-range '+))
;; If we are here, X and Y are both positive
(make-interval :low (bound-mul (interval-low x) (interval-low y))
:high (bound-mul (interval-high x) (interval-high y))))
(t
(error "This shouldn't happen!"))))))
;;; INTERVAL-DIV
;;;
;;; Divide two intervals.
(defun interval-div (top bot)
(declare (type interval top bot))
(flet ((bound-div (x y)
;; Compute x/y
(cond ((null y)
;; Divide by infinity means result is 0
0)
((zerop (bound-value y))
;; Divide by zero means result is infinity
nil)
((and (numberp x) (zerop x))
;; Zero divided by anything is zero.
x)
(t
(bound-binop / x y)))))
(let ((top-range (interval-range-info top))
(bot-range (interval-range-info bot)))
(cond ((null bot-range)
;; The denominator contains zero, so anything goes!
(make-interval :low nil :high nil))
((eq bot-range '-)
;; Denominator is negative so flip the sign, compute the
;; result, and flip it back.
(interval-neg (interval-div top (interval-neg bot))))
((null top-range)
;; Split top into two positive and negative parts, and
;; divide each separately
(destructuring-bind (top- top+)
(interval-split 0 top t t)
(interval-merge-pair (interval-div top- bot)
(interval-div top+ bot))))
((eq top-range '-)
;; Top is negative so flip the sign, divide, and flip the
;; sign of the result.
(interval-neg (interval-div (interval-neg top) bot)))
((and (eq top-range '+) (eq bot-range '+))
;; The easy case
(make-interval :low (bound-div (interval-low top) (interval-high bot))
:high (bound-div (interval-high top) (interval-low bot))))
(t
(error "This shouldn't happen!"))))))
;;; INTERVAL-FUNC
;;;
;;; Apply the function F to the interval X. If X = [a, b], then the
;;; result is [f(a), f(b)]. It is up to the user to make sure the
;;; result makes sense. It will if F is monotonic increasing (or
;;; non-decreasing).
(defun interval-func (f x)
(declare (type interval x))
(let ((lo (bound-func f (interval-low x)))
(hi (bound-func f (interval-high x))))
(make-interval :low lo :high hi)))
;;; INTERVAL-<
;;;
;;; Return T if X < Y. That is every number in the interval X is
;;; always less than any number in the interval Y.
(defun interval-< (x y)
(declare (type interval x y))
;; X < Y only if X is bounded above, Y is bounded below, and they
;; don't overlap.
(when (and (interval-bounded-p x 'above)
(interval-bounded-p y 'below))
;; Intervals are bounded in the appropriate way. Make sure that don't overlap.
(let ((left (interval-high x))
(right (interval-low y)))
(cond ((> (bound-value left)
(bound-value right))
;; Definitely overlap so result is NIL
nil)
((< (bound-value left)
(bound-value right))
;; Definitely don't touch, so result is T
t)
(t
;; Limits are equal. Check for open or closed bounds.
;; Don't overlap if one or the other are open.
(or (consp left) (consp right)))))))
;;; INTERVAL-ABS
;;;
;;; Return an interval that is the absolute value of X. Thus, if X =
;;; [-1 10], the result is [0, 10].
(defun interval-abs (x)
(declare (type interval x))
(case (interval-range-info x)
('+
(copy-interval x))
('-
(interval-neg x))
(t
(destructuring-bind (x- x+)
(interval-split 0 x t t)
(interval-merge-pair (interval-neg x-) x+)))))
;;; INTERVAL-SQR
;;;
;;; Compute the square of an interval.
(defun interval-sqr (x)
(declare (type interval x))
(interval-func #'(lambda (x) (* x x))
(interval-abs x)))
) ; end progn
;;;; 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))))
;;; 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
(progn
;;; Some functions only take one argument but derive-real-type assumes
;;; two. For those cases of one argument functions, set IGNORE-Y to T
;;; because we don't want derive-real-type to process the second
;;; argument because it's meaningless.
(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)))
;;; Some notes: This routine can handle X and Y if they are
;;; numeric-types or unions of numeric types. If this is not true,
;;; general numeric contagion holds. In particular if X is a member
;;; type, we could conceivably compute the right thing by looking
;;; inside the elements of the member type. We don't do this yet.
;;; Perhaps it would be better to let the user say so. Instead of
;;; saying (member 1 2 4), you should say (or (integer 1 1) (integer 2
;;; 2) (integer 4 4)).
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
(labels ((combine (lx ly)
;; Creates a new list containing all possible pairs from LX and LY.
(let ((result '()))
(dolist (ix lx)
(dolist (iy ly)
(push (list ix iy) result)))
(nreverse result)))
(listify (object)
;; If object is a union type, get the list of the types.
;; Otherwise make a list containing the single object.
(typecase object
(union-type
(union-type-types object))
(t
(list object)))))
(let ((all (combine (listify x)
(listify y)))
(result '()))
(dolist (item all)
(destructuring-bind (ix iy)
item
(push (derive-simple-real-type ix iy fun) result)))
(setf result (derive-merged-union-types result))
(if (cdr result)
(make-union-type result)
(first result)))))
(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))
(cur-intvrl (numeric-type->interval cur))
(dolist (this-interval (rest tlist) res)
(let ((this (numeric-type->interval this-interval)))
;; If interval intersects cur or if they are adjacent, we can
;; merge them together, but only if they are the same type of
;; number. If they are different, we can't merge them.
(cond ((and (eq (numeric-type-class cur)
(numeric-type-class this-interval))
(or (interval-intersect-p cur-intvrl this)
(interval-adjacent-p cur-intvrl this)))
(let ((result (interval-merge-pair cur-intvrl this)))
(when result
(setf (numeric-type-high cur)
(interval-high result)))))
(t
(setf res (cons this-interval res))))))))
(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))))
(defun derive-merged-union-types (types)
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
(labels ((num-interval-< (a b)
(when (and (numeric-type-p a)
(numeric-type-p b))
(let ((a-lo (numeric-type-low a))
(b-lo (numeric-type-low b)))
(cond ((null a-lo)
;; A has lower bound of -infinity, so it's
;; lower than B, no matter what B is.
t)
((null b-lo)
;; At this point A has a numeric lower bound,
;; but B has -infinity, so A is not lower than
;; B.
nil)
(t
;; Both A and B have numeric lower bounds. Make the right decision
(let ((av (bound-value a-lo))
(bv (bound-value b-lo)))
(cond ((< av bv)
;; Obviously
t)
((= av bv)
;; Bounds are equal. A is lower unless A is open and B is closed.
(or (numberp a-lo) (consp b-lo)))
(t
nil)))))))))
(merge-types (stable-sort types #'num-interval-<))))
;; We handle the case of real operands. For the other cases, we use
;; general numeric contagion.
(if (and (numeric-type-p x) (numeric-type-p y)
(eq (numeric-type-complexp x) :real)
(eq (numeric-type-complexp y) :real))
(multiple-value-bind (low high type format)
(funcall fun x y)
(make-numeric-type :class type
:complexp :real
:format format
: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)))
) ; end progn
(progn
(defoptimizer (+ derive-type) ((x y))
(derive-real-type
x y
#'(lambda (x y)
(declare (type numeric-type x y))
(let ((result (interval-add (numeric-type->interval x)
(numeric-type->interval y)))
(result-type (numeric-contagion x y)))
;; If the result type is a float, we need to be sure to
;; coerce the bounds into the correct type.
(when (eq (numeric-type-class result-type) 'float)
(setf result (interval-func
#'(lambda (x)
(coerce x (or (numeric-type-format result-type)
'float)))
result)))
(values (interval-low result)
(interval-high result)
(if (and (eq (numeric-type-class x) 'integer)
(eq (numeric-type-class y) 'integer))
;; The sum of integers is always an integer
'integer
(numeric-type-class result-type))
(numeric-type-format result-type))))))
(defoptimizer (- derive-type) ((x y))
(derive-real-type
x y
#'(lambda (x y)
(declare (type numeric-type x y))
(let ((result (interval-sub (numeric-type->interval x)
(numeric-type->interval y)))
(result-type (numeric-contagion x y)))
;; If the result type is a float, we need to be sure to
;; coerce the bounds into the correct type.
(when (eq (numeric-type-class result-type) 'float)
(setf result (interval-func
#'(lambda (x)
(coerce x (or (numeric-type-format result-type)
'float)))
result)))