[6] | 1 | ;;;-*- Mode: Lisp; Package: CCL -*- |
---|
| 2 | ;;; |
---|
| 3 | ;;; Copyright (C) 1994-2001 Digitool, Inc |
---|
| 4 | ;;; This file is part of OpenMCL. |
---|
| 5 | ;;; |
---|
| 6 | ;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public |
---|
| 7 | ;;; License , known as the LLGPL and distributed with OpenMCL as the |
---|
| 8 | ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, |
---|
| 9 | ;;; which is distributed with OpenMCL as the file "LGPL". Where these |
---|
| 10 | ;;; conflict, the preamble takes precedence. |
---|
| 11 | ;;; |
---|
| 12 | ;;; OpenMCL is referenced in the preamble as the "LIBRARY." |
---|
| 13 | ;;; |
---|
| 14 | ;;; The LLGPL is also available online at |
---|
| 15 | ;;; http://opensource.franz.com/preamble.html |
---|
[2332] | 16 | |
---|
[6] | 17 | ; Optimizers.lisp - compiler optimizers |
---|
| 18 | |
---|
[2332] | 19 | (in-package "CCL") |
---|
| 20 | |
---|
[6] | 21 | (eval-when (eval compile) |
---|
| 22 | (require'backquote) |
---|
| 23 | (require'lispequ) |
---|
| 24 | (require "ARCH")) |
---|
| 25 | |
---|
| 26 | (declaim (special *nx-can-constant-fold* *nx-synonyms*)) |
---|
| 27 | |
---|
| 28 | (defvar *dont-find-class-optimize* nil) ; t means dont |
---|
| 29 | |
---|
| 30 | #| |
---|
| 31 | ;;; can-constant-fold had a bug in the way it called #'proclaim-inline |
---|
| 32 | |# |
---|
| 33 | |
---|
| 34 | ;;; There seems to be some confusion about what #'proclaim-inline does. |
---|
| 35 | ;;; The value of the alist entry in *nx-proclaimed-inline* indicates |
---|
| 36 | ;;; whether or not the compiler is allowed to use any special knowledge |
---|
| 37 | ;;; about the symbol in question. That's a necessary but not sufficient |
---|
| 38 | ;;; condition to enable inline expansion; that's governed by declarations |
---|
| 39 | ;;; in the compile-time environment. |
---|
| 40 | ;;; If someone observed a symptom whereby calling CAN-CONSTANT-FOLD |
---|
| 41 | ;;; caused unintended inline-expansion, the bug's elsewhere ... |
---|
| 42 | ;;; The bug is that nx-declared-inline-p calls proclaimed-inline-p |
---|
| 43 | ;;; which looks at what proclaim-inline sets. Presumably, that |
---|
| 44 | ;;; means that someone fixed it because it showed evidence of |
---|
| 45 | ;;; being broken. |
---|
| 46 | ;;; The two concepts (the compiler should/should not make assumptions about |
---|
| 47 | ;;; the signature of known functions, the compiler should/should not arrange |
---|
| 48 | ;;; to keep the lambda expression around) need to be sorted out. |
---|
| 49 | |
---|
| 50 | (defun can-constant-fold (names &aux handler inlines) |
---|
| 51 | (dolist (name names) |
---|
| 52 | (if (atom name) |
---|
| 53 | (setq handler nil) |
---|
| 54 | (setq handler (cdr name) name (car name))) |
---|
| 55 | (when (and handler (not (eq handler 'fold-constant-subforms))) |
---|
| 56 | (warn "Unknown constant-fold handler : ~s" handler) |
---|
| 57 | (setq handler nil)) |
---|
| 58 | (let* ((bits (%symbol-bits name))) |
---|
| 59 | (declare (fixnum bits)) |
---|
| 60 | (%symbol-bits name (logior |
---|
| 61 | (if handler (logior (ash 1 $sym_fbit_fold_subforms) (ash 1 $sym_fbit_constant_fold)) |
---|
| 62 | (ash 1 $sym_fbit_constant_fold)) |
---|
| 63 | bits))) |
---|
| 64 | (push name inlines)) |
---|
| 65 | '(apply #'proclaim-inline t inlines) |
---|
| 66 | ) |
---|
| 67 | |
---|
[1989] | 68 | ;;; There's a bit somewhere. This is very partial. Should be a bit |
---|
| 69 | ;;; somewhere, there are too many of these to keep on a list. |
---|
[1140] | 70 | (can-constant-fold '(specfier-type %ilsl %ilsr 1- 1+ eql eq |
---|
[6] | 71 | byte make-point - / (+ . fold-constant-subforms) (* . fold-constant-subforms) ash character |
---|
| 72 | char-code code-char lsh |
---|
| 73 | (logior . fold-constant-subforms) (logand . fold-constant-subforms) |
---|
| 74 | (logxor . fold-constant-subforms) logcount logorc2 listp consp expt |
---|
| 75 | logorc1 logtest lognand logeqv lognor lognot logandc2 logandc1 |
---|
| 76 | numerator denominator ldb-test byte-position byte-size isqrt gcd |
---|
| 77 | floor mod truncate rem round boole max min ldb dpb mask-field deposit-field |
---|
| 78 | length aref svref char schar bit sbit getf identity list-length |
---|
| 79 | car cdr cadr cddr nth nthcdr last load-byte deposit-byte byte-mask |
---|
| 80 | member search count position assoc rassoc integer-length |
---|
| 81 | float not null char-int expt abs)) |
---|
| 82 | |
---|
| 83 | (defun %binop-cassoc (call) |
---|
| 84 | (unless (and (cddr call) (null (cdr (%cddr call)))) |
---|
| 85 | (return-from %binop-cassoc call)) |
---|
| 86 | (let ((func (%car call)) |
---|
| 87 | (arg1 (%cadr call)) |
---|
| 88 | (arg2 (%caddr call)) |
---|
| 89 | (val)) |
---|
| 90 | (cond ((and (fixnump arg1) (fixnump arg2)) |
---|
| 91 | (funcall func arg1 arg2)) |
---|
| 92 | ((or (fixnump arg1) (fixnump arg2)) |
---|
| 93 | (if (fixnump arg2) (psetq arg1 arg2 arg2 arg1)) |
---|
| 94 | (if (and (consp arg2) |
---|
| 95 | (eq (%car arg2) func) |
---|
| 96 | (cddr arg2) |
---|
| 97 | (null (cdr (%cddr arg2))) |
---|
| 98 | (or (fixnump (setq val (%cadr arg2))) |
---|
| 99 | (fixnump (setq val (%caddr arg2))))) |
---|
| 100 | (list func |
---|
| 101 | (funcall func arg1 val) |
---|
| 102 | (if (eq val (%cadr arg2)) (%caddr arg2) (%cadr arg2))) |
---|
| 103 | call)) |
---|
| 104 | (t call)))) |
---|
| 105 | |
---|
| 106 | (defun fixnumify (args op &aux (len (length args))) |
---|
| 107 | (if (eq len 2) |
---|
| 108 | (cons op args) |
---|
| 109 | (list op (%car args) (fixnumify (%cdr args) op)))) |
---|
| 110 | |
---|
| 111 | (defun generic-to-fixnum-n (call env op &aux (args (%cdr call)) targs) |
---|
| 112 | (block nil |
---|
| 113 | (if (and (%i> (length args) 1) |
---|
| 114 | (and (nx-trust-declarations env) |
---|
| 115 | (or (neq op '%i+) (subtypep *nx-form-type* 'fixnum)))) |
---|
| 116 | (if (dolist (arg args t) |
---|
| 117 | (if (nx-form-typep arg 'fixnum env) |
---|
| 118 | (push arg targs) |
---|
| 119 | (return))) |
---|
| 120 | (return |
---|
| 121 | (fixnumify (nreverse targs) op)))) |
---|
| 122 | call)) |
---|
| 123 | |
---|
[1989] | 124 | ;;; True if arg is an alternating list of keywords and args, |
---|
| 125 | ;;; only recognizes keywords in keyword package. |
---|
| 126 | ;;; Historical note: this used to try to ensure that the |
---|
| 127 | ;;; keyword appeared at most once. Why ? (Even before |
---|
| 128 | ;;; destructuring, pl-search/getf would have dtrt.) |
---|
[6] | 129 | (defun constant-keywords-p (keys) |
---|
| 130 | (when (plistp keys) |
---|
| 131 | (while keys |
---|
| 132 | (unless (keywordp (%car keys)) |
---|
| 133 | (return-from constant-keywords-p nil)) |
---|
| 134 | (setq keys (%cddr keys))) |
---|
| 135 | t)) |
---|
| 136 | |
---|
[7624] | 137 | (defun remove-explicit-test-keyword-from-test-testnot-key (item list keys default alist testonly) |
---|
| 138 | (if (null keys) |
---|
| 139 | `(,default ,item ,list) |
---|
| 140 | (if (constant-keywords-p keys) |
---|
[6] | 141 | (destructuring-bind (&key (test nil test-p) |
---|
| 142 | (test-not nil test-not-p) |
---|
| 143 | (key nil key-p)) |
---|
| 144 | keys |
---|
[7624] | 145 | (declare (ignore test-not)) |
---|
[6] | 146 | (if (and test-p |
---|
[7624] | 147 | (not test-not-p) |
---|
| 148 | (or (not key-p) |
---|
| 149 | (and (consp key) |
---|
| 150 | (consp (%cdr key)) |
---|
| 151 | (null (%cddr key)) |
---|
| 152 | (or (eq (%car key) 'function) |
---|
| 153 | (eq (%car key) 'quote)) |
---|
| 154 | (eq (%cadr key) 'identity))) |
---|
[6] | 155 | (consp test) |
---|
| 156 | (consp (%cdr test)) |
---|
| 157 | (null (%cddr test)) |
---|
| 158 | (or (eq (%car test) 'function) |
---|
| 159 | (eq (%car test) 'quote))) |
---|
[7624] | 160 | (let* ((testname (%cadr test)) |
---|
| 161 | (reduced (cdr (assoc testname alist)))) |
---|
| 162 | (if reduced |
---|
| 163 | `(,reduced ,item ,list) |
---|
| 164 | `(,testonly ,item ,list ,test)))))))) |
---|
[6] | 165 | |
---|
[7624] | 166 | |
---|
[6] | 167 | (defun eql-iff-eq-p (thing env) |
---|
[3660] | 168 | (if (quoted-form-p thing) |
---|
| 169 | (setq thing (%cadr thing)) |
---|
| 170 | (if (not (self-evaluating-p thing)) |
---|
[6] | 171 | (return-from eql-iff-eq-p |
---|
[7624] | 172 | (or (nx-form-typep thing 'symbol env) |
---|
| 173 | (nx-form-typep thing 'character env) |
---|
| 174 | (nx-form-typep thing |
---|
| 175 | '(or fixnum |
---|
| 176 | #+64-bit-target single-float |
---|
| 177 | symbol character |
---|
| 178 | (and (not number) (not macptr))) env))))) |
---|
[3660] | 179 | (or (fixnump thing) #+64-bit-target (typep thing 'single-float) |
---|
[7624] | 180 | (symbolp thing) (characterp thing) |
---|
[3660] | 181 | (and (not (numberp thing)) (not (macptrp thing))))) |
---|
[6] | 182 | |
---|
[7624] | 183 | (defun equal-iff-eql-p (thing env) |
---|
| 184 | (if (quoted-form-p thing) |
---|
| 185 | (setq thing (%cadr thing)) |
---|
| 186 | (if (not (self-evaluating-p thing)) |
---|
| 187 | (return-from equal-iff-eql-p |
---|
| 188 | (nx-form-typep thing |
---|
| 189 | '(and (not cons) (not string) (not bit-vector) (not pathname)) env)))) |
---|
| 190 | (not (typep thing '(or cons string bit-vector pathname)))) |
---|
| 191 | |
---|
| 192 | |
---|
[6] | 193 | (defun fold-constant-subforms (call env) |
---|
| 194 | (let* ((constants nil) |
---|
| 195 | (forms nil)) |
---|
| 196 | (declare (list constants forms)) |
---|
| 197 | (dolist (form (cdr call)) |
---|
| 198 | (setq form (nx-transform form env)) |
---|
| 199 | (if (numberp form) |
---|
| 200 | (setq constants (%temp-cons form constants)) |
---|
| 201 | (setq forms (%temp-cons form forms)))) |
---|
| 202 | (if constants |
---|
| 203 | (let* ((op (car call)) |
---|
| 204 | (constant (if (cdr constants) (handler-case (apply op constants) |
---|
| 205 | (error (c) (declare (ignore c)) |
---|
| 206 | (return-from fold-constant-subforms (values call t)))) |
---|
| 207 | (car constants)))) |
---|
| 208 | (values (if forms (cons op (cons constant (reverse forms))) constant) t)) |
---|
| 209 | (values call nil)))) |
---|
| 210 | |
---|
| 211 | ;;; inline some, etc. in some cases |
---|
| 212 | ;;; in all cases, add dynamic-extent declarations |
---|
| 213 | (defun some-xx-transform (call env) |
---|
| 214 | (destructuring-bind (func predicate sequence &rest args) call |
---|
| 215 | (multiple-value-bind (func-constant end-value loop-test) |
---|
| 216 | (case func |
---|
| 217 | (some (values $some nil 'when)) |
---|
| 218 | (notany (values $notany t 'when)) |
---|
| 219 | (every (values $every t 'unless)) |
---|
| 220 | (notevery (values $notevery nil 'unless))) |
---|
| 221 | (if args |
---|
| 222 | (let ((func-sym (gensym)) |
---|
| 223 | (seq-sym (gensym)) |
---|
| 224 | (list-sym (gensym))) |
---|
| 225 | `(let ((,func-sym ,predicate) |
---|
| 226 | (,seq-sym ,sequence) |
---|
| 227 | (,list-sym (list ,@args))) |
---|
| 228 | (declare (dynamic-extent ,func-sym ,list-sym ,seq-sym)) |
---|
| 229 | (some-xx-multi ,func-constant ,end-value ,func-sym ,seq-sym ,list-sym))) |
---|
| 230 | (let ((loop-function (nx-form-sequence-iterator sequence env))) |
---|
| 231 | ;; inline if we know the type of the sequence and if |
---|
| 232 | ;; the predicate is a lambda expression |
---|
| 233 | ;; otherwise, it blows up the code for not much gain |
---|
| 234 | (if (and loop-function |
---|
| 235 | (function-form-p predicate) |
---|
| 236 | (lambda-expression-p (second predicate))) |
---|
| 237 | (let ((elt-var (gensym))) |
---|
| 238 | (case func |
---|
| 239 | (some |
---|
| 240 | `(,loop-function (,elt-var ,sequence ,end-value) |
---|
| 241 | (let ((result (funcall ,predicate ,elt-var))) |
---|
| 242 | (when result (return result))))) |
---|
| 243 | ((every notevery notany) |
---|
| 244 | `(,loop-function (,elt-var ,sequence ,end-value) |
---|
| 245 | (,loop-test (funcall ,predicate ,elt-var) |
---|
| 246 | (return ,(not end-value))))))) |
---|
| 247 | (let ((func-sym (gensym)) |
---|
| 248 | (seq-sym (gensym))) |
---|
| 249 | `(let ((,func-sym ,predicate) |
---|
| 250 | (,seq-sym ,sequence)) |
---|
| 251 | (declare (dynamic-extent ,func-sym ,seq-sym)) |
---|
| 252 | (some-xx-one ,func-constant ,end-value ,func-sym ,seq-sym))))))))) |
---|
| 253 | |
---|
| 254 | |
---|
| 255 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
---|
[1989] | 256 | ;;; |
---|
| 257 | ;;; The new (roughly alphabetical) order. |
---|
| 258 | ;;; |
---|
[6] | 259 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
---|
| 260 | |
---|
[1989] | 261 | ;;; Compiler macros on functions can assume that their arguments have |
---|
| 262 | ;;; already been transformed. |
---|
[6] | 263 | |
---|
| 264 | |
---|
| 265 | (defun transform-real-n-ary-comparision (whole binary-name) |
---|
| 266 | (destructuring-bind (n0 &optional (n1 0 n1-p) &rest more) (cdr whole) |
---|
| 267 | (if more |
---|
[2248] | 268 | (if (cdr more) |
---|
| 269 | whole |
---|
| 270 | (let* ((n2 (car more)) |
---|
| 271 | (n (gensym))) |
---|
| 272 | `(let* ((,n ,n0)) |
---|
| 273 | (if (,binary-name ,n (setq ,n ,n1)) |
---|
| 274 | (,binary-name ,n ,n2))))) |
---|
[6] | 275 | (if (not n1-p) |
---|
| 276 | `(require-type ,n0 'real) |
---|
| 277 | `(,binary-name ,n0 ,n1))))) |
---|
| 278 | |
---|
| 279 | |
---|
| 280 | |
---|
| 281 | (define-compiler-macro < (&whole whole &rest ignore) |
---|
| 282 | (declare (ignore ignore)) |
---|
| 283 | (transform-real-n-ary-comparision whole '<-2)) |
---|
| 284 | |
---|
| 285 | (define-compiler-macro > (&whole whole &rest ignore) |
---|
| 286 | (declare (ignore ignore)) |
---|
| 287 | (transform-real-n-ary-comparision whole '>-2)) |
---|
| 288 | |
---|
| 289 | (define-compiler-macro <= (&whole whole &rest ignore) |
---|
| 290 | (declare (ignore ignore)) |
---|
| 291 | (transform-real-n-ary-comparision whole '<=-2)) |
---|
| 292 | |
---|
| 293 | (define-compiler-macro >= (&whole whole &rest ignore) |
---|
| 294 | (declare (ignore ignore)) |
---|
| 295 | (transform-real-n-ary-comparision whole '>=-2)) |
---|
| 296 | |
---|
| 297 | |
---|
| 298 | (define-compiler-macro 1- (x) |
---|
| 299 | `(- ,x 1)) |
---|
| 300 | |
---|
| 301 | (define-compiler-macro 1+ (x) |
---|
| 302 | `(+ ,x 1)) |
---|
| 303 | |
---|
| 304 | (define-compiler-macro append (&whole call |
---|
| 305 | &optional arg0 |
---|
| 306 | &rest |
---|
| 307 | (&whole tail |
---|
| 308 | &optional (junk nil arg1-p) |
---|
| 309 | &rest more)) |
---|
| 310 | ;(append (list x y z) A) -> (list* x y z A) |
---|
| 311 | (if (and arg1-p |
---|
| 312 | (null more) |
---|
| 313 | (consp arg0) |
---|
| 314 | (eq (%car arg0) 'list)) |
---|
| 315 | (cons 'list* (append (%cdr arg0) tail)) |
---|
| 316 | (if (and arg1-p (null more)) |
---|
| 317 | `(append-2 ,arg0 ,junk) |
---|
| 318 | call))) |
---|
| 319 | |
---|
| 320 | (define-compiler-macro apply (&whole call &environment env fn arg0 &rest args) |
---|
[7841] | 321 | ;; Special-case (apply #'make-instance 'name ...) |
---|
| 322 | ;; Might be good to make this a little more general, e.g., there |
---|
| 323 | ;; may be other things that can be strength-reduced even if we can't |
---|
| 324 | ;; get rid of the APPLY. |
---|
| 325 | (if (and (consp fn) |
---|
| 326 | (or (eq (car fn) 'quote) |
---|
| 327 | (eq (car fn) 'function)) |
---|
| 328 | (consp (cdr fn)) |
---|
| 329 | (null (cddr fn)) |
---|
| 330 | (eq (cadr fn) 'make-instance) |
---|
| 331 | (consp arg0) |
---|
[7843] | 332 | (eq (car arg0) 'quote) |
---|
[7841] | 333 | (consp (cdr arg0)) |
---|
| 334 | (symbolp (cadr arg0))) |
---|
| 335 | (let* ((name (cadr arg0)) |
---|
| 336 | (class-cell (gensym))) |
---|
| 337 | `(let* ((,class-cell (load-time-value (find-class-cell ',name t)))) |
---|
| 338 | (apply (class-cell-instantiate ,class-cell) ,class-cell ,@args))) |
---|
| 339 | (let ((original-fn fn)) |
---|
| 340 | (if (and arg0 |
---|
| 341 | (null args) |
---|
| 342 | (consp fn) |
---|
| 343 | (eq (%car fn) 'function) |
---|
| 344 | (null (cdr (%cdr fn))) |
---|
| 345 | (consp (setq fn (%cadr fn))) |
---|
| 346 | (eq (%car fn) 'lambda)) |
---|
| 347 | (destructuring-bind (lambda-list &body body) (%cdr fn) |
---|
| 348 | `(destructuring-bind ,lambda-list ,arg0 ,@body)) |
---|
| 349 | (let ((last (%car (last (push arg0 args))))) |
---|
| 350 | (if (and (consp last) (memq (%car last) '(cons list* list))) |
---|
| 351 | (cons (if (eq (%car last) 'list) 'funcall 'apply) |
---|
| 352 | (cons |
---|
| 353 | original-fn |
---|
| 354 | (nreconc (cdr (reverse args)) (%cdr last)))) |
---|
| 355 | call)))))) |
---|
[6] | 356 | |
---|
| 357 | |
---|
| 358 | |
---|
[7624] | 359 | (define-compiler-macro assoc (&whole call item list &rest keys) |
---|
| 360 | (or (remove-explicit-test-keyword-from-test-testnot-key item list keys 'asseql '((eq . assq) (eql . asseql) (equal . assequal)) 'assoc-test) |
---|
[6] | 361 | call)) |
---|
| 362 | |
---|
[7624] | 363 | (define-compiler-macro assequal (&whole call &environment env item list) |
---|
| 364 | (if (or (equal-iff-eql-p item env) |
---|
| 365 | (and (quoted-form-p list) |
---|
| 366 | (proper-list-p (%cadr list)) |
---|
| 367 | (every (lambda (x) (equal-iff-eql-p (car x) env)) (%cadr list)))) |
---|
| 368 | `(asseql ,item ,list) |
---|
| 369 | call)) |
---|
| 370 | |
---|
| 371 | (define-compiler-macro asseql (&whole call &environment env item list) |
---|
| 372 | (if (or (eql-iff-eq-p item env) |
---|
| 373 | (and (quoted-form-p list) |
---|
| 374 | (proper-list-p (%cadr list)) |
---|
| 375 | (every (lambda (x) (eql-iff-eq-p (car x) env)) (%cadr list)))) |
---|
| 376 | `(assq ,item ,list) |
---|
| 377 | call)) |
---|
[2280] | 378 | |
---|
[7624] | 379 | (define-compiler-macro assq (item list) |
---|
| 380 | (let* ((itemx (gensym)) |
---|
| 381 | (listx (gensym)) |
---|
| 382 | (pair (gensym))) |
---|
| 383 | `(let* ((,itemx ,item) |
---|
| 384 | (,listx ,list)) |
---|
| 385 | (dolist (,pair ,listx) |
---|
| 386 | (when (and ,pair (eq (car ,pair) ,itemx)) (return ,pair)))))) |
---|
| 387 | |
---|
[2280] | 388 | (define-compiler-macro caar (form) |
---|
| 389 | `(car (car ,form))) |
---|
| 390 | |
---|
| 391 | (define-compiler-macro cadr (form) |
---|
| 392 | `(car (cdr ,form))) |
---|
| 393 | |
---|
| 394 | (define-compiler-macro cdar (form) |
---|
| 395 | `(cdr (car ,form))) |
---|
| 396 | |
---|
| 397 | (define-compiler-macro cddr (form) |
---|
| 398 | `(cdr (cdr ,form))) |
---|
| 399 | |
---|
[6] | 400 | (define-compiler-macro caaar (form) |
---|
| 401 | `(car (caar ,form))) |
---|
| 402 | |
---|
| 403 | (define-compiler-macro caadr (form) |
---|
| 404 | `(car (cadr ,form))) |
---|
| 405 | |
---|
| 406 | (define-compiler-macro cadar (form) |
---|
| 407 | `(car (cdar ,form))) |
---|
| 408 | |
---|
| 409 | (define-compiler-macro caddr (form) |
---|
| 410 | `(car (cddr ,form))) |
---|
| 411 | |
---|
| 412 | (define-compiler-macro cdaar (form) |
---|
| 413 | `(cdr (caar ,form))) |
---|
| 414 | |
---|
| 415 | (define-compiler-macro cdadr (form) |
---|
| 416 | `(cdr (cadr ,form))) |
---|
| 417 | |
---|
| 418 | (define-compiler-macro cddar (form) |
---|
| 419 | `(cdr (cdar ,form))) |
---|
| 420 | |
---|
| 421 | (define-compiler-macro cdddr (form) |
---|
| 422 | `(cdr (cddr ,form))) |
---|
| 423 | |
---|
[2280] | 424 | (define-compiler-macro caaaar (form) |
---|
| 425 | `(car (caaar ,form))) |
---|
| 426 | |
---|
| 427 | (define-compiler-macro caaadr (form) |
---|
| 428 | `(car (caadr ,form))) |
---|
[6] | 429 | |
---|
[2280] | 430 | (define-compiler-macro caadar (form) |
---|
| 431 | `(car (cadar ,form))) |
---|
[6] | 432 | |
---|
[2280] | 433 | (define-compiler-macro caaddr (form) |
---|
| 434 | `(car (caddr ,form))) |
---|
[6] | 435 | |
---|
[2280] | 436 | (define-compiler-macro cadaar (form) |
---|
| 437 | `(car (cdaar ,form))) |
---|
| 438 | |
---|
| 439 | (define-compiler-macro cadadr (form) |
---|
| 440 | `(car (cdadr ,form))) |
---|
| 441 | |
---|
| 442 | (define-compiler-macro caddar (form) |
---|
| 443 | `(car (cddar ,form))) |
---|
| 444 | |
---|
| 445 | (define-compiler-macro cadddr (form) |
---|
| 446 | `(car (cdddr ,form))) |
---|
| 447 | |
---|
| 448 | (define-compiler-macro cdaaar (form) |
---|
| 449 | `(cdr (caaar ,form))) |
---|
| 450 | |
---|
| 451 | (define-compiler-macro cdaadr (form) |
---|
| 452 | `(cdr (caadr ,form))) |
---|
| 453 | |
---|
| 454 | (define-compiler-macro cdadar (form) |
---|
| 455 | `(cdr (cadar ,form))) |
---|
| 456 | |
---|
| 457 | (define-compiler-macro cdaddr (form) |
---|
| 458 | `(cdr (caddr ,form))) |
---|
| 459 | |
---|
| 460 | (define-compiler-macro cddaar (form) |
---|
| 461 | `(cdr (cdaar ,form))) |
---|
| 462 | |
---|
| 463 | (define-compiler-macro cddadr (form) |
---|
| 464 | `(cdr (cdadr ,form))) |
---|
| 465 | |
---|
| 466 | (define-compiler-macro cdddar (form) |
---|
| 467 | `(cdr (cddar ,form))) |
---|
| 468 | |
---|
| 469 | (define-compiler-macro cddddr (form) |
---|
| 470 | `(cdr (cdddr ,form))) |
---|
| 471 | |
---|
| 472 | |
---|
| 473 | |
---|
| 474 | |
---|
[6] | 475 | (define-compiler-macro cons (&whole call &environment env x y &aux dcall ddcall) |
---|
| 476 | (if (consp (setq dcall y)) |
---|
| 477 | (cond |
---|
| 478 | ((or (eq (%car dcall) 'list) (eq (%car dcall) 'list*)) |
---|
| 479 | ;(CONS A (LIST[*] . args)) -> (LIST[*] A . args) |
---|
| 480 | (list* (%car dcall) x (%cdr dcall))) |
---|
| 481 | ((or (neq (%car dcall) 'cons) (null (cddr dcall)) (cdddr dcall)) |
---|
| 482 | call) |
---|
| 483 | ((null (setq ddcall (%caddr dcall))) |
---|
| 484 | ;(CONS A (CONS B NIL)) -> (LIST A B) |
---|
| 485 | `(list ,x ,(%cadr dcall))) |
---|
| 486 | ((and (consp ddcall) |
---|
| 487 | (eq (%car ddcall) 'cons) |
---|
| 488 | (eq (list-length ddcall) 3)) |
---|
| 489 | ;(CONS A (CONS B (CONS C D))) -> (LIST* A B C D) |
---|
| 490 | (list* 'list* x (%cadr dcall) (%cdr ddcall))) |
---|
| 491 | (t call)) |
---|
| 492 | call)) |
---|
| 493 | |
---|
| 494 | (define-compiler-macro dotimes (&whole call (i n &optional result) |
---|
| 495 | &body body |
---|
| 496 | &environment env) |
---|
| 497 | (multiple-value-bind (body decls) (parse-body body env) |
---|
| 498 | (if (nx-form-typep (setq n (nx-transform n env)) 'fixnum env) |
---|
| 499 | (let* ((limit (gensym)) |
---|
| 500 | (upper (if (constantp n) n most-positive-fixnum)) |
---|
| 501 | (top (gensym)) |
---|
| 502 | (test (gensym))) |
---|
| 503 | `(let* ((,limit ,n) (,i 0)) |
---|
| 504 | ,@decls |
---|
| 505 | (declare (fixnum ,limit) |
---|
| 506 | (type (integer 0 ,(if (<= upper 0) 0 `(,upper))) ,i) |
---|
| 507 | (unsettable ,i)) |
---|
| 508 | (block nil |
---|
| 509 | (tagbody |
---|
| 510 | (go ,test) |
---|
| 511 | ,top |
---|
| 512 | ,@body |
---|
| 513 | (locally |
---|
| 514 | (declare (settable ,i)) |
---|
| 515 | (setq ,i (1+ ,i))) |
---|
| 516 | ,test |
---|
| 517 | (when (< ,i ,limit) (go ,top))) |
---|
| 518 | ,result))) |
---|
| 519 | call))) |
---|
| 520 | |
---|
| 521 | (define-compiler-macro dpb (&whole call &environment env value byte integer) |
---|
[305] | 522 | (cond ((and (integerp byte) (> byte 0)) |
---|
[6] | 523 | (if (integerp value) |
---|
| 524 | `(logior ,(dpb value byte 0) (logand ,(lognot byte) ,integer)) |
---|
| 525 | `(deposit-field (ash ,value ,(byte-position byte)) ,byte ,integer))) |
---|
| 526 | ((and (consp byte) |
---|
| 527 | (eq (%car byte) 'byte) |
---|
| 528 | (eq (list-length (%cdr byte)) 2)) |
---|
| 529 | `(deposit-byte ,value ,(%cadr byte) ,(%caddr byte) ,integer)) |
---|
| 530 | (t call))) |
---|
| 531 | |
---|
| 532 | (define-compiler-macro eql (&whole call &environment env v1 v2) |
---|
| 533 | (if (or (eql-iff-eq-p v1 env) (eql-iff-eq-p v2 env)) |
---|
| 534 | `(eq ,v1 ,v2) |
---|
| 535 | call)) |
---|
| 536 | |
---|
| 537 | (define-compiler-macro every (&whole call &environment env &rest ignore) |
---|
| 538 | (declare (ignore ignore)) |
---|
| 539 | (some-xx-transform call env)) |
---|
| 540 | |
---|
| 541 | |
---|
| 542 | (define-compiler-macro identity (form) form) |
---|
| 543 | |
---|
| 544 | (define-compiler-macro if (&whole call test true &optional false &environment env) |
---|
| 545 | (multiple-value-bind (test test-win) (nx-transform test env) |
---|
| 546 | (multiple-value-bind (true true-win) (nx-transform true env) |
---|
| 547 | (multiple-value-bind (false false-win) (nx-transform false env) |
---|
| 548 | (if (or (quoted-form-p test) (self-evaluating-p test)) |
---|
| 549 | (if (eval test) |
---|
| 550 | true |
---|
| 551 | false) |
---|
| 552 | (if (or test-win true-win false-win) |
---|
| 553 | `(if ,test ,true ,false) |
---|
| 554 | call)))))) |
---|
| 555 | |
---|
| 556 | (define-compiler-macro %ilsr (&whole call &environment env shift value) |
---|
| 557 | (if (eql shift 0) |
---|
| 558 | value |
---|
| 559 | (if (eql value 0) |
---|
| 560 | `(progn ,shift 0) |
---|
| 561 | call))) |
---|
| 562 | |
---|
| 563 | |
---|
| 564 | (define-compiler-macro ldb (&whole call &environment env byte integer) |
---|
[305] | 565 | (cond ((and (integerp byte) (> byte 0)) |
---|
[6] | 566 | (let ((size (byte-size byte)) |
---|
| 567 | (position (byte-position byte))) |
---|
| 568 | (cond ((nx-form-typep integer 'fixnum env) |
---|
| 569 | `(logand ,(byte-mask size) |
---|
[5263] | 570 | (the fixnum (ash ,integer ,(- position))))) |
---|
[6] | 571 | (t `(load-byte ,size ,position ,integer))))) |
---|
| 572 | ((and (consp byte) |
---|
| 573 | (eq (%car byte) 'byte) |
---|
| 574 | (eq (list-length (%cdr byte)) 2)) |
---|
| 575 | (let ((size (%cadr byte)) |
---|
| 576 | (position (%caddr byte))) |
---|
| 577 | (if (and (nx-form-typep integer 'fixnum env) (fixnump position)) |
---|
[4137] | 578 | ;; I'm not sure this is worth doing |
---|
[5263] | 579 | `(logand (byte-mask ,size) (the fixnum (ash ,integer ,(- position)))) |
---|
[4137] | 580 | ;; this IS worth doing |
---|
[6] | 581 | `(load-byte ,size ,position ,integer)))) |
---|
| 582 | (t call))) |
---|
| 583 | |
---|
| 584 | (define-compiler-macro length (&whole call &environment env seq) |
---|
| 585 | (if (nx-form-typep seq '(simple-array * (*)) env) |
---|
| 586 | `(uvsize ,seq) |
---|
| 587 | call)) |
---|
| 588 | |
---|
| 589 | (define-compiler-macro let (&whole call (&optional (first nil first-p) &rest rest) &body body) |
---|
| 590 | (if first-p |
---|
| 591 | (if rest |
---|
| 592 | call |
---|
| 593 | `(let* (,first) ,@body)) |
---|
| 594 | `(locally ,@body))) |
---|
| 595 | |
---|
| 596 | (define-compiler-macro let* (&whole call (&rest bindings) &body body) |
---|
| 597 | (if bindings |
---|
| 598 | call |
---|
| 599 | `(locally ,@body))) |
---|
| 600 | |
---|
| 601 | (define-compiler-macro list* (&whole call &environment env &rest rest &aux (n (list-length rest)) last) |
---|
| 602 | (cond ((%izerop n) nil) |
---|
| 603 | ((null (setq last (%car (last call)))) |
---|
| 604 | (cons 'list (nreverse (cdr (reverse (cdr call)))))) |
---|
| 605 | ((and (consp last) (memq (%car last) '(list* list cons))) |
---|
| 606 | (cons (if (eq (%car last) 'cons) 'list* (%car last)) |
---|
| 607 | (nreconc (cdr (reverse (cdr call))) (%cdr last)))) |
---|
| 608 | ((eq n 1) (list 'values last)) |
---|
| 609 | ((eq n 2) (cons 'cons (%cdr call))) |
---|
| 610 | (t call))) |
---|
| 611 | |
---|
| 612 | |
---|
| 613 | |
---|
[1989] | 614 | ;;;(CONS X NIL) is same size as (LIST X) and faster. |
---|
[6] | 615 | (define-compiler-macro list (&whole call &optional (first nil first-p) &rest more) |
---|
| 616 | (if more |
---|
| 617 | call |
---|
| 618 | (if first-p |
---|
| 619 | `(cons ,first nil)))) |
---|
| 620 | |
---|
| 621 | |
---|
| 622 | (define-compiler-macro locally (&whole call &body body &environment env) |
---|
| 623 | (multiple-value-bind (body decls) (parse-body body env nil) |
---|
| 624 | (if decls |
---|
| 625 | call |
---|
| 626 | `(progn ,@body)))) |
---|
| 627 | |
---|
| 628 | |
---|
[1373] | 629 | (defun target-element-type-type-keyword (typespec) |
---|
| 630 | (let* ((ctype (ignore-errors (specifier-type `(array ,typespec))))) |
---|
[6] | 631 | (if (or (null ctype) (typep ctype 'unknown-ctype)) |
---|
| 632 | (progn |
---|
| 633 | (nx1-whine :unknown-type-declaration typespec) |
---|
| 634 | nil) |
---|
[1373] | 635 | (funcall (arch::target-array-type-name-from-ctype-function |
---|
| 636 | (backend-target-arch *target-backend*)) |
---|
| 637 | ctype)))) |
---|
[6] | 638 | |
---|
[5525] | 639 | (defun infer-array-type (dims element-type element-type-p displaced-to-p fill-pointer-p adjustable-p env) |
---|
| 640 | (let* ((ctype (make-array-ctype :complexp (or displaced-to-p fill-pointer-p adjustable-p)))) |
---|
| 641 | (if (quoted-form-p dims) |
---|
| 642 | (let* ((dims (nx-unquote dims))) |
---|
| 643 | (if (listp dims) |
---|
| 644 | (progn |
---|
| 645 | (unless (every #'fixnump dims) |
---|
| 646 | (warn "Funky-looking array dimensions ~s in MAKE-ARRAY call" dims)) |
---|
| 647 | (setf (array-ctype-dimensions ctype) dims)) |
---|
| 648 | (progn |
---|
| 649 | (unless (typep dims 'fixnum) |
---|
| 650 | (warn "Funky-looking array dimensions ~s in MAKE-ARRAY call" dims)) |
---|
| 651 | (setf (array-ctype-dimensions ctype) (list dims))))) |
---|
| 652 | (if (atom dims) |
---|
| 653 | (if (nx-form-typep dims 'fixnum env) |
---|
| 654 | (setf (array-ctype-dimensions ctype) |
---|
| 655 | (if (typep (setq dims (nx-transform dims env)) 'fixnum) |
---|
| 656 | (list dims) |
---|
| 657 | (list '*))) |
---|
| 658 | (setf (array-ctype-dimensions ctype) '*)) |
---|
| 659 | (if (eq (car dims) 'list) |
---|
| 660 | (setf (array-ctype-dimensions ctype) |
---|
| 661 | (mapcar #'(lambda (d) |
---|
| 662 | (if (typep (setq d (nx-transform d env)) 'fixnum) |
---|
| 663 | d |
---|
| 664 | '*)) |
---|
| 665 | (cdr dims))) |
---|
| 666 | ;; Wimp out |
---|
| 667 | (setf (array-ctype-dimensions ctype) |
---|
| 668 | '*)))) |
---|
[6177] | 669 | (let* ((element-type (specifier-type (if element-type-p (nx-unquote element-type) t)))) |
---|
[5525] | 670 | (setf (array-ctype-element-type ctype) element-type) |
---|
| 671 | (if (typep element-type 'unknown-ctype) |
---|
| 672 | (setf (array-ctype-specialized-element-type ctype) *wild-type*) |
---|
| 673 | (specialize-array-type ctype))) |
---|
| 674 | (type-specifier ctype))) |
---|
| 675 | |
---|
| 676 | |
---|
| 677 | |
---|
[6] | 678 | (define-compiler-macro make-array (&whole call &environment env dims &rest keys) |
---|
| 679 | (if (constant-keywords-p keys) |
---|
| 680 | (destructuring-bind (&key (element-type t element-type-p) |
---|
| 681 | (displaced-to () displaced-to-p) |
---|
| 682 | (displaced-index-offset () displaced-index-offset-p) |
---|
| 683 | (adjustable () adjustable-p) |
---|
| 684 | (fill-pointer () fill-pointer-p) |
---|
| 685 | (initial-element () initial-element-p) |
---|
| 686 | (initial-contents () initial-contents-p)) |
---|
[5525] | 687 | keys |
---|
| 688 | (declare (ignorable element-type element-type-p |
---|
| 689 | displaced-to displaced-to-p |
---|
| 690 | displaced-index-offset displaced-index-offset-p |
---|
| 691 | adjustable adjustable-p |
---|
| 692 | fill-pointer fill-pointer-p |
---|
| 693 | initial-element initial-element-p |
---|
| 694 | initial-contents initial-contents-p)) |
---|
| 695 | (let* ((element-type-keyword nil) |
---|
| 696 | (expansion |
---|
| 697 | (cond ((and initial-element-p initial-contents-p) |
---|
| 698 | (nx1-whine 'illegal-arguments call) |
---|
| 699 | call) |
---|
| 700 | (displaced-to-p |
---|
| 701 | (if (or initial-element-p initial-contents-p element-type-p) |
---|
| 702 | (comp-make-array-1 dims keys) |
---|
| 703 | (comp-make-displaced-array dims keys))) |
---|
| 704 | ((or displaced-index-offset-p |
---|
| 705 | (not (constantp element-type)) |
---|
| 706 | (null (setq element-type-keyword |
---|
| 707 | (target-element-type-type-keyword |
---|
| 708 | (eval element-type))))) |
---|
| 709 | (comp-make-array-1 dims keys)) |
---|
| 710 | ((and (typep element-type-keyword 'keyword) |
---|
| 711 | (nx-form-typep dims 'fixnum env) |
---|
| 712 | (null (or adjustable fill-pointer initial-contents |
---|
| 713 | initial-contents-p))) |
---|
| 714 | (if |
---|
| 715 | (or (null initial-element-p) |
---|
| 716 | (cond ((eql element-type-keyword :double-float-vector) |
---|
| 717 | (eql initial-element 0.0d0)) |
---|
| 718 | ((eql element-type-keyword :single-float-vector) |
---|
| 719 | (eql initial-element 0.0s0)) |
---|
| 720 | ((eql element-type :simple-string) |
---|
| 721 | (eql initial-element #\Null)) |
---|
| 722 | (t (eql initial-element 0)))) |
---|
| 723 | `(allocate-typed-vector ,element-type-keyword ,dims) |
---|
| 724 | `(allocate-typed-vector ,element-type-keyword ,dims ,initial-element))) |
---|
| 725 | (t ;Should do more here |
---|
| 726 | (comp-make-uarray dims keys (type-keyword-code element-type-keyword))))) |
---|
| 727 | (type (infer-array-type dims element-type element-type-p displaced-to-p fill-pointer-p adjustable-p env))) |
---|
| 728 | `(the ,type ,expansion))) |
---|
| 729 | |
---|
| 730 | call)) |
---|
[6] | 731 | |
---|
| 732 | (defun comp-make-displaced-array (dims keys) |
---|
| 733 | (let* ((call-list (make-list 4 :initial-element nil)) |
---|
| 734 | (dims-var (make-symbol "DIMS")) |
---|
| 735 | (let-list (comp-nuke-keys keys |
---|
| 736 | '((:displaced-to 0) |
---|
| 737 | (:fill-pointer 1) |
---|
| 738 | (:adjustable 2) |
---|
| 739 | (:displaced-index-offset 3)) |
---|
| 740 | call-list |
---|
| 741 | `((,dims-var ,dims))))) |
---|
| 742 | |
---|
| 743 | `(let ,let-list |
---|
[609] | 744 | (%make-displaced-array ,dims-var ,@call-list t)))) |
---|
[6] | 745 | |
---|
| 746 | (defun comp-make-uarray (dims keys subtype) |
---|
[1373] | 747 | (if (null keys) |
---|
| 748 | `(%make-simple-array ,subtype ,dims) |
---|
| 749 | (let* ((call-list (make-list 6)) |
---|
| 750 | (dims-var (make-symbol "DIMS")) |
---|
[6] | 751 | (let-list (comp-nuke-keys keys |
---|
| 752 | '((:adjustable 0) |
---|
| 753 | (:fill-pointer 1) |
---|
| 754 | (:initial-element 2 3) |
---|
| 755 | (:initial-contents 4 5)) |
---|
| 756 | call-list |
---|
| 757 | `((,dims-var ,dims))))) |
---|
| 758 | `(let ,let-list |
---|
[1373] | 759 | (make-uarray-1 ,subtype ,dims-var ,@call-list nil nil))))) |
---|
[6] | 760 | |
---|
| 761 | (defun comp-make-array-1 (dims keys) |
---|
| 762 | (let* ((call-list (make-list 10 :initial-element nil)) |
---|
| 763 | (dims-var (make-symbol "DIMS")) |
---|
| 764 | (let-list (comp-nuke-keys keys |
---|
| 765 | '((:element-type 0 1) |
---|
| 766 | (:displaced-to 2) |
---|
| 767 | (:displaced-index-offset 3) |
---|
| 768 | (:adjustable 4) |
---|
| 769 | (:fill-pointer 5) |
---|
| 770 | (:initial-element 6 7) |
---|
| 771 | (:initial-contents 8 9)) |
---|
| 772 | call-list |
---|
| 773 | `((,dims-var ,dims))))) |
---|
| 774 | `(let ,let-list |
---|
| 775 | (make-array-1 ,dims-var ,@call-list nil)))) |
---|
| 776 | |
---|
| 777 | (defun comp-nuke-keys (keys key-list call-list &optional required-bindings) |
---|
| 778 | ; side effects call list, returns a let-list |
---|
| 779 | (let ((let-list (reverse required-bindings))) |
---|
| 780 | (do ((lst keys (cddr lst))) |
---|
| 781 | ((null lst) nil) |
---|
| 782 | (let* ((key (car lst)) |
---|
| 783 | (val (cadr lst)) |
---|
| 784 | (ass (assq key key-list)) |
---|
| 785 | (vpos (cadr ass)) |
---|
| 786 | (ppos (caddr ass))) |
---|
| 787 | (when ass |
---|
| 788 | (when (not (constantp val)) |
---|
| 789 | (let ((gen (gensym))) |
---|
| 790 | (setq let-list (cons (list gen val) let-list)) ; reverse him |
---|
| 791 | (setq val gen))) |
---|
| 792 | (rplaca (nthcdr vpos call-list) val) |
---|
| 793 | (if ppos (rplaca (nthcdr ppos call-list) t))))) |
---|
| 794 | (nreverse let-list))) |
---|
| 795 | |
---|
| 796 | (define-compiler-macro make-instance (&whole call class &rest initargs) |
---|
| 797 | (if (and (listp class) |
---|
| 798 | (eq (car class) 'quote) |
---|
| 799 | (symbolp (cadr class)) |
---|
| 800 | (null (cddr class))) |
---|
[7750] | 801 | (let* ((cell (gensym))) |
---|
| 802 | `(let* ((,cell (load-time-value (find-class-cell ,class t)))) |
---|
| 803 | (funcall (class-cell-instantiate ,cell) ,cell ,@initargs))) |
---|
[6] | 804 | call)) |
---|
| 805 | |
---|
| 806 | |
---|
| 807 | |
---|
| 808 | |
---|
| 809 | |
---|
| 810 | |
---|
| 811 | |
---|
| 812 | (define-compiler-macro mapc (&whole call fn lst &rest more) |
---|
| 813 | (if more |
---|
| 814 | call |
---|
| 815 | (let* ((temp-var (gensym)) |
---|
| 816 | (elt-var (gensym)) |
---|
| 817 | (fn-var (gensym))) |
---|
| 818 | `(let* ((,fn-var ,fn) |
---|
| 819 | (,temp-var ,lst)) |
---|
| 820 | (dolist (,elt-var ,temp-var ,temp-var) |
---|
| 821 | (funcall ,fn-var ,elt-var)) |
---|
| 822 | )))) |
---|
| 823 | |
---|
| 824 | (define-compiler-macro mapcar (&whole call fn lst &rest more) |
---|
| 825 | (if more |
---|
| 826 | call |
---|
| 827 | (let* ((temp-var (gensym)) |
---|
| 828 | (result-var (gensym)) |
---|
| 829 | (elt-var (gensym)) |
---|
| 830 | (fn-var (gensym))) |
---|
| 831 | `(let* ((,temp-var (cons nil nil)) |
---|
| 832 | (,result-var ,temp-var) |
---|
| 833 | (,fn-var ,fn)) |
---|
| 834 | (declare (dynamic-extent ,temp-var) |
---|
| 835 | (type cons ,temp-var ,result-var)) |
---|
| 836 | (dolist (,elt-var ,lst (cdr ,result-var)) |
---|
| 837 | (setq ,temp-var (setf (cdr ,temp-var) (list (funcall ,fn-var ,elt-var))))))))) |
---|
| 838 | |
---|
[7624] | 839 | (define-compiler-macro member (&whole call item list &rest keys) |
---|
| 840 | (or (remove-explicit-test-keyword-from-test-testnot-key item list keys 'memeql '((eq . memq) (eql . memeql) (equal . memequal)) 'member-test) |
---|
[6] | 841 | call)) |
---|
| 842 | |
---|
[7624] | 843 | (define-compiler-macro memequal (&whole call &environment env item list) |
---|
| 844 | (if (or (equal-iff-eql-p item env) |
---|
| 845 | (and (quoted-form-p list) |
---|
| 846 | (proper-list-p (%cadr list)) |
---|
| 847 | (every (lambda (elt) (equal-iff-eql-p elt env)) (%cadr list)))) |
---|
| 848 | `(memeql ,item ,list) |
---|
| 849 | call)) |
---|
| 850 | |
---|
| 851 | (define-compiler-macro memeql (&whole call &environment env item list) |
---|
| 852 | (if (or (eql-iff-eq-p item env) |
---|
| 853 | (and (quoted-form-p list) |
---|
| 854 | (proper-list-p (%cadr list)) |
---|
| 855 | (every (lambda (elt) (eql-iff-eq-p elt env)) (%cadr list)))) |
---|
| 856 | `(memq ,item ,list) |
---|
| 857 | call)) |
---|
| 858 | |
---|
[6] | 859 | (define-compiler-macro memq (&whole call &environment env item list) |
---|
[7624] | 860 | ;;(memq x '(y)) => (if (eq x 'y) '(y)) |
---|
| 861 | ;;Would it be worth making a two elt list into an OR? Maybe if |
---|
| 862 | ;;optimizing for speed... |
---|
[6] | 863 | (if (and (or (quoted-form-p list) |
---|
| 864 | (null list)) |
---|
| 865 | (null (cdr (%cadr list)))) |
---|
| 866 | (if list `(if (eq ,item ',(%caadr list)) ,list)) |
---|
[7624] | 867 | (let* ((x (gensym)) |
---|
| 868 | (tail (gensym))) |
---|
| 869 | `(do* ((,x ,item) |
---|
| 870 | (,tail ,list (cdr (the list ,tail)))) |
---|
| 871 | ((null ,tail)) |
---|
| 872 | (if (eq (car ,tail) ,x) (return ,tail)))))) |
---|
[6] | 873 | |
---|
| 874 | (define-compiler-macro minusp (x) |
---|
| 875 | `(< ,x 0)) |
---|
| 876 | |
---|
| 877 | (define-compiler-macro notany (&whole call &environment env &rest ignore) |
---|
| 878 | (declare (ignore ignore)) |
---|
| 879 | (some-xx-transform call env)) |
---|
| 880 | |
---|
| 881 | (define-compiler-macro notevery (&whole call &environment env &rest ignore) |
---|
| 882 | (declare (ignore ignore)) |
---|
| 883 | (some-xx-transform call env)) |
---|
| 884 | |
---|
| 885 | (define-compiler-macro nth (&whole call &environment env count list) |
---|
| 886 | (if (and (fixnump count) |
---|
| 887 | (%i>= count 0) |
---|
| 888 | (%i< count 3)) |
---|
| 889 | `(,(svref '#(car cadr caddr) count) ,list) |
---|
[7624] | 890 | `(car (nthcdr ,count ,list)))) |
---|
[6] | 891 | |
---|
| 892 | (define-compiler-macro nthcdr (&whole call &environment env count list) |
---|
| 893 | (if (and (fixnump count) |
---|
| 894 | (%i>= count 0) |
---|
| 895 | (%i< count 4)) |
---|
| 896 | (if (%izerop count) |
---|
[7624] | 897 | `(require-type ,list 'list) |
---|
[6] | 898 | `(,(svref '#(cdr cddr cdddr) (%i- count 1)) ,list)) |
---|
[7624] | 899 | (let* ((i (gensym)) |
---|
| 900 | (n (gensym)) ; evaluation order |
---|
| 901 | (tail (gensym))) |
---|
| 902 | `(let* ((,n (require-type ,count 'unsigned-byte)) |
---|
| 903 | (,tail (require-type ,list 'list))) |
---|
| 904 | (dotimes (,i ,n ,tail) |
---|
| 905 | (unless (setq ,tail (cdr ,tail)) |
---|
| 906 | (return nil))))))) |
---|
[6] | 907 | |
---|
| 908 | (define-compiler-macro plusp (x) |
---|
| 909 | `(> ,x 0)) |
---|
| 910 | |
---|
| 911 | (define-compiler-macro progn (&whole call &optional (first nil first-p) &rest rest) |
---|
| 912 | (if first-p |
---|
| 913 | (if rest call first))) |
---|
| 914 | |
---|
[1989] | 915 | ;;; This isn't quite right... The idea is that (car (require-type foo |
---|
| 916 | ;;; 'list)) ;can become just (<typechecking-car> foo) [regardless of |
---|
| 917 | ;;; optimize settings], ;but I don't think this can be done just with |
---|
| 918 | ;;; optimizers... For now, at least try to get it to become (%car |
---|
| 919 | ;;; (<typecheck> foo)). |
---|
[6] | 920 | (define-compiler-macro require-type (&whole call &environment env arg type) |
---|
[8130] | 921 | (cond ((and (or (eq type t) |
---|
| 922 | (and (quoted-form-p type) |
---|
| 923 | (setq type (%cadr type)))) |
---|
[6] | 924 | (not (typep (specifier-type type) 'unknown-ctype))) |
---|
| 925 | (cond ((nx-form-typep arg type env) arg) |
---|
| 926 | ((eq type 'simple-vector) |
---|
| 927 | `(the simple-vector (require-simple-vector ,arg))) |
---|
| 928 | ((eq type 'simple-string) |
---|
| 929 | `(the simple-string (require-simple-string ,arg))) |
---|
| 930 | ((eq type 'integer) |
---|
| 931 | `(the integer (require-integer ,arg))) |
---|
| 932 | ((eq type 'fixnum) |
---|
| 933 | `(the fixnum (require-fixnum ,arg))) |
---|
| 934 | ((eq type 'real) |
---|
| 935 | `(the real (require-real ,arg))) |
---|
| 936 | ((eq type 'list) |
---|
| 937 | `(the list (require-list ,arg))) |
---|
| 938 | ((eq type 'character) |
---|
| 939 | `(the character (require-character ,arg))) |
---|
| 940 | ((eq type 'number) |
---|
| 941 | `(the number (require-number ,arg))) |
---|
| 942 | ((eq type 'symbol) |
---|
| 943 | `(the symbol (require-symbol ,arg))) |
---|
[5217] | 944 | ((type= (specifier-type type) |
---|
| 945 | (specifier-type '(signed-byte 8))) |
---|
| 946 | `(the (signed-byte 8) (require-s8 ,arg))) |
---|
| 947 | ((type= (specifier-type type) |
---|
| 948 | (specifier-type '(unsigned-byte 8))) |
---|
| 949 | `(the (unsigned-byte 8) (require-u8 ,arg))) |
---|
| 950 | ((type= (specifier-type type) |
---|
| 951 | (specifier-type '(signed-byte 16))) |
---|
| 952 | `(the (signed-byte 16) (require-s16 ,arg))) |
---|
| 953 | ((type= (specifier-type type) |
---|
| 954 | (specifier-type '(unsigned-byte 16))) |
---|
| 955 | `(the (unsigned-byte 16) (require-u16 ,arg))) |
---|
| 956 | ((type= (specifier-type type) |
---|
| 957 | (specifier-type '(signed-byte 32))) |
---|
| 958 | `(the (signed-byte 32) (require-s32 ,arg))) |
---|
| 959 | ((type= (specifier-type type) |
---|
| 960 | (specifier-type '(unsigned-byte 32))) |
---|
| 961 | `(the (unsigned-byte 32) (require-u32 ,arg))) |
---|
| 962 | ((type= (specifier-type type) |
---|
| 963 | (specifier-type '(signed-byte 64))) |
---|
| 964 | `(the (signed-byte 64) (require-s64 ,arg))) |
---|
| 965 | ((type= (specifier-type type) |
---|
| 966 | (specifier-type '(unsigned-byte 64))) |
---|
[8130] | 967 | `(the (unsigned-byte 64) (require-u64 ,arg))) |
---|
| 968 | #+nil |
---|
[6] | 969 | ((and (symbolp type) |
---|
| 970 | (let ((simpler (type-predicate type))) |
---|
| 971 | (if simpler `(the ,type (%require-type ,arg ',simpler)))))) |
---|
[8130] | 972 | #+nil |
---|
[6] | 973 | ((and (symbolp type)(find-class type nil env)) |
---|
| 974 | `(%require-type-class-cell ,arg (load-time-value (find-class-cell ',type t)))) |
---|
[7940] | 975 | (t (let* ((val (gensym))) |
---|
| 976 | `(let* ((,val ,arg)) |
---|
| 977 | (if (typep ,val ',type) |
---|
| 978 | ,val |
---|
| 979 | (%kernel-restart $xwrongtype ,val ',type))))))) |
---|
[6] | 980 | (t call))) |
---|
| 981 | |
---|
| 982 | (define-compiler-macro proclaim (&whole call decl) |
---|
| 983 | (if (and (quoted-form-p decl) |
---|
| 984 | (eq (car (setq decl (%cadr decl))) 'special)) |
---|
| 985 | (do ((vars (%cdr decl) (%cdr vars)) (decls ())) |
---|
| 986 | ((null vars) |
---|
| 987 | (cons 'progn (nreverse decls))) |
---|
| 988 | (unless (and (car vars) |
---|
| 989 | (neq (%car vars) t) |
---|
| 990 | (symbolp (%car vars))) |
---|
| 991 | (return call)) |
---|
| 992 | (push (list '%proclaim-special (list 'quote (%car vars))) decls)) |
---|
| 993 | call)) |
---|
| 994 | |
---|
| 995 | |
---|
| 996 | (define-compiler-macro some (&whole call &environment env &rest ignore) |
---|
| 997 | (declare (ignore ignore)) |
---|
| 998 | (some-xx-transform call env)) |
---|
| 999 | |
---|
| 1000 | (define-compiler-macro struct-ref (&whole call &environment env struct offset) |
---|
| 1001 | (if (nx-inhibit-safety-checking env) |
---|
| 1002 | `(%svref ,struct ,offset) |
---|
| 1003 | call)) |
---|
| 1004 | |
---|
| 1005 | ;;; expand find-if and find-if-not |
---|
| 1006 | |
---|
| 1007 | (define-compiler-macro find-if (&whole call &environment env |
---|
| 1008 | test sequence &rest keys) |
---|
| 1009 | `(find ,test ,sequence |
---|
| 1010 | :test #'funcall |
---|
| 1011 | ,@keys)) |
---|
| 1012 | |
---|
| 1013 | (define-compiler-macro find-if-not (&whole call &environment env |
---|
| 1014 | test sequence &rest keys) |
---|
| 1015 | `(find ,test ,sequence |
---|
| 1016 | :test-not #'funcall |
---|
| 1017 | ,@keys)) |
---|
| 1018 | |
---|
| 1019 | ;;; inline some cases, and use a positional function in others |
---|
| 1020 | |
---|
| 1021 | (define-compiler-macro find (&whole call &environment env |
---|
| 1022 | item sequence &rest keys) |
---|
| 1023 | (if (constant-keywords-p keys) |
---|
| 1024 | (destructuring-bind (&key from-end test test-not (start 0) end key) keys |
---|
| 1025 | (if (and (eql start 0) |
---|
| 1026 | (null end) |
---|
| 1027 | (null from-end) |
---|
| 1028 | (not (and test test-not))) |
---|
| 1029 | (let ((find-test (or test test-not '#'eql)) |
---|
| 1030 | (loop-test (if test-not 'unless 'when)) |
---|
| 1031 | (loop-function (nx-form-sequence-iterator sequence env))) |
---|
| 1032 | (if loop-function |
---|
| 1033 | (let ((item-var (unless (or (constantp item) |
---|
| 1034 | (and (equal find-test '#'funcall) |
---|
| 1035 | (function-form-p item))) |
---|
| 1036 | (gensym))) |
---|
| 1037 | (elt-var (gensym))) |
---|
| 1038 | `(let (,@(when item-var `((,item-var ,item)))) |
---|
| 1039 | (,loop-function (,elt-var ,sequence) |
---|
| 1040 | (,loop-test (funcall ,find-test ,(or item-var item) |
---|
| 1041 | (funcall ,(or key '#'identity) ,elt-var)) |
---|
| 1042 | (return ,elt-var))))) |
---|
| 1043 | (let ((find-function (if test-not 'find-positional-test-not-key 'find-positional-test-key)) |
---|
| 1044 | (item-var (gensym)) |
---|
| 1045 | (sequence-var (gensym)) |
---|
| 1046 | (test-var (gensym)) |
---|
| 1047 | (key-var (gensym))) |
---|
| 1048 | `(let ((,item-var ,item) |
---|
| 1049 | (,sequence-var ,sequence) |
---|
| 1050 | (,test-var ,(or test test-not)) |
---|
| 1051 | (,key-var ,key)) |
---|
| 1052 | (declare (dynamic-extent ,item-var ,sequence-var ,test-var ,key-var)) |
---|
| 1053 | (,find-function ,item-var ,sequence-var ,test-var ,key-var))))) |
---|
| 1054 | call)) |
---|
| 1055 | call)) |
---|
| 1056 | |
---|
| 1057 | ;;; expand position-if and position-if-not |
---|
| 1058 | |
---|
| 1059 | (define-compiler-macro position-if (&whole call &environment env |
---|
| 1060 | test sequence &rest keys) |
---|
| 1061 | `(position ,test ,sequence |
---|
| 1062 | :test #'funcall |
---|
| 1063 | ,@keys)) |
---|
| 1064 | |
---|
| 1065 | (define-compiler-macro position-if-not (&whole call &environment env |
---|
| 1066 | test sequence &rest keys) |
---|
| 1067 | `(position ,test ,sequence |
---|
| 1068 | :test-not #'funcall |
---|
| 1069 | ,@keys)) |
---|
| 1070 | |
---|
| 1071 | ;;; inline some cases, and use positional functions for others |
---|
| 1072 | |
---|
| 1073 | (define-compiler-macro position (&whole call &environment env |
---|
| 1074 | item sequence &rest keys) |
---|
| 1075 | (if (constant-keywords-p keys) |
---|
| 1076 | (destructuring-bind (&key from-end test test-not (start 0) end key) keys |
---|
| 1077 | (if (and (eql start 0) |
---|
| 1078 | (null end) |
---|
| 1079 | (null from-end) |
---|
| 1080 | (not (and test test-not))) |
---|
| 1081 | (let ((position-test (or test test-not '#'eql)) |
---|
| 1082 | (loop-test (if test-not 'unless 'when)) |
---|
| 1083 | (sequence-value (if (constantp sequence) |
---|
| 1084 | (eval-constant sequence) |
---|
| 1085 | sequence))) |
---|
| 1086 | (cond ((nx-form-typep sequence-value 'list env) |
---|
| 1087 | (let ((item-var (unless (or (constantp item) |
---|
| 1088 | (and (equal position-test '#'funcall) |
---|
| 1089 | (function-form-p item))) |
---|
| 1090 | (gensym))) |
---|
| 1091 | (elt-var (gensym)) |
---|
| 1092 | (position-var (gensym))) |
---|
| 1093 | `(let (,@(when item-var `((,item-var ,item))) |
---|
| 1094 | (,position-var 0)) |
---|
| 1095 | (dolist (,elt-var ,sequence) |
---|
| 1096 | (,loop-test (funcall ,position-test ,(or item-var item) |
---|
| 1097 | (funcall ,(or key '#'identity) ,elt-var)) |
---|
| 1098 | (return ,position-var)) |
---|
| 1099 | (incf ,position-var))))) |
---|
| 1100 | ((nx-form-typep sequence-value 'vector env) |
---|
| 1101 | (let ((item-var (unless (or (constantp item) |
---|
| 1102 | (and (equal position-test '#'funcall) |
---|
| 1103 | (function-form-p item))) |
---|
| 1104 | (gensym))) |
---|
| 1105 | (sequence-var (gensym)) |
---|
| 1106 | (position-var (gensym))) |
---|
| 1107 | `(let (,@(when item-var `((,item-var ,item))) |
---|
| 1108 | (,sequence-var ,sequence)) |
---|
| 1109 | ,@(let ((type (nx-form-type sequence env))) |
---|
| 1110 | (unless (eq type t) |
---|
| 1111 | `((declare (type ,type ,sequence-var))))) |
---|
| 1112 | (dotimes (,position-var (length ,sequence-var)) |
---|
| 1113 | (,loop-test (funcall ,position-test ,(or item-var item) |
---|
| 1114 | (funcall ,(or key '#'identity) |
---|
| 1115 | (locally (declare (optimize (speed 3) (safety 0))) |
---|
| 1116 | (aref ,sequence ,position-var)))) |
---|
| 1117 | (return ,position-var)))))) |
---|
| 1118 | (t |
---|
| 1119 | (let ((position-function (if test-not |
---|
| 1120 | 'position-positional-test-not-key |
---|
| 1121 | 'position-positional-test-key)) |
---|
| 1122 | (item-var (gensym)) |
---|
| 1123 | (sequence-var (gensym)) |
---|
| 1124 | (test-var (gensym)) |
---|
| 1125 | (key-var (gensym))) |
---|
| 1126 | `(let ((,item-var ,item) |
---|
| 1127 | (,sequence-var ,sequence) |
---|
| 1128 | (,test-var ,(or test test-not)) |
---|
| 1129 | (,key-var ,key)) |
---|
| 1130 | (declare (dynamic-extent ,sequence-var ,test-var ,key-var)) |
---|
| 1131 | (,position-function ,item-var ,sequence-var ,test-var ,key-var)))))) |
---|
| 1132 | call)) |
---|
| 1133 | call)) |
---|
| 1134 | |
---|
| 1135 | ;;; inline some cases of remove-if and remove-if-not |
---|
| 1136 | |
---|
| 1137 | (define-compiler-macro remove-if (&whole call &environment env &rest ignore) |
---|
| 1138 | (declare (ignore ignore)) |
---|
| 1139 | (remove-if-transform call env)) |
---|
| 1140 | |
---|
| 1141 | (define-compiler-macro remove-if-not (&whole call &environment env &rest ignore) |
---|
| 1142 | (declare (ignore ignore)) |
---|
| 1143 | (remove-if-transform call env)) |
---|
| 1144 | |
---|
| 1145 | (defun remove-if-transform (call env) |
---|
| 1146 | (destructuring-bind (function test sequence &rest keys) call |
---|
| 1147 | (if (constant-keywords-p keys) |
---|
| 1148 | (destructuring-bind (&key from-end (start 0) end count (key '#'identity)) keys |
---|
| 1149 | (if (and (eql start 0) |
---|
| 1150 | (null end) |
---|
| 1151 | (null from-end) |
---|
| 1152 | (null count) |
---|
| 1153 | (nx-form-typep sequence 'list env)) |
---|
| 1154 | ;; only do the list case, since it's hard to collect vector results |
---|
| 1155 | (let ((temp-var (gensym)) |
---|
| 1156 | (result-var (gensym)) |
---|
| 1157 | (elt-var (gensym)) |
---|
| 1158 | (loop-test (ecase function (remove-if 'unless) (remove-if-not 'when)))) |
---|
| 1159 | `(the list |
---|
| 1160 | (let* ((,temp-var (cons nil nil)) |
---|
| 1161 | (,result-var ,temp-var)) |
---|
| 1162 | (declare (dynamic-extent ,temp-var)) |
---|
| 1163 | (dolist (,elt-var ,sequence (%cdr ,result-var)) |
---|
| 1164 | (,loop-test (funcall ,test (funcall ,key ,elt-var)) |
---|
| 1165 | (setq ,temp-var |
---|
| 1166 | (%cdr |
---|
| 1167 | (%rplacd ,temp-var (list ,elt-var))))))))) |
---|
| 1168 | call)) |
---|
| 1169 | call))) |
---|
| 1170 | |
---|
| 1171 | |
---|
| 1172 | |
---|
| 1173 | (define-compiler-macro struct-set (&whole call &environment env struct offset new) |
---|
| 1174 | (if (nx-inhibit-safety-checking env) |
---|
| 1175 | `(%svset ,struct ,offset ,new) |
---|
| 1176 | call)) |
---|
| 1177 | |
---|
| 1178 | (define-compiler-macro zerop (arg &environment env) |
---|
| 1179 | (let* ((z (if (nx-form-typep arg 'float env) |
---|
| 1180 | (coerce 0 (nx-form-type arg env)) |
---|
| 1181 | 0))) |
---|
| 1182 | `(= ,arg ,z))) |
---|
| 1183 | |
---|
| 1184 | |
---|
| 1185 | (define-compiler-macro = (&whole w n0 &optional (n1 nil n1p) &rest more) |
---|
| 1186 | (if (not n1p) |
---|
| 1187 | `(require-type ,n0 'number) |
---|
| 1188 | (if more |
---|
| 1189 | w |
---|
| 1190 | `(=-2 ,n0 ,n1)))) |
---|
| 1191 | |
---|
| 1192 | (define-compiler-macro /= (&whole w n0 &optional (n1 nil n1p) &rest more) |
---|
| 1193 | (if (not n1p) |
---|
| 1194 | `(require-type ,n0 'number) |
---|
| 1195 | (if more |
---|
| 1196 | w |
---|
| 1197 | `(/=-2 ,n0 ,n1)))) |
---|
| 1198 | |
---|
| 1199 | (define-compiler-macro + (&whole w &environment env &optional (n0 nil n0p) (n1 nil n1p) &rest more) |
---|
| 1200 | (if more |
---|
[1733] | 1201 | `(+ (+-2 ,n0 ,n1) ,@more) |
---|
[6] | 1202 | (if n1p |
---|
| 1203 | `(+-2 ,n0 ,n1) |
---|
| 1204 | (if n0p |
---|
| 1205 | `(require-type ,n0 'number) |
---|
| 1206 | 0)))) |
---|
| 1207 | |
---|
| 1208 | (define-compiler-macro - (&whole w &environment env n0 &optional (n1 nil n1p) &rest more) |
---|
| 1209 | (if more |
---|
[1733] | 1210 | `(- (--2 ,n0 ,n1) ,@more) |
---|
[6] | 1211 | (if n1p |
---|
| 1212 | `(--2 ,n0 ,n1) |
---|
| 1213 | `(%negate ,n0)))) |
---|
| 1214 | |
---|
| 1215 | (define-compiler-macro * (&whole w &environment env &optional (n0 nil n0p) (n1 nil n1p) &rest more) |
---|
| 1216 | (if more |
---|
| 1217 | (let ((type (nx-form-type w env))) |
---|
| 1218 | (if (and type (numeric-type-p type)) ; go pairwise if type known, else not |
---|
| 1219 | `(*-2 ,n0 (* ,n1 ,@more)) |
---|
| 1220 | w)) |
---|
| 1221 | (if n1p |
---|
| 1222 | `(*-2 ,n0 ,n1) |
---|
| 1223 | (if n0p |
---|
| 1224 | `(require-type ,n0 'number) |
---|
| 1225 | 1)))) |
---|
| 1226 | |
---|
| 1227 | (define-compiler-macro / (&whole w n0 &optional (n1 nil n1p) &rest more) |
---|
| 1228 | (if more |
---|
| 1229 | w |
---|
| 1230 | (if n1p |
---|
| 1231 | `(/-2 ,n0 ,n1) |
---|
| 1232 | `(%quo-1 ,n0)))) |
---|
| 1233 | |
---|
[1989] | 1234 | ;;; beware of limits - truncate of most-negative-fixnum & -1 ain't a |
---|
| 1235 | ;;; fixnum - too bad |
---|
[6] | 1236 | (define-compiler-macro truncate (&whole w &environment env n0 &optional (n1 nil n1p)) |
---|
| 1237 | (let ((*nx-form-type* t)) |
---|
| 1238 | (if (nx-form-typep n0 'fixnum env) |
---|
| 1239 | (if (not n1p) |
---|
| 1240 | n0 |
---|
| 1241 | (if (nx-form-typep n1 'fixnum env) |
---|
| 1242 | `(%fixnum-truncate ,n0 ,n1) |
---|
| 1243 | w)) |
---|
| 1244 | w))) |
---|
| 1245 | |
---|
| 1246 | (define-compiler-macro floor (&whole w &environment env n0 &optional (n1 nil n1p)) |
---|
| 1247 | (let ((*nx-form-type* t)) |
---|
| 1248 | (if (nx-form-typep n0 'fixnum env) |
---|
| 1249 | (if (not n1p) |
---|
| 1250 | n0 |
---|
| 1251 | (if (nx-form-typep n1 'fixnum env) |
---|
| 1252 | `(%fixnum-floor ,n0 ,n1) |
---|
| 1253 | w)) |
---|
| 1254 | w))) |
---|
| 1255 | |
---|
| 1256 | (define-compiler-macro round (&whole w &environment env n0 &optional (n1 nil n1p)) |
---|
| 1257 | (let ((*nx-form-type* t)) ; it doesn't matter what the result type is declared to be |
---|
| 1258 | (if (nx-form-typep n0 'fixnum env) |
---|
| 1259 | (if (not n1p) |
---|
| 1260 | n0 |
---|
| 1261 | (if (nx-form-typep n1 'fixnum env) |
---|
| 1262 | `(%fixnum-round ,n0 ,n1) |
---|
| 1263 | w)) |
---|
| 1264 | w))) |
---|
| 1265 | |
---|
| 1266 | (define-compiler-macro ceiling (&whole w &environment env n0 &optional (n1 nil n1p)) |
---|
| 1267 | (let ((*nx-form-type* t)) |
---|
| 1268 | (if (nx-form-typep n0 'fixnum env) |
---|
| 1269 | (if (not n1p) |
---|
| 1270 | n0 |
---|
| 1271 | (if (nx-form-typep n1 'fixnum env) |
---|
| 1272 | `(%fixnum-ceiling ,n0 ,n1) |
---|
| 1273 | w)) |
---|
| 1274 | w))) |
---|
| 1275 | |
---|
| 1276 | (define-compiler-macro oddp (&whole w &environment env n0) |
---|
| 1277 | (if (nx-form-typep n0 'fixnum env) |
---|
| 1278 | `(logbitp 0 (the fixnum ,n0)) |
---|
| 1279 | w)) |
---|
| 1280 | |
---|
| 1281 | (define-compiler-macro evenp (&whole w &environment env n0) |
---|
| 1282 | (if (nx-form-typep n0 'fixnum env) |
---|
| 1283 | `(not (logbitp 0 (the fixnum ,n0))) |
---|
| 1284 | w)) |
---|
| 1285 | |
---|
| 1286 | |
---|
| 1287 | (define-compiler-macro logandc2 (n0 n1) |
---|
| 1288 | (let ((n1var (gensym)) |
---|
| 1289 | (n0var (gensym))) |
---|
| 1290 | `(let ((,n0var ,n0) |
---|
| 1291 | (,n1var ,n1)) |
---|
| 1292 | (logandc1 ,n1var ,n0var)))) |
---|
| 1293 | |
---|
| 1294 | (define-compiler-macro logorc2 (n0 n1) |
---|
| 1295 | (let ((n1var (gensym)) |
---|
| 1296 | (n0var (gensym))) |
---|
| 1297 | `(let ((,n0var ,n0) |
---|
| 1298 | (,n1var ,n1)) |
---|
| 1299 | (logorc1 ,n1var ,n0var)))) |
---|
| 1300 | |
---|
| 1301 | (define-compiler-macro lognand (n0 n1) |
---|
| 1302 | `(lognot (logand ,n0 ,n1))) |
---|
| 1303 | |
---|
| 1304 | (define-compiler-macro lognor (n0 n1) |
---|
| 1305 | `(lognot (logior ,n0 ,n1))) |
---|
| 1306 | |
---|
| 1307 | |
---|
[1907] | 1308 | (defun transform-logop (whole identity binop &optional (transform-complement t)) |
---|
[6] | 1309 | (destructuring-bind (op &optional (n0 nil n0p) (n1 nil n1p) &rest more) whole |
---|
| 1310 | (if (and n1p (eql n0 identity)) |
---|
| 1311 | `(,op ,n1 ,@more) |
---|
[1907] | 1312 | (if (and transform-complement n1p (eql n0 (lognot identity))) |
---|
[6] | 1313 | `(progn |
---|
| 1314 | (,op ,n1 ,@more) |
---|
| 1315 | ,(lognot identity)) |
---|
| 1316 | (if more |
---|
| 1317 | (if (cdr more) |
---|
| 1318 | whole |
---|
| 1319 | `(,binop ,n0 (,binop ,n1 ,(car more)))) |
---|
| 1320 | (if n1p |
---|
| 1321 | `(,binop ,n0 ,n1) |
---|
| 1322 | (if n0p |
---|
| 1323 | `(require-type ,n0 'integer) |
---|
| 1324 | identity))))))) |
---|
| 1325 | |
---|
| 1326 | (define-compiler-macro logand (&whole w &rest all) |
---|
| 1327 | (declare (ignore all)) |
---|
| 1328 | (transform-logop w -1 'logand-2)) |
---|
| 1329 | |
---|
| 1330 | (define-compiler-macro logior (&whole w &rest all) |
---|
| 1331 | (declare (ignore all)) |
---|
| 1332 | (transform-logop w 0 'logior-2)) |
---|
| 1333 | |
---|
| 1334 | (define-compiler-macro logxor (&whole w &rest all) |
---|
| 1335 | (declare (ignore all)) |
---|
[1907] | 1336 | (transform-logop w 0 'logxor-2 nil)) |
---|
[6] | 1337 | |
---|
| 1338 | (define-compiler-macro lognot (&whole w &environment env n1) |
---|
| 1339 | (if (nx-form-typep n1 'fixnum env) |
---|
| 1340 | `(%ilognot ,n1) |
---|
| 1341 | w)) |
---|
| 1342 | |
---|
| 1343 | (define-compiler-macro logtest (&whole w &environment env n1 n2) |
---|
| 1344 | (if (and (nx-form-typep n1 'fixnum env) |
---|
| 1345 | (nx-form-typep n2 'fixnum env)) |
---|
| 1346 | `(not (eql 0 (logand ,n1 ,n2))) |
---|
| 1347 | w)) |
---|
| 1348 | |
---|
| 1349 | |
---|
| 1350 | (defmacro defsynonym (from to) |
---|
| 1351 | ;Should maybe check for circularities. |
---|
| 1352 | `(progn |
---|
| 1353 | (setf (compiler-macro-function ',from) nil) |
---|
| 1354 | (let ((pair (assq ',from *nx-synonyms*))) |
---|
| 1355 | (if pair (rplacd pair ',to) |
---|
| 1356 | (push (cons ',from ',to) |
---|
| 1357 | *nx-synonyms*)) |
---|
| 1358 | ',to))) |
---|
| 1359 | |
---|
| 1360 | (defsynonym first car) |
---|
| 1361 | (defsynonym second cadr) |
---|
| 1362 | (defsynonym third caddr) |
---|
| 1363 | (defsynonym fourth cadddr) |
---|
| 1364 | (defsynonym rest cdr) |
---|
| 1365 | |
---|
| 1366 | |
---|
| 1367 | (defsynonym functionp lfunp) |
---|
| 1368 | (defsynonym null not) |
---|
| 1369 | (defsynonym char-int char-code) |
---|
| 1370 | |
---|
| 1371 | ;;; Improvemets file by Bob Cassels |
---|
| 1372 | ;;; Just what are "Improvemets", anyway ? |
---|
| 1373 | |
---|
[1989] | 1374 | ;;; Optimize some CL sequence functions, mostly by inlining them in |
---|
| 1375 | ;;; simple cases when the type of the sequence is known. In some |
---|
| 1376 | ;;; cases, dynamic-extent declarations are automatically inserted. |
---|
| 1377 | ;;; For some sequence functions, if the type of the sequence is known |
---|
| 1378 | ;;; at compile time, the function is inlined. If the type isn't known |
---|
| 1379 | ;;; but the call is "simple", a call to a faster (positional-arg) |
---|
[6] | 1380 | ;;; function is substituted. |
---|
| 1381 | |
---|
| 1382 | |
---|
| 1383 | (defun nx-form-sequence-iterator (sequence-form env) |
---|
| 1384 | (cond ((nx-form-typep sequence-form 'vector env) 'dovector) |
---|
| 1385 | ((nx-form-typep sequence-form 'list env) 'dolist))) |
---|
| 1386 | |
---|
| 1387 | (defun function-form-p (form) |
---|
| 1388 | ;; c.f. quoted-form-p |
---|
| 1389 | (and (consp form) |
---|
| 1390 | (eq (%car form) 'function) |
---|
| 1391 | (consp (%cdr form)) |
---|
| 1392 | (null (%cdr (%cdr form))))) |
---|
| 1393 | |
---|
[7940] | 1394 | |
---|
| 1395 | ;; Return a form that checks to see if THING is if type CTYPE, or |
---|
| 1396 | ;; NIL if we can't do that for some reason. |
---|
| 1397 | (defun optimize-ctypep (thing ctype) |
---|
| 1398 | (when (eq *target-backend* *host-backend*) |
---|
| 1399 | (typecase ctype |
---|
| 1400 | (numeric-ctype |
---|
| 1401 | (cond ((eq :real (numeric-ctype-complexp ctype)) |
---|
| 1402 | (let* ((low (numeric-ctype-low ctype)) |
---|
| 1403 | (high (numeric-ctype-high ctype)) |
---|
| 1404 | (class (numeric-ctype-class ctype)) |
---|
| 1405 | (format (numeric-ctype-format ctype)) |
---|
| 1406 | (type (if (eq class 'float) |
---|
| 1407 | (or format class) |
---|
[8986] | 1408 | (or class 'real)))) |
---|
[7940] | 1409 | (cond ((and low (eql low high) (or (not (eq class 'float)) |
---|
| 1410 | format)) |
---|
| 1411 | `(eql ,thing ,low)) |
---|
| 1412 | ((and (eq type 'float) |
---|
| 1413 | (or low high) |
---|
| 1414 | (or (null low) |
---|
| 1415 | (typep low 'single-float) |
---|
| 1416 | (not (null (ignore-errors |
---|
| 1417 | (coerce (if (atom low) |
---|
| 1418 | low |
---|
| 1419 | (car low)) |
---|
| 1420 | 'single-float))))) |
---|
| 1421 | (or (null high) |
---|
| 1422 | (typep high 'single-float) |
---|
| 1423 | (not (null (ignore-errors |
---|
| 1424 | (coerce (if (atom high) |
---|
| 1425 | high |
---|
| 1426 | (car high)) |
---|
| 1427 | 'single-float)))))) |
---|
| 1428 | (let* ((temp (gensym))) |
---|
| 1429 | (flet ((bounded-float (type low high) |
---|
| 1430 | `(,type |
---|
| 1431 | ,(if low |
---|
| 1432 | (if (listp low) |
---|
| 1433 | (list (coerce (car low) type)) |
---|
| 1434 | (coerce low type)) |
---|
| 1435 | '*) |
---|
| 1436 | ,(if high |
---|
| 1437 | (if (listp high) |
---|
| 1438 | (list (coerce (car high) type)) |
---|
| 1439 | (coerce high type)) |
---|
| 1440 | '*)))) |
---|
| 1441 | `(let* ((,temp ,thing)) |
---|
| 1442 | (or (typep ,temp ',(bounded-float 'single-float low high)) |
---|
| 1443 | (typep ,temp ',(bounded-float 'double-float low high))))))) |
---|
| 1444 | (t |
---|
| 1445 | (let* ((temp (gensym))) |
---|
[8986] | 1446 | (if (and (typep low 'fixnum) (typep high 'fixnum) |
---|
| 1447 | (eq class 'integer)) |
---|
[7940] | 1448 | (setq type 'fixnum)) |
---|
| 1449 | (if (or low high) |
---|
| 1450 | `(let* ((,temp ,thing)) |
---|
| 1451 | (and (typep ,temp ',type) |
---|
| 1452 | ,@(if low `((,(if (consp low) '> '>=) (the ,type ,temp) ,(if (consp low) (car low) low)))) |
---|
| 1453 | ,@(if high `((,(if (consp high) '< '<=) (the ,type ,temp) ,(if (consp high) (car high) high)))))) |
---|
| 1454 | `(typep ,thing ',type))))))) |
---|
| 1455 | (t `(numeric-%%typep ,thing ,ctype)))) |
---|
| 1456 | (array-ctype |
---|
| 1457 | (or |
---|
| 1458 | (let* ((typecode (array-ctype-typecode ctype)) |
---|
| 1459 | (dims (array-ctype-dimensions ctype))) |
---|
| 1460 | (cond ((and typecode (consp dims) (null (cdr dims))) |
---|
| 1461 | (case (array-ctype-complexp ctype) |
---|
| 1462 | ((nil) |
---|
| 1463 | (if (eq (car dims) '*) |
---|
| 1464 | `(eql (typecode ,thing) ,typecode) |
---|
| 1465 | (let* ((temp (gensym))) |
---|
| 1466 | `(let* ((,temp ,thing)) |
---|
| 1467 | (and (eql (typecode ,temp) ,typecode) |
---|
| 1468 | (eq (uvsize ,temp) ,(car dims))))))) |
---|
| 1469 | ((* :maybe) |
---|
| 1470 | (let* ((temp (gensym)) |
---|
| 1471 | (tempcode (gensym))) |
---|
| 1472 | `(let* ((,temp ,thing) |
---|
| 1473 | (,tempcode (typecode ,temp))) |
---|
| 1474 | (or (and (eql ,tempcode ,typecode) |
---|
| 1475 | ,@(unless (eq (car dims) '*) |
---|
[7961] | 1476 | `((eq (uvsize ,temp) ,(car dims))))) |
---|
[7940] | 1477 | (and (eql ,tempcode target::subtag-vectorH) |
---|
| 1478 | (eql (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref ,temp target::arrayH.flags-cell))) ,typecode) |
---|
| 1479 | ,@(unless (eq (car dims) '*) |
---|
| 1480 | `((eq (%svref ,temp target::vectorH.logsize-cell) ,(car dims))))))))))))) |
---|
| 1481 | `(array-%%typep ,thing ,ctype)))))) |
---|
| 1482 | |
---|
| 1483 | |
---|
| 1484 | |
---|
[6] | 1485 | (defun optimize-typep (thing type env) |
---|
| 1486 | ;; returns a new form, or nil if it can't optimize |
---|
[7940] | 1487 | (let* ((ctype (ignore-errors (specifier-type type)))) |
---|
| 1488 | (when (and ctype (not (typep ctype 'unknown-ctype))) |
---|
| 1489 | (let* ((type (type-specifier ctype)) |
---|
| 1490 | (predicate (if (typep type 'symbol) (type-predicate type)))) |
---|
| 1491 | (if (and predicate (symbolp predicate)) |
---|
| 1492 | `(,predicate ,thing) |
---|
| 1493 | (or (optimize-ctypep thing ctype) |
---|
| 1494 | (cond ((symbolp type) |
---|
| 1495 | (cond ((%deftype-expander type) |
---|
| 1496 | ;; recurse here, rather than returning the |
---|
| 1497 | ;; partially-expanded form mostly since it doesn't |
---|
| 1498 | ;; seem to further optimize the result otherwise |
---|
| 1499 | (let ((expanded-type (type-expand type))) |
---|
| 1500 | (or (optimize-typep thing expanded-type env) |
---|
| 1501 | ;; at least do the first expansion |
---|
| 1502 | `(typep ,thing ',expanded-type)))) |
---|
| 1503 | ((structure-class-p type env) |
---|
| 1504 | `(structure-typep ,thing ',type)) |
---|
| 1505 | ((find-class type nil env) |
---|
| 1506 | `(class-cell-typep ,thing (load-time-value (find-class-cell ',type t)))) |
---|
| 1507 | ((info-type-builtin type) ; bootstrap troubles here? |
---|
| 1508 | `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type)))) |
---|
| 1509 | (t nil))) |
---|
| 1510 | ((consp type) |
---|
| 1511 | (cond |
---|
| 1512 | ((info-type-builtin type) ; byte types |
---|
| 1513 | `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type)))) |
---|
| 1514 | (t |
---|
| 1515 | (case (%car type) |
---|
| 1516 | (satisfies `(funcall ',(cadr type) ,thing)) |
---|
| 1517 | (eql `(eql ,thing ',(cadr type))) |
---|
| 1518 | (member `(not (null (member ,thing ',(%cdr type))))) |
---|
| 1519 | (not `(not (typep ,thing ',(cadr type)))) |
---|
| 1520 | ((or and) |
---|
| 1521 | (let ((thing-sym (gensym))) |
---|
| 1522 | `(let ((,thing-sym ,thing)) |
---|
| 1523 | (,(%car type) |
---|
| 1524 | ,@(mapcar #'(lambda (type-spec) |
---|
| 1525 | (or (optimize-typep thing-sym type-spec env) |
---|
| 1526 | `(typep ,thing-sym ',type-spec))) |
---|
| 1527 | (%cdr type)))))) |
---|
| 1528 | ((signed-byte unsigned-byte integer mod) ; more byte types |
---|
| 1529 | `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type)))) |
---|
| 1530 | (t nil))))) |
---|
| 1531 | (t nil)))))))) |
---|
[6] | 1532 | |
---|
| 1533 | (define-compiler-macro typep (&whole call &environment env thing type &optional e) |
---|
| 1534 | (declare (ignore e)) |
---|
| 1535 | (if (quoted-form-p type) |
---|
[8130] | 1536 | (if (constantp thing) |
---|
| 1537 | (typep (if (quoted-form-p thing) (%cadr thing) thing) (%cadr type)) |
---|
| 1538 | (or (optimize-typep thing (%cadr type) env) |
---|
| 1539 | call)) |
---|
[7940] | 1540 | (if (eq type t) |
---|
| 1541 | `(progn ,thing t) |
---|
| 1542 | call))) |
---|
[6] | 1543 | |
---|
[2052] | 1544 | (define-compiler-macro true (&rest args) |
---|
| 1545 | `(progn |
---|
| 1546 | ,@args |
---|
| 1547 | t)) |
---|
[6] | 1548 | |
---|
| 1549 | |
---|
[2052] | 1550 | (define-compiler-macro false (&rest args) |
---|
| 1551 | `(progn |
---|
| 1552 | ,@args |
---|
| 1553 | nil)) |
---|
| 1554 | |
---|
[6] | 1555 | (define-compiler-macro find-class (&whole call type &optional (errorp t) env) |
---|
| 1556 | (if (and (quoted-form-p type)(not *dont-find-class-optimize*)(not env)) |
---|
| 1557 | `(class-cell-find-class (load-time-value (find-class-cell ,type t)) ,errorp) |
---|
| 1558 | call)) |
---|
| 1559 | |
---|
| 1560 | |
---|
| 1561 | (define-compiler-macro gcd (&whole call &optional (n0 nil n0-p) (n1 nil n1-p) &rest rest) |
---|
| 1562 | (if rest |
---|
| 1563 | call |
---|
| 1564 | (if n1-p |
---|
| 1565 | `(gcd-2 ,n0 ,n1) |
---|
| 1566 | (if n0-p |
---|
| 1567 | `(%integer-abs ,n0) |
---|
| 1568 | 0)))) |
---|
| 1569 | |
---|
| 1570 | (define-compiler-macro lcm (&whole call &optional (n0 nil n0-p) (n1 nil n1-p) &rest rest) |
---|
| 1571 | (if rest |
---|
| 1572 | call |
---|
| 1573 | (if n1-p |
---|
| 1574 | `(lcm-2 ,n0 ,n1) |
---|
| 1575 | (if n0-p |
---|
| 1576 | `(%integer-abs ,n0) |
---|
| 1577 | 1)))) |
---|
| 1578 | |
---|
| 1579 | (define-compiler-macro max (&whole call &environment env n0 &optional (n1 nil n1-p) &rest rest) |
---|
| 1580 | (if rest |
---|
| 1581 | call |
---|
| 1582 | (if n1-p |
---|
| 1583 | (if (and (nx-form-typep n0 'fixnum env)(nx-form-typep n1 'fixnum env)) |
---|
| 1584 | `(imax-2 ,n0 ,n1) |
---|
| 1585 | `(max-2 ,n0 ,n1)) |
---|
| 1586 | `(require-type ,n0 'real)))) |
---|
| 1587 | |
---|
| 1588 | (define-compiler-macro max-2 (n0 n1) |
---|
| 1589 | (let* ((g0 (gensym)) |
---|
| 1590 | (g1 (gensym))) |
---|
| 1591 | `(let* ((,g0 ,n0) |
---|
| 1592 | (,g1 ,n1)) |
---|
| 1593 | (if (> ,g0 ,g1) ,g0 ,g1)))) |
---|
| 1594 | |
---|
| 1595 | (define-compiler-macro imax-2 (n0 n1) |
---|
| 1596 | (let* ((g0 (gensym)) |
---|
| 1597 | (g1 (gensym))) |
---|
| 1598 | `(let* ((,g0 ,n0) |
---|
| 1599 | (,g1 ,n1)) |
---|
| 1600 | (if (%i> ,g0 ,g1) ,g0 ,g1)))) |
---|
| 1601 | |
---|
| 1602 | |
---|
| 1603 | |
---|
| 1604 | |
---|
| 1605 | (define-compiler-macro min (&whole call &environment env n0 &optional (n1 nil n1-p) &rest rest) |
---|
| 1606 | (if rest |
---|
| 1607 | call |
---|
| 1608 | (if n1-p |
---|
| 1609 | (if (and (nx-form-typep n0 'fixnum env)(nx-form-typep n1 'fixnum env)) |
---|
| 1610 | `(imin-2 ,n0 ,n1) |
---|
| 1611 | `(min-2 ,n0 ,n1)) |
---|
| 1612 | `(require-type ,n0 'real)))) |
---|
| 1613 | |
---|
| 1614 | (define-compiler-macro min-2 (n0 n1) |
---|
| 1615 | (let* ((g0 (gensym)) |
---|
| 1616 | (g1 (gensym))) |
---|
| 1617 | `(let* ((,g0 ,n0) |
---|
| 1618 | (,g1 ,n1)) |
---|
| 1619 | (if (< ,g0 ,g1) ,g0 ,g1)))) |
---|
| 1620 | |
---|
| 1621 | (define-compiler-macro imin-2 (n0 n1) |
---|
| 1622 | (let* ((g0 (gensym)) |
---|
| 1623 | (g1 (gensym))) |
---|
| 1624 | `(let* ((,g0 ,n0) |
---|
| 1625 | (,g1 ,n1)) |
---|
| 1626 | (if (%i< ,g0 ,g1) ,g0 ,g1)))) |
---|
| 1627 | |
---|
| 1628 | |
---|
| 1629 | (defun eq-test-p (test) |
---|
| 1630 | (or (equal test ''eq) (equal test '#'eq))) |
---|
| 1631 | |
---|
| 1632 | (defun eql-test-p (test) |
---|
| 1633 | (or (equal test ''eql) (equal test '#'eql))) |
---|
| 1634 | |
---|
| 1635 | (define-compiler-macro adjoin (&whole whole elt list &rest keys) |
---|
| 1636 | (if (constant-keywords-p keys) |
---|
| 1637 | (destructuring-bind (&key (test ''eql) test-not key) keys |
---|
| 1638 | (or (and (null test-not) |
---|
| 1639 | (null key) |
---|
| 1640 | (cond ((eq-test-p test) |
---|
| 1641 | `(adjoin-eq ,elt ,list)) |
---|
| 1642 | ((eql-test-p test) |
---|
| 1643 | `(adjoin-eql ,elt ,list)) |
---|
| 1644 | (t nil))) |
---|
| 1645 | whole)) |
---|
| 1646 | whole)) |
---|
| 1647 | |
---|
| 1648 | (define-compiler-macro union (&whole whole list1 list2 &rest keys) |
---|
| 1649 | (if (constant-keywords-p keys) |
---|
| 1650 | (destructuring-bind (&key (test ''eql) test-not key) keys |
---|
| 1651 | (or (and (null test-not) |
---|
| 1652 | (null key) |
---|
| 1653 | (cond ((eq-test-p test) |
---|
| 1654 | `(union-eq ,list1 ,list2)) |
---|
| 1655 | ((eql-test-p test) |
---|
| 1656 | `(union-eql ,list1 ,list2)) |
---|
| 1657 | (t nil))) |
---|
| 1658 | whole)) |
---|
| 1659 | whole)) |
---|
| 1660 | |
---|
| 1661 | (define-compiler-macro slot-value (&whole whole &environment env |
---|
| 1662 | instance slot-name-form) |
---|
[97] | 1663 | (declare (ignore env)) |
---|
| 1664 | (let* ((name (and (quoted-form-p slot-name-form) |
---|
| 1665 | (typep (cadr slot-name-form) 'symbol) |
---|
| 1666 | (cadr slot-name-form)))) |
---|
| 1667 | (if name |
---|
| 1668 | `(slot-id-value ,instance (load-time-value (ensure-slot-id ',name))) |
---|
| 1669 | whole))) |
---|
[6] | 1670 | |
---|
[97] | 1671 | |
---|
[6] | 1672 | (define-compiler-macro set-slot-value (&whole whole &environment env |
---|
| 1673 | instance slot-name-form value-form) |
---|
[97] | 1674 | (declare (ignore env)) |
---|
| 1675 | (let* ((name (and (quoted-form-p slot-name-form) |
---|
| 1676 | (typep (cadr slot-name-form) 'symbol) |
---|
| 1677 | (cadr slot-name-form)))) |
---|
| 1678 | (if name |
---|
| 1679 | `(set-slot-id-value |
---|
| 1680 | ,instance |
---|
| 1681 | (load-time-value (ensure-slot-id ',name)) |
---|
| 1682 | ,value-form) |
---|
| 1683 | whole))) |
---|
[6] | 1684 | |
---|
| 1685 | |
---|
[97] | 1686 | |
---|
[6] | 1687 | |
---|
| 1688 | (defsynonym %get-unsigned-byte %get-byte) |
---|
| 1689 | (defsynonym %get-unsigned-word %get-word) |
---|
| 1690 | (defsynonym %get-signed-long %get-long) |
---|
| 1691 | |
---|
| 1692 | |
---|
| 1693 | |
---|
| 1694 | |
---|
| 1695 | (define-compiler-macro arrayp (arg) |
---|
[1334] | 1696 | `(>= (the fixnum (typecode ,arg)) |
---|
[3228] | 1697 | ,(nx-lookup-target-uvector-subtag :array-header))) |
---|
[6] | 1698 | |
---|
| 1699 | (define-compiler-macro vectorp (arg) |
---|
[1334] | 1700 | `(>= (the fixnum (typecode ,arg)) |
---|
[3228] | 1701 | ,(nx-lookup-target-uvector-subtag :vector-header))) |
---|
[6] | 1702 | |
---|
| 1703 | |
---|
[3228] | 1704 | |
---|
[6] | 1705 | (define-compiler-macro fixnump (arg) |
---|
[3228] | 1706 | (let* ((fixnum-tag |
---|
| 1707 | (arch::target-fixnum-tag (backend-target-arch *target-backend*)))) |
---|
| 1708 | `(eql (lisptag ,arg) ,fixnum-tag))) |
---|
[6] | 1709 | |
---|
| 1710 | |
---|
[6177] | 1711 | |
---|
[6] | 1712 | (define-compiler-macro double-float-p (n) |
---|
[3228] | 1713 | (let* ((tag (arch::target-double-float-tag (backend-target-arch *target-backend*)))) |
---|
| 1714 | `(eql (typecode ,n) ,tag))) |
---|
[6] | 1715 | |
---|
| 1716 | |
---|
| 1717 | (define-compiler-macro short-float-p (n) |
---|
[3228] | 1718 | (let* ((arch (backend-target-arch *target-backend*)) |
---|
| 1719 | (tag (arch::target-single-float-tag arch)) |
---|
| 1720 | (op (if (arch::target-single-float-tag-is-subtag arch) |
---|
| 1721 | 'typecode |
---|
| 1722 | 'fulltag))) |
---|
| 1723 | `(eql (,op ,n) ,tag))) |
---|
[6] | 1724 | |
---|
| 1725 | |
---|
| 1726 | (define-compiler-macro floatp (n) |
---|
[3228] | 1727 | (let* ((typecode (make-symbol "TYPECODE")) |
---|
| 1728 | (arch (backend-target-arch *target-backend*)) |
---|
| 1729 | (single (arch::target-single-float-tag arch)) |
---|
| 1730 | (double (arch::target-double-float-tag arch))) |
---|
[6] | 1731 | `(let* ((,typecode (typecode ,n))) |
---|
| 1732 | (declare (fixnum ,typecode)) |
---|
[3228] | 1733 | (or (= ,typecode ,single) |
---|
| 1734 | (= ,typecode ,double))))) |
---|
[6] | 1735 | |
---|
| 1736 | (define-compiler-macro functionp (n) |
---|
[3228] | 1737 | (let* ((arch (backend-target-arch *target-backend*)) |
---|
| 1738 | (tag (arch::target-function-tag arch)) |
---|
| 1739 | (op (if (arch::target-function-tag-is-subtag arch) |
---|
| 1740 | 'typecode |
---|
| 1741 | 'fulltag))) |
---|
| 1742 | `(eql (,op ,n) ,tag))) |
---|
[6] | 1743 | |
---|
[1615] | 1744 | (define-compiler-macro symbolp (s) |
---|
[3228] | 1745 | (let* ((arch (backend-target-arch *target-backend*)) |
---|
| 1746 | (symtag (arch::target-symbol-tag arch)) |
---|
| 1747 | (op (if (arch::target-symbol-tag-is-subtag arch) |
---|
| 1748 | 'typecode |
---|
| 1749 | 'fulltag)) |
---|
| 1750 | (niltag (arch::target-null-tag arch))) |
---|
| 1751 | (if (eql niltag symtag) |
---|
| 1752 | `(eql (,op ,s) ,symtag) |
---|
| 1753 | (let* ((sym (gensym))) |
---|
| 1754 | `(let* ((,sym ,s)) |
---|
| 1755 | (if ,sym (eql (,op ,sym) ,symtag) t)))))) |
---|
| 1756 | |
---|
| 1757 | ;;; If NIL isn't tagged as a symbol, assume that LISPTAG only looks |
---|
| 1758 | ;;; at bits that NIL shares with a cons. |
---|
[6] | 1759 | (define-compiler-macro listp (n) |
---|
[3228] | 1760 | (let* ((arch (backend-target-arch *target-backend*)) |
---|
| 1761 | (cons-tag (arch::target-cons-tag arch)) |
---|
| 1762 | (nil-tag (arch::target-null-tag arch)) |
---|
| 1763 | (symbol-tag (arch::target-symbol-tag arch))) |
---|
| 1764 | (if (= nil-tag symbol-tag) |
---|
| 1765 | (let* ((nvar (gensym))) |
---|
| 1766 | `(let* ((,nvar ,n)) |
---|
| 1767 | (if ,nvar (consp ,nvar) t))) |
---|
| 1768 | `(eql (lisptag ,n) ,cons-tag)))) |
---|
[6] | 1769 | |
---|
| 1770 | (define-compiler-macro consp (n) |
---|
[3228] | 1771 | (let* ((cons-tag (arch::target-cons-tag (backend-target-arch *target-backend*)))) |
---|
| 1772 | `(eql (fulltag ,n) ,cons-tag))) |
---|
[6] | 1773 | |
---|
| 1774 | (define-compiler-macro bignump (n) |
---|
[3228] | 1775 | `(eql (typecode ,n) ,(nx-lookup-target-uvector-subtag :bignum))) |
---|
[6] | 1776 | |
---|
| 1777 | (define-compiler-macro ratiop (n) |
---|
[3228] | 1778 | `(eql (typecode ,n) ,(nx-lookup-target-uvector-subtag :ratio))) |
---|
[6] | 1779 | |
---|
| 1780 | (define-compiler-macro complexp (n) |
---|
[3228] | 1781 | `(eql (typecode ,n) ,(nx-lookup-target-uvector-subtag :complex))) |
---|
[6] | 1782 | |
---|
[3876] | 1783 | (define-compiler-macro macptrp (n) |
---|
| 1784 | `(eql (typecode ,n) ,(nx-lookup-target-uvector-subtag :macptr))) |
---|
[6] | 1785 | |
---|
[4910] | 1786 | (define-compiler-macro basic-stream-p (n) |
---|
| 1787 | `(eql (typecode ,n) ,(nx-lookup-target-uvector-subtag :basic-stream))) |
---|
| 1788 | |
---|
[6] | 1789 | (define-compiler-macro aref (&whole call a &rest subscripts &environment env) |
---|
[3228] | 1790 | (let* ((ctype (if (nx-form-typep a 'array env) |
---|
| 1791 | (specifier-type (nx-form-type a env)))) |
---|
| 1792 | (type (if ctype (type-specifier (array-ctype-specialized-element-type ctype)))) |
---|
| 1793 | (useful (unless (or (eq type *) (eq type t)) |
---|
| 1794 | type))) |
---|
| 1795 | (if (= 2 (length subscripts)) |
---|
[5516] | 1796 | (setq call `(%aref2 ,a ,@subscripts)) |
---|
| 1797 | (if (= 3 (length subscripts)) |
---|
| 1798 | (setq call `(%aref3 ,a ,@subscripts)))) |
---|
[3228] | 1799 | (if useful |
---|
| 1800 | `(the ,useful ,call) |
---|
| 1801 | call))) |
---|
[6] | 1802 | |
---|
| 1803 | |
---|
| 1804 | (define-compiler-macro aset (&whole call a &rest subs&val) |
---|
| 1805 | (if (= 3 (length subs&val)) |
---|
[5516] | 1806 | `(%aset2 ,a ,@subs&val) |
---|
| 1807 | (if (= 4 (length subs&val)) |
---|
| 1808 | `(%aset3 ,a ,@subs&val) |
---|
| 1809 | call))) |
---|
[6] | 1810 | |
---|
| 1811 | |
---|
| 1812 | (define-compiler-macro make-sequence (&whole call &environment env typespec len &rest keys &key initial-element) |
---|
| 1813 | (declare (ignore typespec len keys initial-element)) |
---|
| 1814 | call) |
---|
| 1815 | |
---|
| 1816 | (define-compiler-macro make-string (&whole call size &rest keys) |
---|
| 1817 | (if (constant-keywords-p keys) |
---|
| 1818 | (destructuring-bind (&key (element-type () element-type-p) |
---|
| 1819 | (initial-element () initial-element-p)) |
---|
| 1820 | keys |
---|
| 1821 | (if (and element-type-p |
---|
| 1822 | (quoted-form-p element-type)) |
---|
| 1823 | (let* ((element-type (cadr element-type))) |
---|
| 1824 | (if (subtypep element-type 'base-char) |
---|
[1334] | 1825 | `(allocate-typed-vector :simple-string ,size ,@(if initial-element-p `(,initial-element))) |
---|
[6] | 1826 | call)) |
---|
| 1827 | (if (not element-type-p) |
---|
[1334] | 1828 | `(allocate-typed-vector :simple-string ,size ,@(if initial-element-p `(,initial-element))) |
---|
[6] | 1829 | call))) |
---|
| 1830 | call)) |
---|
| 1831 | |
---|
[5404] | 1832 | (define-compiler-macro make-string-output-stream (&whole whole &rest keys) |
---|
| 1833 | (if (null keys) |
---|
| 1834 | '(make-simple-string-output-stream) |
---|
| 1835 | whole)) |
---|
| 1836 | |
---|
| 1837 | |
---|
[6] | 1838 | (define-compiler-macro sbit (&environment env &whole call v &optional sub0 &rest others) |
---|
| 1839 | (if (and sub0 (null others)) |
---|
[1245] | 1840 | `(aref (the simple-bit-vector ,v) ,sub0) |
---|
[6] | 1841 | call)) |
---|
| 1842 | |
---|
| 1843 | (define-compiler-macro %sbitset (&environment env &whole call v sub0 &optional (newval nil newval-p) &rest newval-was-really-sub1) |
---|
| 1844 | (if (and newval-p (not newval-was-really-sub1) ) |
---|
[1245] | 1845 | `(setf (aref (the simple-bit-vector ,v) ,sub0) ,newval) |
---|
[6] | 1846 | call)) |
---|
| 1847 | |
---|
| 1848 | (define-compiler-macro simple-base-string-p (thing) |
---|
[3228] | 1849 | `(= (the fixnum (typecode ,thing)) ,(nx-lookup-target-uvector-subtag :simple-string))) |
---|
[6] | 1850 | |
---|
| 1851 | (define-compiler-macro simple-string-p (thing) |
---|
| 1852 | `(simple-base-string-p ,thing)) |
---|
| 1853 | |
---|
[7940] | 1854 | (define-compiler-macro stringp (thing) |
---|
| 1855 | `(base-string-p ,thing)) |
---|
[6] | 1856 | |
---|
[7940] | 1857 | (define-compiler-macro base-string-p (thing) |
---|
| 1858 | (let* ((gthing (gensym)) |
---|
| 1859 | (gtype (gensym))) |
---|
| 1860 | `(let* ((,gthing ,thing) |
---|
| 1861 | (,gtype (typecode ,thing))) |
---|
| 1862 | (declare (type (unsigned-byte 8) ,gtype)) |
---|
| 1863 | (if (= ,gtype ,(nx-lookup-target-uvector-subtag :vector-header)) |
---|
| 1864 | (= (the (unsigned-byte 8) |
---|
| 1865 | (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref ,gthing target::arrayH.flags-cell)))) |
---|
| 1866 | ,(nx-lookup-target-uvector-subtag :simple-string)) |
---|
| 1867 | (= ,gtype ,(nx-lookup-target-uvector-subtag :simple-string)))))) |
---|
| 1868 | |
---|
| 1869 | |
---|
[6] | 1870 | (defsetf %misc-ref %misc-set) |
---|
| 1871 | |
---|
| 1872 | |
---|
| 1873 | (define-compiler-macro lockp (lock) |
---|
[3228] | 1874 | (let* ((tag (nx-lookup-target-uvector-subtag :simple-string))) |
---|
| 1875 | `(eq ,tag (typecode ,lock)))) |
---|
[6] | 1876 | |
---|
[3228] | 1877 | |
---|
| 1878 | (define-compiler-macro integerp (thing) |
---|
| 1879 | (let* ((typecode (gensym)) |
---|
| 1880 | (fixnum-tag (arch::target-fixnum-tag (backend-target-arch *target-backend*))) |
---|
| 1881 | (bignum-tag (nx-lookup-target-uvector-subtag :bignum))) |
---|
| 1882 | `(let* ((,typecode (typecode ,thing))) |
---|
| 1883 | (declare (fixnum ,typecode)) |
---|
[7940] | 1884 | (if (= ,typecode ,fixnum-tag) |
---|
| 1885 | t |
---|
| 1886 | (= ,typecode ,bignum-tag))))) |
---|
[305] | 1887 | |
---|
[388] | 1888 | (define-compiler-macro %composite-pointer-ref (size pointer offset) |
---|
| 1889 | (if (constantp size) |
---|
| 1890 | `(%inc-ptr ,pointer ,offset) |
---|
| 1891 | `(progn |
---|
| 1892 | ,size |
---|
| 1893 | (%inc-ptr ,pointer ,offset)))) |
---|
[6] | 1894 | |
---|
[1140] | 1895 | |
---|
| 1896 | (define-compiler-macro char= (&whole call ch &optional (other nil other-p) &rest others) |
---|
| 1897 | (if (null others) |
---|
| 1898 | (if other-p |
---|
| 1899 | `(eq (char-code ,ch) (char-code ,other)) |
---|
| 1900 | `(progn (char-code ,ch) t)) |
---|
[2248] | 1901 | (if (null (cdr others)) |
---|
| 1902 | (let* ((third (car others)) |
---|
| 1903 | (code (gensym))) |
---|
| 1904 | `(let* ((,code (char-code ,ch))) |
---|
| 1905 | (and (eq ,code (setq ,code (char-code ,other))) |
---|
| 1906 | (eq ,code (char-code ,third))))) |
---|
| 1907 | call))) |
---|
[1140] | 1908 | |
---|
[3423] | 1909 | (define-compiler-macro char-equal (&whole call ch &optional (other nil other-p) &rest others) |
---|
| 1910 | (if (null others) |
---|
| 1911 | (if other-p |
---|
| 1912 | `(eq (%char-code (char-upcase ,ch)) (%char-code (char-upcase ,other))) |
---|
| 1913 | `(progn (char-code ,ch) t)) |
---|
| 1914 | (if (null (cdr others)) |
---|
| 1915 | (let* ((third (car others)) |
---|
| 1916 | (code (gensym))) |
---|
| 1917 | `(let* ((,code (%char-code (char-upcase ,ch)))) |
---|
| 1918 | (and (eq ,code (setq ,code (%char-code (char-upcase ,other)))) |
---|
| 1919 | (eq ,code (%char-code (char-upcase ,third)))))) |
---|
| 1920 | call))) |
---|
| 1921 | |
---|
[1140] | 1922 | (define-compiler-macro char/= (&whole call ch &optional (other nil other-p) &rest others) |
---|
| 1923 | (if (null others) |
---|
| 1924 | (if other-p |
---|
| 1925 | `(not (eq (char-code ,ch) (char-code ,other))) |
---|
| 1926 | `(progn (char-code ,ch) t)) |
---|
| 1927 | call)) |
---|
| 1928 | |
---|
| 1929 | |
---|
| 1930 | (define-compiler-macro char< (&whole call ch &optional (other nil other-p) &rest others) |
---|
| 1931 | (if (null others) |
---|
| 1932 | (if other-p |
---|
| 1933 | `(< (the fixnum (char-code ,ch)) (the fixnum (char-code ,other))) |
---|
| 1934 | `(progn (char-code ,ch) t)) |
---|
[2248] | 1935 | (if (null (cdr others)) |
---|
| 1936 | (let* ((third (car others)) |
---|
| 1937 | (code (gensym))) |
---|
| 1938 | `(let* ((,code (char-code ,ch))) |
---|
| 1939 | (declare (fixnum ,code)) |
---|
| 1940 | (and (< ,code (setq ,code (char-code ,other))) |
---|
| 1941 | (< ,code (the fixnum (char-code ,third)))))) |
---|
| 1942 | call))) |
---|
[1140] | 1943 | |
---|
| 1944 | (define-compiler-macro char<= (&whole call ch &optional (other nil other-p) &rest others) |
---|
| 1945 | (if (null others) |
---|
| 1946 | (if other-p |
---|
| 1947 | `(<= (the fixnum (char-code ,ch)) (the fixnum (char-code ,other))) |
---|
| 1948 | `(progn (char-code ,ch) t)) |
---|
[2248] | 1949 | (if (null (cdr others)) |
---|
| 1950 | (let* ((third (car others)) |
---|
| 1951 | (code (gensym))) |
---|
| 1952 | `(let* ((,code (char-code ,ch))) |
---|
| 1953 | (declare (fixnum ,code)) |
---|
| 1954 | (and (<= ,code (setq ,code (char-code ,other))) |
---|
| 1955 | (<= ,code (the fixnum (char-code ,third)))))) |
---|
| 1956 | call))) |
---|
[1140] | 1957 | |
---|
| 1958 | (define-compiler-macro char> (&whole call ch &optional (other nil other-p) &rest others) |
---|
| 1959 | (if (null others) |
---|
| 1960 | (if other-p |
---|
| 1961 | `(> (the fixnum (char-code ,ch)) (the fixnum (char-code ,other))) |
---|
| 1962 | `(progn (char-code ,ch) t)) |
---|
[2248] | 1963 | (if (null (cdr others)) |
---|
| 1964 | (let* ((third (car others)) |
---|
| 1965 | (code (gensym))) |
---|
| 1966 | `(let* ((,code (char-code ,ch))) |
---|
| 1967 | (declare (fixnum ,code)) |
---|
| 1968 | (and (> ,code (setq ,code (char-code ,other))) |
---|
| 1969 | (> ,code (the fixnum (char-code ,third)))))) |
---|
| 1970 | call))) |
---|
[1140] | 1971 | |
---|
| 1972 | (define-compiler-macro char>= (&whole call ch &optional (other nil other-p) &rest others) |
---|
| 1973 | (if (null others) |
---|
| 1974 | (if other-p |
---|
| 1975 | `(>= (the fixnum (char-code ,ch)) (the fixnum (char-code ,other))) |
---|
| 1976 | `(progn (char-code ,ch) t)) |
---|
[2248] | 1977 | (if (null (cdr others)) |
---|
| 1978 | (let* ((third (car others)) |
---|
| 1979 | (code (gensym))) |
---|
| 1980 | `(let* ((,code (char-code ,ch))) |
---|
| 1981 | (declare (fixnum ,code)) |
---|
| 1982 | (and (>= ,code (setq ,code (char-code ,other))) |
---|
| 1983 | (>= ,code (the fixnum (char-code ,third)))))) |
---|
| 1984 | call))) |
---|
[1140] | 1985 | |
---|
[6177] | 1986 | (define-compiler-macro float (&whole call number &optional (other 0.0f0 other-p) &environment env) |
---|
| 1987 | |
---|
[3660] | 1988 | (cond ((and (typep other 'single-float) |
---|
| 1989 | (nx-form-typep number 'double-float env)) |
---|
| 1990 | `(the single-float (%double-to-single ,number))) |
---|
| 1991 | ((and (typep other 'double-float) |
---|
| 1992 | (nx-form-typep number 'single-float env)) |
---|
| 1993 | `(the double-float (%single-to-double ,number))) |
---|
[6473] | 1994 | ((and other-p (typep other 'single-float)) |
---|
[6177] | 1995 | `(the single-float (%short-float ,number))) |
---|
| 1996 | ((typep other 'double-float) |
---|
| 1997 | `(the double-float (%double-float ,number))) |
---|
[6473] | 1998 | ((null other-p) |
---|
| 1999 | (let* ((temp (gensym))) |
---|
| 2000 | `(let* ((,temp ,number)) |
---|
| 2001 | (if (typep ,temp 'double-float) |
---|
| 2002 | ,temp |
---|
| 2003 | (the single-float (%short-float ,temp)))))) |
---|
[3660] | 2004 | (t call))) |
---|
| 2005 | |
---|
| 2006 | (define-compiler-macro coerce (&whole call thing type) |
---|
| 2007 | (if (quoted-form-p type) |
---|
| 2008 | (setq type (cadr type))) |
---|
| 2009 | (if (ignore-errors (subtypep type 'single-float)) |
---|
| 2010 | `(float ,thing 0.0f0) |
---|
| 2011 | (if (ignore-errors (subtypep type 'double-float)) |
---|
| 2012 | `(float ,thing 0.0d0) |
---|
| 2013 | call))) |
---|
| 2014 | |
---|
[7624] | 2015 | (define-compiler-macro equal (&whole call x y &environment env) |
---|
| 2016 | (if (or (equal-iff-eql-p x env) |
---|
| 2017 | (equal-iff-eql-p y env)) |
---|
| 2018 | `(eql ,x ,y) |
---|
| 2019 | call)) |
---|
| 2020 | |
---|
[8130] | 2021 | (define-compiler-macro instance-slots (&whole w instance) |
---|
| 2022 | (if (and (constantp instance) |
---|
| 2023 | (eql (typecode instance) (nx-lookup-target-uvector-subtag :instance))) |
---|
| 2024 | `(instance.slots ,instance) |
---|
| 2025 | w)) |
---|
| 2026 | |
---|
| 2027 | (define-compiler-macro unsigned-byte-p (x) |
---|
| 2028 | (if (typep (nx-unquote x) 'unsigned-byte) |
---|
| 2029 | t |
---|
| 2030 | (let* ((val (gensym))) |
---|
| 2031 | `(let* ((,val ,x)) |
---|
| 2032 | (and (integerp ,val) (not (< ,val 0))))))) |
---|
| 2033 | |
---|
[6] | 2034 | (provide "OPTIMIZERS") |
---|
| 2035 | |
---|