Newer
Older
(%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.
;;;
(deftransform eql ((x y))
(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)))))
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
;;; = 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, so can't open code."))))
;;; 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 '<))
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
;;;; 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)))))
1290
1291
1292
1293
1294
1295
1296
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
;;; Source-Transform-Intransitive -- Internal
;;;
;;; Do source transformations for intransitive n-arg functions such as /.
;;; With one arg, we form the inverse using the indentity, 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 identity)
(case (length args)
((0 2) (values nil t))
(1 `(,function ,identity ,(first args)))
(t
(associate-arguments function (first args) (rest args)))))
(def-source-transform - (&rest args) (source-transform-intransitive '- args 0))
(def-source-transform / (&rest args) (source-transform-intransitive '/ args 1))
(deftransform - ((x y))
(unless (and (constant-continuation-p x) (zerop (continuation-value x)))
(give-up))
'(%negate y))
;;;; 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:
;;; A transform for FORMAT, based on the original (courtesy of Skef.)
;;;
(deftransform format ((stream control &rest args)
((or (member t) stream) simple-string &rest t))
(unless (constant-continuation-p control)
(give-up "Control string is not a constant."))
(let* ((control (continuation-value control))
(end (length control))
(penultimus (1- end))
(stream-form (if (csubtypep (continuation-type stream)
(specifier-type 'stream))
`(stream)
()))
(arg-vars (mapcar #'(lambda (x)
(declare (ignore x))
(gensym))
args))
(args arg-vars)
(index 0))
(declare (simple-string control))
(collect ((forms))
(loop
(let ((command-index (position #\~ control :start index)))
(unless command-index
;; Write out the final part of the string.
(forms `(write-string ,(subseq control index end)
,@stream-form))
(return `(lambda (stream control ,@arg-vars)
(declare (ignorable stream control))
,@(forms)
nil)))
(when (= command-index penultimus)
(abort-transform "FORMAT control string ends in a ~~: ~S"
control))
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
;; Non-command stuff gets write-string'ed out.
(when (/= index command-index)
(forms `(write-string
,(subseq control index command-index)
,@stream-form)))
;; Get the format directive.
(forms
(case (schar control (1+ command-index))
((#\b #\B) `(let ((*print-base* 2))
(princ ,(pop args) ,@stream-form)))
((#\o #\O) `(let ((*print-base* 8))
(princ ,(pop args) ,@stream-form)))
((#\d #\D) `(let ((*print-base* 10))
(princ ,(pop args) ,@stream-form)))
((#\x #\X) `(let ((*print-base* 16))
(princ ,(pop args) ,@stream-form)))
((#\a #\A) `(princ ,(pop args) ,@stream-form))
((#\s #\S) `(prin1 ,(pop args) ,@stream-form))
(#\% `(terpri ,@stream-form))
(#\& `(fresh-line ,@stream-form))
(#\| `(write-char #\form ,@stream-form))
(#\~ `(write-char #\~ ,@stream-form))
(#\newline
(let ((new-pos (position-if-not
#'lisp::whitespace-char-p
control
:start (+ command-index 2))))
(if new-pos
(setq command-index (- new-pos 2)))))
(t
(give-up))))
(setq index (+ command-index 2)))))))