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.45 1994/10/31 04:27:28 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 :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))))
231
232
233
234
235
236
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
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
;;;; 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))))
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
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
(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))))))))
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
543
544
545
546
547
;;;; 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)))))
Loading
Loading full blame...