Newer
Older
(let ((mask (1- y-abs)))
(if (minusp y)
`(- (logand (- x) ,mask))
`(logand x ,mask)))))
;;; If arg is a constant power of two, turn truncate into a shift and mask.
;;;
(deftransform truncate ((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))
(let* ((shift (- len))
(mask (1- y-abs)))
`(if (minusp x)
(values ,(if (minusp y)
`(ash (- x) ,shift)
`(- (ash (- x) ,shift)))
(- (logand (- x) ,mask)))
(values ,(if (minusp y)
`(- (ash (- x) ,shift))
`(ash x ,shift))
(logand x ,mask))))))
;;; And the same for rem.
;;;
(deftransform rem ((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))
(let ((mask (1- y-abs)))
`(if (minusp x)
(- (logand (- x) ,mask))
(logand x ,mask)))))
;;;; Arithmetic and logical identity operation elimination:
;;;
;;; Flush calls to random arith functions that convert to the identity
;;; function or a constant.
(dolist (stuff '((ash 0 x)
(logand -1 x)
(logand 0 0)
(logior 0 x)
(logior -1 -1)
(logxor -1 (lognot x))
(logxor 0 x)))
(destructuring-bind (name identity result) stuff
(deftransform name ((x y) `(* (constant-argument (member ,identity))) '*
:eval-name t)
"fold identity operations"
result)))
;;; These are restricted to rationals, because (- 0 0.0) is 0.0, not -0.0, and
;;; (* 0 -4.0) is -0.0.
(deftransform - ((x y) ((constant-argument (member 0)) rational))
"convert (- 0 x) to negate"
'(%negate y))
;;;
(deftransform * ((x y) (rational (constant-argument (member 0))))
"convert (* x 0) to 0."
0)
;;; NOT-MORE-CONTAGIOUS -- Interface
;;;
;;; Return T if in an arithmetic op including continuations X and Y, the
;;; result type is not affected by the type of X. That is, Y is at least as
;;; contagious as X.
;;;
(defun not-more-contagious (x y)
(declare (type continuation x y))
(let ((x (continuation-type x))
(y (continuation-type y)))
(values (type= (numeric-contagion x y)
(numeric-contagion y y)))))
;;; Fold (OP x 0).
;;;
;;; If y is not constant, not zerop, or is contagious, then give up.
;;;
(dolist (stuff '((+ x)
(- x)
(expt 1)))
(destructuring-bind (name result) stuff
(deftransform name ((x y) '(t (constant-argument t)) '* :eval-name t)
"fold zero arg"
(let ((val (continuation-value y)))
(unless (and (zerop val)
(not (and (floatp val) (minusp (float-sign val))))
(not-more-contagious y x))
(give-up)))
result)))
;;; Fold (OP x +/-1)
;;;
(dolist (stuff '((* x (%negate x))
(/ x (%negate x))
(expt x (/ 1 x))))
(destructuring-bind (name result minus-result) stuff
(deftransform name ((x y) '(t (constant-argument real)) '* :eval-name t)
"fold identity operations"
(let ((val (continuation-value y)))
(unless (and (= (abs val) 1)
(not-more-contagious y x))
(give-up))
(if (minusp val) minus-result result)))))
(deftransform char-equal ((a b) (base-char base-char))
'(let* ((ac (char-code a))
(bc (char-code b))
(sum (logxor ac bc)))
(or (zerop sum)
(when (eql sum #x20)
(let ((sum (+ ac bc)))
(and (> sum 161) (< sum 213)))))))
(deftransform char-upcase ((x) (base-char))
'(let ((n-code (char-code x)))
(if (and (> n-code #o140) ; Octal 141 is #\a.
(< n-code #o173)) ; Octal 172 is #\z.
(code-char (logxor #x20 n-code))
x)))
(deftransform char-downcase ((x) (base-char))
'(let ((n-code (char-code x)))
(if (and (> n-code 64) ; 65 is #\A.
(< n-code 91)) ; 90 is #\Z.
(code-char (logxor #x20 n-code))
x)))
;;;; Equality predicate transforms:
;;; SAME-LEAF-REF-P -- Internal
;;;
;;; Return true if X and Y are continuations whose only use is a reference
;;; to the same leaf, and the value of the leaf cannot change.
;;;
(defun same-leaf-ref-p (x y)
(declare (type continuation x y))
(let ((x-use (continuation-use x))
(y-use (continuation-use y)))
(and (ref-p x-use)
(ref-p y-use)
(eq (ref-leaf x-use) (ref-leaf y-use))
(constant-reference-p x-use))))
;;; SIMPLE-EQUALITY-TRANSFORM -- Internal
;;;
;;; If X and Y are the same leaf, then the result is true. Otherwise, if
;;; there is no intersection between the types of the arguments, then the
;;; result is definitely false.
;;;
(deftransform simple-equality-transform ((x y) * * :defun-only t)
(cond ((same-leaf-ref-p x y)
't)
((not (types-intersect (continuation-type x) (continuation-type y)))
'nil)
(%deftransform x '(function * *) #'simple-equality-transform))
;;; EQL IR1 Transform -- Internal
;;;
;;; Similar to SIMPLE-EQUALITY-PREDICATE, except that we also try to convert
;;; to a type-specific predicate or EQ:
;;; -- If both args are characters, convert to CHAR=. This is better than just
;;; converting to EQ, since CHAR= may have special compilation strategies
;;; for non-standard representations, etc.
;;; -- If either arg is definitely not a number, then we can compare with EQ.
;;; -- Otherwise, we try to put the arg we know more about second. If X is
;;; constant then we put it second. If X is a subtype of Y, we put it
;;; second. These rules make it easier for the back end to match these
;;; interesting cases.
;;; -- If Y is a fixnum, then we quietly pass because the back end can handle
;;; that case, otherwise give an efficency note.
(let ((x-type (continuation-type x))
(y-type (continuation-type y))
(char-type (specifier-type 'character))
(number-type (specifier-type 'number)))
(cond ((same-leaf-ref-p x y)
't)
((not (types-intersect x-type y-type))
'nil)
((and (csubtypep x-type char-type)
(csubtypep y-type char-type))
'(char= x y))
((or (not (types-intersect x-type number-type))
(not (types-intersect y-type number-type)))
'(eq x y))
((and (not (constant-continuation-p y))
(or (constant-continuation-p x)
(and (csubtypep x-type y-type)
(not (csubtypep y-type x-type)))))
'(eql y x))
(give-up)))))
;;; = IR1 Transform -- Internal
;;;
;;; Convert to EQL if both args are the "same" numeric type. This allows
;;; all of EQL's type-specific expertise to come into play. "Same" means
;;; either both rational or both floats of the same format. Complexp must also
;;; be specified and identical.
;;;
(deftransform = ((x y))
(let ((x-type (continuation-type x))
(y-type (continuation-type y)))
(if (and (numeric-type-p x-type) (numeric-type-p y-type)
(let ((x-class (numeric-type-class x-type))
(y-class (numeric-type-class y-type))
(x-format (numeric-type-format x-type)))
(or (and (eq x-class 'float) (eq y-class 'float)
x-format
(eq x-format (numeric-type-format y-type)))
(and (member x-class '(rational integer))
(member y-class '(rational integer)))))
(let ((x-complexp (numeric-type-complexp x-type)))
(and x-complexp
(eq x-complexp (numeric-type-complexp y-type)))))
'(eql x y)
(give-up "Operands might not be the same type."))))
;;; Numeric-Type-Or-Lose -- Interface
;;;
;;; If Cont's type is a numeric type, then return the type, otherwise
;;; GIVE-UP.
;;;
(defun numeric-type-or-lose (cont)
(declare (type continuation cont))
(let ((res (continuation-type cont)))
(unless (numeric-type-p res) (give-up))
res))
;;; IR1-TRANSFORM-< -- Internal
;;;
;;; See if we can statically determine (< X Y) using type information. If
;;; X's high bound is < Y's low, then X < Y. Similarly, if X's low is >= to
;;; Y's high, the X >= Y (so return NIL). If not, at least make sure any
;;; constant arg is second.
(defun ir1-transform-< (x y first second inverse)
(let* ((x-type (numeric-type-or-lose x))
(x-lo (numeric-type-low x-type))
(x-hi (numeric-type-high x-type))
(y-type (numeric-type-or-lose y))
(y-lo (numeric-type-low y-type))
(y-hi (numeric-type-high y-type)))
(cond ((and x-hi y-lo (< x-hi y-lo))
't)
((and y-hi x-lo (>= x-lo y-hi))
'nil)
((and (constant-continuation-p first)
(not (constant-continuation-p second)))
`(,inverse y x))
(t
(give-up))))))
(ir1-transform-< x y x y '>))
(ir1-transform-< y x x y '<))
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
;;;; Converting N-arg comparisons:
;;;
;;; We convert calls to N-arg comparison functions such as < into two-arg
;;; calls. This transformation is enabled for all such comparisons in this
;;; file. If any of these predicates are not open-coded, then the
;;; transformation should be removed at some point to avoid pessimization.
;;; Multi-Compare -- Internal
;;;
;;; This function is used for source transformation of N-arg comparison
;;; functions other than inequality. We deal both with converting to two-arg
;;; calls and inverting the sense of the test, if necessary. If the call has
;;; two args, then we pass or return a negated test as appropriate. If it is a
;;; degenerate one-arg call, then we transform to code that returns true.
;;; Otherwise, we bind all the arguments and expand into a bunch of IFs.
;;;
(proclaim '(function multi-compare (symbol list boolean)))
(defun multi-compare (predicate args not-p)
(let ((nargs (length args)))
(cond ((< nargs 1) (values nil t))
((= nargs 1) `(progn ,@args t))
((= nargs 2)
(if not-p
`(if (,predicate ,(first args) ,(second args)) nil t)
(values nil t)))
(t
(do* ((i (1- nargs) (1- i))
(last nil current)
(current (gensym) (gensym))
(vars (list current) (cons current vars))
(result 't (if not-p
`(if (,predicate ,current ,last)
nil ,result)
`(if (,predicate ,current ,last)
,result nil))))
((zerop i)
`((lambda ,vars ,result) . ,args)))))))
(def-source-transform = (&rest args) (multi-compare '= args nil))
(def-source-transform < (&rest args) (multi-compare '< args nil))
(def-source-transform > (&rest args) (multi-compare '> args nil))
(def-source-transform <= (&rest args) (multi-compare '> args t))
(def-source-transform >= (&rest args) (multi-compare '< args t))
(def-source-transform char= (&rest args) (multi-compare 'char= args nil))
(def-source-transform char< (&rest args) (multi-compare 'char< args nil))
(def-source-transform char> (&rest args) (multi-compare 'char> args nil))
(def-source-transform char<= (&rest args) (multi-compare 'char> args t))
(def-source-transform char>= (&rest args) (multi-compare 'char< args t))
(def-source-transform char-equal (&rest args) (multi-compare 'char-equal args nil))
(def-source-transform char-lessp (&rest args) (multi-compare 'char-lessp args nil))
(def-source-transform char-greaterp (&rest args) (multi-compare 'char-greaterp args nil))
(def-source-transform char-not-greaterp (&rest args) (multi-compare 'char-greaterp args t))
(def-source-transform char-not-lessp (&rest args) (multi-compare 'char-lessp args t))
;;; Multi-Not-Equal -- Internal
;;;
;;; This function does source transformation of N-arg inequality functions
;;; such as /=. This is similar to Multi-Compare in the <3 arg cases. If
;;; there are more than two args, then we expand into the appropriate n^2
;;; comparisons only when speed is important.
;;;
(proclaim '(function multi-not-equal (symbol list)))
(defun multi-not-equal (predicate args)
(let ((nargs (length args)))
(cond ((< nargs 1) (values nil t))
((= nargs 1) `(progn ,@args t))
((= nargs 2)
`(if (,predicate ,(first args) ,(second args)) nil t))
((not (policy nil (>= speed space) (>= speed cspeed)))
(values nil t))
(t
(collect ((vars))
(dotimes (i nargs) (vars (gensym)))
(do ((var (vars) next)
(next (cdr (vars)) (cdr next))
(result 't))
((null next)
`((lambda ,(vars) ,result) . ,args))
(let ((v1 (first var)))
(dolist (v2 next)
(setq result `(if (,predicate ,v1 ,v2) nil ,result))))))))))
(def-source-transform /= (&rest args) (multi-not-equal '= args))
(def-source-transform char/= (&rest args) (multi-not-equal 'char= args))
(def-source-transform char-not-equal (&rest args) (multi-not-equal 'char-equal args))
;;; Expand Max and Min into the obvious comparisons.
(def-source-transform max (arg &rest more-args)
(if (null more-args)
`(values ,arg)
(once-only ((arg1 arg)
(arg2 `(max ,@more-args)))
`(if (> ,arg1 ,arg2)
,arg1 ,arg2))))
;;;
(def-source-transform min (arg &rest more-args)
(if (null more-args)
`(values ,arg)
(once-only ((arg1 arg)
(arg2 `(min ,@more-args)))
`(if (< ,arg1 ,arg2)
,arg1 ,arg2))))
;;;; Converting N-arg arithmetic functions:
;;;
;;; N-arg arithmetic and logic functions are associated into two-arg
;;; versions, and degenerate cases are flushed.
;;; Associate-Arguments -- Internal
;;;
;;; Left-associate First-Arg and More-Args using Function.
;;;
(proclaim '(function associate-arguments (symbol t list) list))
(defun associate-arguments (function first-arg more-args)
(let ((next (rest more-args))
(arg (first more-args)))
(if (null next)
`(,function ,first-arg ,arg)
(associate-arguments function `(,function ,first-arg ,arg) next))))
;;; Source-Transform-Transitive -- Internal
;;;
;;; Do source transformations for transitive functions such as +. One-arg
;;; cases are replaced with the arg and zero arg cases with the identity. If
;;; Leaf-Fun is true, then replace two-arg calls with a call to that function.
;;;
(defun source-transform-transitive (fun args identity &optional leaf-fun)
(declare (symbol fun leaf-fun) (list args))
(case (length args)
(0 identity)
(1 `(values ,(first args)))
(2 (if leaf-fun
`(,leaf-fun ,(first args) ,(second args))
(values nil t)))
(t
(associate-arguments fun (first args) (rest args)))))
(def-source-transform + (&rest args) (source-transform-transitive '+ args 0))
(def-source-transform * (&rest args) (source-transform-transitive '* args 1))
(def-source-transform logior (&rest args) (source-transform-transitive 'logior args 0))
(def-source-transform logxor (&rest args) (source-transform-transitive 'logxor args 0))
(def-source-transform logand (&rest args) (source-transform-transitive 'logand args -1))
(if (evenp (length args))
`(lognot (logxor ,@args))
`(logxor ,@args)))
;;; Note: we can't use source-transform-transitive for GCD and LCM because when
;;; they are given one argument, they return it's absolute value.
(def-source-transform gcd (&rest args)
(case (length args)
(0 0)
(1 `(abs (the integer ,(first args))))
(2 (values nil t))
(t (associate-arguments 'gcd (first args) (rest args)))))
(def-source-transform lcm (&rest args)
(case (length args)
(0 1)
(1 `(abs (the integer ,(first args))))
(2 (values nil t))
(t (associate-arguments 'lcm (first args) (rest args)))))
;;; Source-Transform-Intransitive -- Internal
;;;
;;; Do source transformations for intransitive n-arg functions such as /.
;;; With one arg, we form the inverse. With two args we pass. Otherwise we
;;; associate into two-arg calls.
;;;
(proclaim '(function source-transform-intransitive (symbol list t) list))
(defun source-transform-intransitive (function args inverse)
(1 `(,@inverse ,(first args)))
(t
(associate-arguments function (first args) (rest args)))))
(def-source-transform - (&rest args)
(source-transform-intransitive '- args '(%negate)))
(def-source-transform / (&rest args)
(source-transform-intransitive '/ args '(/ 1)))
;;;; Apply:
;;;
;;; We convert Apply into Multiple-Value-Call so that the compiler only
;;; needs to understand one kind of variable-argument call. It is more
;;; efficient to convert Apply to MV-Call than MV-Call to Apply.
(def-source-transform apply (fun arg &rest more-args)
(let ((args (cons arg more-args)))
`(multiple-value-call ,fun
,@(mapcar #'(lambda (x)
`(values ,x))
(butlast args))
(values-list ,(car (last args))))))
;;;; FORMAT transform:
;;;
;;; If the control string is a compile-time constant, then replace it with
;;; a use of the FORMATTER macro so that the control string is ``compiled.''
;;; Furthermore, if the destination is either a stream or T and the control
;;; string is a function (i.e. formatter), then convert the call to format to
;;; just a funcall of that function.
;;;
(deftransform format ((dest control &rest args) (t simple-string &rest t))
(unless (constant-continuation-p control)
(give-up "Control string is not a constant."))
(let ((arg-names (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) args)))
`(lambda (dest control ,@arg-names)
(declare (ignore control))
(format dest (formatter ,(continuation-value control)) ,@arg-names))))
;;;
(deftransform format ((stream control &rest args) (stream function &rest t))
(let ((arg-names (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) args)))
`(lambda (stream control ,@arg-names)
(funcall control stream ,@arg-names)
nil)))
;;;
(deftransform format ((tee control &rest args) ((member t) function &rest t))
(let ((arg-names (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) args)))
`(lambda (tee control ,@arg-names)
(declare (ignore tee))
(funcall control *standard-output* ,@arg-names)
nil)))