[6] | 1 | ;;;-*- Mode: Lisp; Package: CCL -*- |
---|
| 2 | ;;; |
---|
| 3 | ;;; Copyright (C) 1994-2001 Digitool, Inc |
---|
[9389] | 4 | ;;; This file is part of OpenMCL. |
---|
[6] | 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 |
---|
[9389] | 10 | ;;; conflict, the preamble takes precedence. |
---|
[6] | 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)) |
---|
[9389] | 60 | (%symbol-bits name (logior |
---|
[6] | 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))) |
---|
[9389] | 120 | (return |
---|
[6] | 121 | (fixnumify (nreverse targs) op)))) |
---|
| 122 | call)) |
---|
| 123 | |
---|
[10008] | 124 | ;;; True if arg is an alternating list of keywords and args, only |
---|
| 125 | ;;; recognizes keywords in keyword package. Historical note: this |
---|
| 126 | ;;; used to try to ensure that the keyword appeared at most once. Why |
---|
| 127 | ;;; ? (Even before destructuring, pl-search/getf would have dtrt.) |
---|
| 128 | ;;; Side effects: it's not the right thing to simply pick the value |
---|
| 129 | ;;; associated with the first occurrence of a keyword if the value |
---|
| 130 | ;;; associated with subsequent occurrence could have a side-effect. |
---|
| 131 | ;;; (We -can- ignore a duplicate key if the associated value is |
---|
| 132 | ;;; side-effect free.) |
---|
[6] | 133 | (defun constant-keywords-p (keys) |
---|
| 134 | (when (plistp keys) |
---|
[10008] | 135 | (do* ((seen ()) |
---|
| 136 | (keys keys (cddr keys))) |
---|
| 137 | ((null keys) t) |
---|
| 138 | (let* ((key (car keys))) |
---|
| 139 | (if (or (not (keywordp key)) |
---|
| 140 | (and (memq key seen) |
---|
| 141 | (not (constantp (cadr keys))))) |
---|
| 142 | (return)) |
---|
| 143 | (push key seen))))) |
---|
[6] | 144 | |
---|
[10008] | 145 | |
---|
[7624] | 146 | (defun remove-explicit-test-keyword-from-test-testnot-key (item list keys default alist testonly) |
---|
| 147 | (if (null keys) |
---|
| 148 | `(,default ,item ,list) |
---|
| 149 | (if (constant-keywords-p keys) |
---|
[6] | 150 | (destructuring-bind (&key (test nil test-p) |
---|
| 151 | (test-not nil test-not-p) |
---|
| 152 | (key nil key-p)) |
---|
| 153 | keys |
---|
[7624] | 154 | (declare (ignore test-not)) |
---|
[9389] | 155 | (if (and test-p |
---|
[7624] | 156 | (not test-not-p) |
---|
| 157 | (or (not key-p) |
---|
| 158 | (and (consp key) |
---|
| 159 | (consp (%cdr key)) |
---|
| 160 | (null (%cddr key)) |
---|
| 161 | (or (eq (%car key) 'function) |
---|
| 162 | (eq (%car key) 'quote)) |
---|
| 163 | (eq (%cadr key) 'identity))) |
---|
[9389] | 164 | (consp test) |
---|
[6] | 165 | (consp (%cdr test)) |
---|
| 166 | (null (%cddr test)) |
---|
| 167 | (or (eq (%car test) 'function) |
---|
| 168 | (eq (%car test) 'quote))) |
---|
[7624] | 169 | (let* ((testname (%cadr test)) |
---|
| 170 | (reduced (cdr (assoc testname alist)))) |
---|
| 171 | (if reduced |
---|
| 172 | `(,reduced ,item ,list) |
---|
| 173 | `(,testonly ,item ,list ,test)))))))) |
---|
[6] | 174 | |
---|
[7624] | 175 | |
---|
[6] | 176 | (defun eql-iff-eq-p (thing env) |
---|
[3660] | 177 | (if (quoted-form-p thing) |
---|
| 178 | (setq thing (%cadr thing)) |
---|
| 179 | (if (not (self-evaluating-p thing)) |
---|
[6] | 180 | (return-from eql-iff-eq-p |
---|
[7624] | 181 | (or (nx-form-typep thing 'symbol env) |
---|
| 182 | (nx-form-typep thing 'character env) |
---|
| 183 | (nx-form-typep thing |
---|
| 184 | '(or fixnum |
---|
| 185 | #+64-bit-target single-float |
---|
| 186 | symbol character |
---|
| 187 | (and (not number) (not macptr))) env))))) |
---|
[3660] | 188 | (or (fixnump thing) #+64-bit-target (typep thing 'single-float) |
---|
[7624] | 189 | (symbolp thing) (characterp thing) |
---|
[3660] | 190 | (and (not (numberp thing)) (not (macptrp thing))))) |
---|
[6] | 191 | |
---|
[7624] | 192 | (defun equal-iff-eql-p (thing env) |
---|
| 193 | (if (quoted-form-p thing) |
---|
| 194 | (setq thing (%cadr thing)) |
---|
| 195 | (if (not (self-evaluating-p thing)) |
---|
| 196 | (return-from equal-iff-eql-p |
---|
| 197 | (nx-form-typep thing |
---|
| 198 | '(and (not cons) (not string) (not bit-vector) (not pathname)) env)))) |
---|
| 199 | (not (typep thing '(or cons string bit-vector pathname)))) |
---|
| 200 | |
---|
| 201 | |
---|
[6] | 202 | (defun fold-constant-subforms (call env) |
---|
| 203 | (let* ((constants nil) |
---|
| 204 | (forms nil)) |
---|
| 205 | (declare (list constants forms)) |
---|
| 206 | (dolist (form (cdr call)) |
---|
| 207 | (setq form (nx-transform form env)) |
---|
| 208 | (if (numberp form) |
---|
| 209 | (setq constants (%temp-cons form constants)) |
---|
| 210 | (setq forms (%temp-cons form forms)))) |
---|
| 211 | (if constants |
---|
| 212 | (let* ((op (car call)) |
---|
| 213 | (constant (if (cdr constants) (handler-case (apply op constants) |
---|
[9389] | 214 | (error (c) (declare (ignore c)) |
---|
[6] | 215 | (return-from fold-constant-subforms (values call t)))) |
---|
| 216 | (car constants)))) |
---|
| 217 | (values (if forms (cons op (cons constant (reverse forms))) constant) t)) |
---|
| 218 | (values call nil)))) |
---|
| 219 | |
---|
| 220 | ;;; inline some, etc. in some cases |
---|
| 221 | ;;; in all cases, add dynamic-extent declarations |
---|
| 222 | (defun some-xx-transform (call env) |
---|
| 223 | (destructuring-bind (func predicate sequence &rest args) call |
---|
| 224 | (multiple-value-bind (func-constant end-value loop-test) |
---|
| 225 | (case func |
---|
| 226 | (some (values $some nil 'when)) |
---|
| 227 | (notany (values $notany t 'when)) |
---|
| 228 | (every (values $every t 'unless)) |
---|
| 229 | (notevery (values $notevery nil 'unless))) |
---|
| 230 | (if args |
---|
| 231 | (let ((func-sym (gensym)) |
---|
| 232 | (seq-sym (gensym)) |
---|
| 233 | (list-sym (gensym))) |
---|
| 234 | `(let ((,func-sym ,predicate) |
---|
| 235 | (,seq-sym ,sequence) |
---|
| 236 | (,list-sym (list ,@args))) |
---|
| 237 | (declare (dynamic-extent ,func-sym ,list-sym ,seq-sym)) |
---|
| 238 | (some-xx-multi ,func-constant ,end-value ,func-sym ,seq-sym ,list-sym))) |
---|
| 239 | (let ((loop-function (nx-form-sequence-iterator sequence env))) |
---|
| 240 | ;; inline if we know the type of the sequence and if |
---|
| 241 | ;; the predicate is a lambda expression |
---|
| 242 | ;; otherwise, it blows up the code for not much gain |
---|
| 243 | (if (and loop-function |
---|
| 244 | (function-form-p predicate) |
---|
| 245 | (lambda-expression-p (second predicate))) |
---|
| 246 | (let ((elt-var (gensym))) |
---|
| 247 | (case func |
---|
| 248 | (some |
---|
| 249 | `(,loop-function (,elt-var ,sequence ,end-value) |
---|
| 250 | (let ((result (funcall ,predicate ,elt-var))) |
---|
| 251 | (when result (return result))))) |
---|
| 252 | ((every notevery notany) |
---|
| 253 | `(,loop-function (,elt-var ,sequence ,end-value) |
---|
| 254 | (,loop-test (funcall ,predicate ,elt-var) |
---|
| 255 | (return ,(not end-value))))))) |
---|
| 256 | (let ((func-sym (gensym)) |
---|
| 257 | (seq-sym (gensym))) |
---|
| 258 | `(let ((,func-sym ,predicate) |
---|
| 259 | (,seq-sym ,sequence)) |
---|
| 260 | (declare (dynamic-extent ,func-sym ,seq-sym)) |
---|
| 261 | (some-xx-one ,func-constant ,end-value ,func-sym ,seq-sym))))))))) |
---|
| 262 | |
---|
| 263 | |
---|
| 264 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
---|
[1989] | 265 | ;;; |
---|
| 266 | ;;; The new (roughly alphabetical) order. |
---|
[9389] | 267 | ;;; |
---|
[6] | 268 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
---|
| 269 | |
---|
[1989] | 270 | ;;; Compiler macros on functions can assume that their arguments have |
---|
| 271 | ;;; already been transformed. |
---|
[6] | 272 | |
---|
| 273 | |
---|
| 274 | (defun transform-real-n-ary-comparision (whole binary-name) |
---|
| 275 | (destructuring-bind (n0 &optional (n1 0 n1-p) &rest more) (cdr whole) |
---|
| 276 | (if more |
---|
[2248] | 277 | (if (cdr more) |
---|
| 278 | whole |
---|
| 279 | (let* ((n2 (car more)) |
---|
| 280 | (n (gensym))) |
---|
| 281 | `(let* ((,n ,n0)) |
---|
| 282 | (if (,binary-name ,n (setq ,n ,n1)) |
---|
| 283 | (,binary-name ,n ,n2))))) |
---|
[6] | 284 | (if (not n1-p) |
---|
| 285 | `(require-type ,n0 'real) |
---|
| 286 | `(,binary-name ,n0 ,n1))))) |
---|
| 287 | |
---|
| 288 | |
---|
| 289 | |
---|
| 290 | (define-compiler-macro < (&whole whole &rest ignore) |
---|
| 291 | (declare (ignore ignore)) |
---|
| 292 | (transform-real-n-ary-comparision whole '<-2)) |
---|
| 293 | |
---|
| 294 | (define-compiler-macro > (&whole whole &rest ignore) |
---|
| 295 | (declare (ignore ignore)) |
---|
| 296 | (transform-real-n-ary-comparision whole '>-2)) |
---|
| 297 | |
---|
| 298 | (define-compiler-macro <= (&whole whole &rest ignore) |
---|
| 299 | (declare (ignore ignore)) |
---|
| 300 | (transform-real-n-ary-comparision whole '<=-2)) |
---|
| 301 | |
---|
| 302 | (define-compiler-macro >= (&whole whole &rest ignore) |
---|
| 303 | (declare (ignore ignore)) |
---|
| 304 | (transform-real-n-ary-comparision whole '>=-2)) |
---|
| 305 | |
---|
| 306 | |
---|
| 307 | (define-compiler-macro 1- (x) |
---|
| 308 | `(- ,x 1)) |
---|
| 309 | |
---|
| 310 | (define-compiler-macro 1+ (x) |
---|
| 311 | `(+ ,x 1)) |
---|
| 312 | |
---|
[9389] | 313 | (define-compiler-macro append (&whole call |
---|
| 314 | &optional arg0 |
---|
| 315 | &rest |
---|
| 316 | (&whole tail |
---|
| 317 | &optional (junk nil arg1-p) |
---|
[6] | 318 | &rest more)) |
---|
| 319 | ;(append (list x y z) A) -> (list* x y z A) |
---|
| 320 | (if (and arg1-p |
---|
| 321 | (null more) |
---|
| 322 | (consp arg0) |
---|
| 323 | (eq (%car arg0) 'list)) |
---|
| 324 | (cons 'list* (append (%cdr arg0) tail)) |
---|
| 325 | (if (and arg1-p (null more)) |
---|
| 326 | `(append-2 ,arg0 ,junk) |
---|
| 327 | call))) |
---|
| 328 | |
---|
| 329 | (define-compiler-macro apply (&whole call &environment env fn arg0 &rest args) |
---|
[7841] | 330 | ;; Special-case (apply #'make-instance 'name ...) |
---|
| 331 | ;; Might be good to make this a little more general, e.g., there |
---|
| 332 | ;; may be other things that can be strength-reduced even if we can't |
---|
| 333 | ;; get rid of the APPLY. |
---|
| 334 | (if (and (consp fn) |
---|
| 335 | (or (eq (car fn) 'quote) |
---|
| 336 | (eq (car fn) 'function)) |
---|
| 337 | (consp (cdr fn)) |
---|
| 338 | (null (cddr fn)) |
---|
| 339 | (eq (cadr fn) 'make-instance) |
---|
| 340 | (consp arg0) |
---|
[7843] | 341 | (eq (car arg0) 'quote) |
---|
[7841] | 342 | (consp (cdr arg0)) |
---|
| 343 | (symbolp (cadr arg0))) |
---|
| 344 | (let* ((name (cadr arg0)) |
---|
| 345 | (class-cell (gensym))) |
---|
| 346 | `(let* ((,class-cell (load-time-value (find-class-cell ',name t)))) |
---|
| 347 | (apply (class-cell-instantiate ,class-cell) ,class-cell ,@args))) |
---|
| 348 | (let ((original-fn fn)) |
---|
[9389] | 349 | (if (and arg0 |
---|
[7841] | 350 | (null args) |
---|
| 351 | (consp fn) |
---|
| 352 | (eq (%car fn) 'function) |
---|
| 353 | (null (cdr (%cdr fn))) |
---|
| 354 | (consp (setq fn (%cadr fn))) |
---|
| 355 | (eq (%car fn) 'lambda)) |
---|
| 356 | (destructuring-bind (lambda-list &body body) (%cdr fn) |
---|
| 357 | `(destructuring-bind ,lambda-list ,arg0 ,@body)) |
---|
| 358 | (let ((last (%car (last (push arg0 args))))) |
---|
| 359 | (if (and (consp last) (memq (%car last) '(cons list* list))) |
---|
| 360 | (cons (if (eq (%car last) 'list) 'funcall 'apply) |
---|
| 361 | (cons |
---|
| 362 | original-fn |
---|
| 363 | (nreconc (cdr (reverse args)) (%cdr last)))) |
---|
| 364 | call)))))) |
---|
[6] | 365 | |
---|
| 366 | |
---|
| 367 | |
---|
[7624] | 368 | (define-compiler-macro assoc (&whole call item list &rest keys) |
---|
| 369 | (or (remove-explicit-test-keyword-from-test-testnot-key item list keys 'asseql '((eq . assq) (eql . asseql) (equal . assequal)) 'assoc-test) |
---|
[6] | 370 | call)) |
---|
| 371 | |
---|
[7624] | 372 | (define-compiler-macro assequal (&whole call &environment env item list) |
---|
| 373 | (if (or (equal-iff-eql-p item env) |
---|
| 374 | (and (quoted-form-p list) |
---|
| 375 | (proper-list-p (%cadr list)) |
---|
| 376 | (every (lambda (x) (equal-iff-eql-p (car x) env)) (%cadr list)))) |
---|
| 377 | `(asseql ,item ,list) |
---|
| 378 | call)) |
---|
[9389] | 379 | |
---|
[7624] | 380 | (define-compiler-macro asseql (&whole call &environment env item list) |
---|
| 381 | (if (or (eql-iff-eq-p item env) |
---|
| 382 | (and (quoted-form-p list) |
---|
| 383 | (proper-list-p (%cadr list)) |
---|
| 384 | (every (lambda (x) (eql-iff-eq-p (car x) env)) (%cadr list)))) |
---|
| 385 | `(assq ,item ,list) |
---|
| 386 | call)) |
---|
[2280] | 387 | |
---|
[7624] | 388 | (define-compiler-macro assq (item list) |
---|
| 389 | (let* ((itemx (gensym)) |
---|
| 390 | (listx (gensym)) |
---|
| 391 | (pair (gensym))) |
---|
| 392 | `(let* ((,itemx ,item) |
---|
| 393 | (,listx ,list)) |
---|
| 394 | (dolist (,pair ,listx) |
---|
| 395 | (when (and ,pair (eq (car ,pair) ,itemx)) (return ,pair)))))) |
---|
| 396 | |
---|
[2280] | 397 | (define-compiler-macro caar (form) |
---|
| 398 | `(car (car ,form))) |
---|
| 399 | |
---|
| 400 | (define-compiler-macro cadr (form) |
---|
| 401 | `(car (cdr ,form))) |
---|
| 402 | |
---|
| 403 | (define-compiler-macro cdar (form) |
---|
| 404 | `(cdr (car ,form))) |
---|
| 405 | |
---|
| 406 | (define-compiler-macro cddr (form) |
---|
| 407 | `(cdr (cdr ,form))) |
---|
| 408 | |
---|
[6] | 409 | (define-compiler-macro caaar (form) |
---|
| 410 | `(car (caar ,form))) |
---|
| 411 | |
---|
| 412 | (define-compiler-macro caadr (form) |
---|
| 413 | `(car (cadr ,form))) |
---|
| 414 | |
---|
| 415 | (define-compiler-macro cadar (form) |
---|
| 416 | `(car (cdar ,form))) |
---|
| 417 | |
---|
| 418 | (define-compiler-macro caddr (form) |
---|
| 419 | `(car (cddr ,form))) |
---|
| 420 | |
---|
| 421 | (define-compiler-macro cdaar (form) |
---|
| 422 | `(cdr (caar ,form))) |
---|
| 423 | |
---|
| 424 | (define-compiler-macro cdadr (form) |
---|
| 425 | `(cdr (cadr ,form))) |
---|
| 426 | |
---|
| 427 | (define-compiler-macro cddar (form) |
---|
| 428 | `(cdr (cdar ,form))) |
---|
| 429 | |
---|
| 430 | (define-compiler-macro cdddr (form) |
---|
| 431 | `(cdr (cddr ,form))) |
---|
| 432 | |
---|
[2280] | 433 | (define-compiler-macro caaaar (form) |
---|
| 434 | `(car (caaar ,form))) |
---|
[9389] | 435 | |
---|
[2280] | 436 | (define-compiler-macro caaadr (form) |
---|
| 437 | `(car (caadr ,form))) |
---|
[6] | 438 | |
---|
[2280] | 439 | (define-compiler-macro caadar (form) |
---|
| 440 | `(car (cadar ,form))) |
---|
[6] | 441 | |
---|
[2280] | 442 | (define-compiler-macro caaddr (form) |
---|
| 443 | `(car (caddr ,form))) |
---|
[6] | 444 | |
---|
[2280] | 445 | (define-compiler-macro cadaar (form) |
---|
| 446 | `(car (cdaar ,form))) |
---|
| 447 | |
---|
| 448 | (define-compiler-macro cadadr (form) |
---|
| 449 | `(car (cdadr ,form))) |
---|
| 450 | |
---|
| 451 | (define-compiler-macro caddar (form) |
---|
| 452 | `(car (cddar ,form))) |
---|
| 453 | |
---|
| 454 | (define-compiler-macro cadddr (form) |
---|
| 455 | `(car (cdddr ,form))) |
---|
| 456 | |
---|
| 457 | (define-compiler-macro cdaaar (form) |
---|
| 458 | `(cdr (caaar ,form))) |
---|
[9389] | 459 | |
---|
[2280] | 460 | (define-compiler-macro cdaadr (form) |
---|
| 461 | `(cdr (caadr ,form))) |
---|
| 462 | |
---|
| 463 | (define-compiler-macro cdadar (form) |
---|
| 464 | `(cdr (cadar ,form))) |
---|
| 465 | |
---|
| 466 | (define-compiler-macro cdaddr (form) |
---|
| 467 | `(cdr (caddr ,form))) |
---|
| 468 | |
---|
| 469 | (define-compiler-macro cddaar (form) |
---|
| 470 | `(cdr (cdaar ,form))) |
---|
| 471 | |
---|
| 472 | (define-compiler-macro cddadr (form) |
---|
| 473 | `(cdr (cdadr ,form))) |
---|
| 474 | |
---|
| 475 | (define-compiler-macro cdddar (form) |
---|
| 476 | `(cdr (cddar ,form))) |
---|
| 477 | |
---|
| 478 | (define-compiler-macro cddddr (form) |
---|
| 479 | `(cdr (cdddr ,form))) |
---|
| 480 | |
---|
| 481 | |
---|
| 482 | |
---|
| 483 | |
---|
[6] | 484 | (define-compiler-macro cons (&whole call &environment env x y &aux dcall ddcall) |
---|
| 485 | (if (consp (setq dcall y)) |
---|
| 486 | (cond |
---|
| 487 | ((or (eq (%car dcall) 'list) (eq (%car dcall) 'list*)) |
---|
| 488 | ;(CONS A (LIST[*] . args)) -> (LIST[*] A . args) |
---|
| 489 | (list* (%car dcall) x (%cdr dcall))) |
---|
| 490 | ((or (neq (%car dcall) 'cons) (null (cddr dcall)) (cdddr dcall)) |
---|
| 491 | call) |
---|
| 492 | ((null (setq ddcall (%caddr dcall))) |
---|
| 493 | ;(CONS A (CONS B NIL)) -> (LIST A B) |
---|
| 494 | `(list ,x ,(%cadr dcall))) |
---|
| 495 | ((and (consp ddcall) |
---|
| 496 | (eq (%car ddcall) 'cons) |
---|
| 497 | (eq (list-length ddcall) 3)) |
---|
| 498 | ;(CONS A (CONS B (CONS C D))) -> (LIST* A B C D) |
---|
| 499 | (list* 'list* x (%cadr dcall) (%cdr ddcall))) |
---|
| 500 | (t call)) |
---|
| 501 | call)) |
---|
| 502 | |
---|
[9389] | 503 | (define-compiler-macro dotimes (&whole call (i n &optional result) |
---|
[6] | 504 | &body body |
---|
| 505 | &environment env) |
---|
| 506 | (multiple-value-bind (body decls) (parse-body body env) |
---|
| 507 | (if (nx-form-typep (setq n (nx-transform n env)) 'fixnum env) |
---|
| 508 | (let* ((limit (gensym)) |
---|
| 509 | (upper (if (constantp n) n most-positive-fixnum)) |
---|
| 510 | (top (gensym)) |
---|
| 511 | (test (gensym))) |
---|
| 512 | `(let* ((,limit ,n) (,i 0)) |
---|
| 513 | ,@decls |
---|
| 514 | (declare (fixnum ,limit) |
---|
| 515 | (type (integer 0 ,(if (<= upper 0) 0 `(,upper))) ,i) |
---|
| 516 | (unsettable ,i)) |
---|
| 517 | (block nil |
---|
| 518 | (tagbody |
---|
| 519 | (go ,test) |
---|
| 520 | ,top |
---|
| 521 | ,@body |
---|
| 522 | (locally |
---|
| 523 | (declare (settable ,i)) |
---|
| 524 | (setq ,i (1+ ,i))) |
---|
| 525 | ,test |
---|
| 526 | (when (< ,i ,limit) (go ,top))) |
---|
| 527 | ,result))) |
---|
| 528 | call))) |
---|
| 529 | |
---|
| 530 | (define-compiler-macro dpb (&whole call &environment env value byte integer) |
---|
[305] | 531 | (cond ((and (integerp byte) (> byte 0)) |
---|
[6] | 532 | (if (integerp value) |
---|
| 533 | `(logior ,(dpb value byte 0) (logand ,(lognot byte) ,integer)) |
---|
| 534 | `(deposit-field (ash ,value ,(byte-position byte)) ,byte ,integer))) |
---|
| 535 | ((and (consp byte) |
---|
| 536 | (eq (%car byte) 'byte) |
---|
| 537 | (eq (list-length (%cdr byte)) 2)) |
---|
| 538 | `(deposit-byte ,value ,(%cadr byte) ,(%caddr byte) ,integer)) |
---|
| 539 | (t call))) |
---|
| 540 | |
---|
| 541 | (define-compiler-macro eql (&whole call &environment env v1 v2) |
---|
| 542 | (if (or (eql-iff-eq-p v1 env) (eql-iff-eq-p v2 env)) |
---|
| 543 | `(eq ,v1 ,v2) |
---|
| 544 | call)) |
---|
| 545 | |
---|
| 546 | (define-compiler-macro every (&whole call &environment env &rest ignore) |
---|
| 547 | (declare (ignore ignore)) |
---|
| 548 | (some-xx-transform call env)) |
---|
| 549 | |
---|
| 550 | |
---|
| 551 | (define-compiler-macro identity (form) form) |
---|
| 552 | |
---|
| 553 | (define-compiler-macro if (&whole call test true &optional false &environment env) |
---|
| 554 | (multiple-value-bind (test test-win) (nx-transform test env) |
---|
[8554] | 555 | (if (or (quoted-form-p test) (self-evaluating-p test)) |
---|
[9389] | 556 | (if (eval test) |
---|
[8554] | 557 | true |
---|
| 558 | false) |
---|
| 559 | (if test-win |
---|
| 560 | `(if ,test ,@(cddr call)) |
---|
| 561 | call)))) |
---|
[6] | 562 | |
---|
| 563 | (define-compiler-macro %ilsr (&whole call &environment env shift value) |
---|
| 564 | (if (eql shift 0) |
---|
| 565 | value |
---|
| 566 | (if (eql value 0) |
---|
| 567 | `(progn ,shift 0) |
---|
| 568 | call))) |
---|
| 569 | |
---|
[9389] | 570 | (defun string-designator-p (object) |
---|
| 571 | (typecase object |
---|
| 572 | (character t) |
---|
| 573 | (symbol t) |
---|
| 574 | (string t))) |
---|
[6] | 575 | |
---|
| 576 | (define-compiler-macro ldb (&whole call &environment env byte integer) |
---|
[305] | 577 | (cond ((and (integerp byte) (> byte 0)) |
---|
[6] | 578 | (let ((size (byte-size byte)) |
---|
| 579 | (position (byte-position byte))) |
---|
| 580 | (cond ((nx-form-typep integer 'fixnum env) |
---|
| 581 | `(logand ,(byte-mask size) |
---|
[5263] | 582 | (the fixnum (ash ,integer ,(- position))))) |
---|
[6] | 583 | (t `(load-byte ,size ,position ,integer))))) |
---|
| 584 | ((and (consp byte) |
---|
| 585 | (eq (%car byte) 'byte) |
---|
| 586 | (eq (list-length (%cdr byte)) 2)) |
---|
| 587 | (let ((size (%cadr byte)) |
---|
| 588 | (position (%caddr byte))) |
---|
| 589 | (if (and (nx-form-typep integer 'fixnum env) (fixnump position)) |
---|
[4137] | 590 | ;; I'm not sure this is worth doing |
---|
[5263] | 591 | `(logand (byte-mask ,size) (the fixnum (ash ,integer ,(- position)))) |
---|
[4137] | 592 | ;; this IS worth doing |
---|
[6] | 593 | `(load-byte ,size ,position ,integer)))) |
---|
| 594 | (t call))) |
---|
| 595 | |
---|
| 596 | (define-compiler-macro length (&whole call &environment env seq) |
---|
| 597 | (if (nx-form-typep seq '(simple-array * (*)) env) |
---|
| 598 | `(uvsize ,seq) |
---|
| 599 | call)) |
---|
| 600 | |
---|
| 601 | (define-compiler-macro let (&whole call (&optional (first nil first-p) &rest rest) &body body) |
---|
| 602 | (if first-p |
---|
| 603 | (if rest |
---|
| 604 | call |
---|
| 605 | `(let* (,first) ,@body)) |
---|
| 606 | `(locally ,@body))) |
---|
| 607 | |
---|
| 608 | (define-compiler-macro let* (&whole call (&rest bindings) &body body) |
---|
| 609 | (if bindings |
---|
| 610 | call |
---|
| 611 | `(locally ,@body))) |
---|
| 612 | |
---|
| 613 | (define-compiler-macro list* (&whole call &environment env &rest rest &aux (n (list-length rest)) last) |
---|
| 614 | (cond ((%izerop n) nil) |
---|
| 615 | ((null (setq last (%car (last call)))) |
---|
| 616 | (cons 'list (nreverse (cdr (reverse (cdr call)))))) |
---|
| 617 | ((and (consp last) (memq (%car last) '(list* list cons))) |
---|
| 618 | (cons (if (eq (%car last) 'cons) 'list* (%car last)) |
---|
| 619 | (nreconc (cdr (reverse (cdr call))) (%cdr last)))) |
---|
| 620 | ((eq n 1) (list 'values last)) |
---|
| 621 | ((eq n 2) (cons 'cons (%cdr call))) |
---|
| 622 | (t call))) |
---|
| 623 | |
---|
| 624 | |
---|
| 625 | |
---|
[1989] | 626 | ;;;(CONS X NIL) is same size as (LIST X) and faster. |
---|
[6] | 627 | (define-compiler-macro list (&whole call &optional (first nil first-p) &rest more) |
---|
| 628 | (if more |
---|
| 629 | call |
---|
| 630 | (if first-p |
---|
| 631 | `(cons ,first nil)))) |
---|
| 632 | |
---|
| 633 | |
---|
| 634 | (define-compiler-macro locally (&whole call &body body &environment env) |
---|
| 635 | (multiple-value-bind (body decls) (parse-body body env nil) |
---|
| 636 | (if decls |
---|
| 637 | call |
---|
| 638 | `(progn ,@body)))) |
---|
| 639 | |
---|
[9338] | 640 | (defun specifier-type-if-known (typespec &optional env) |
---|
| 641 | (handler-case (specifier-type typespec env) |
---|
| 642 | (parse-unknown-type (c) (values nil (parse-unknown-type-specifier c))) |
---|
[9245] | 643 | (error () nil))) |
---|
[6] | 644 | |
---|
[9390] | 645 | #+debugging-version |
---|
| 646 | (defun specifier-type-if-known (typespec &optional env) |
---|
| 647 | (handler-bind ((parse-unknown-type (lambda (c) |
---|
| 648 | (break "caught unknown-type ~s" c) |
---|
| 649 | (return-from specifier-type-if-known |
---|
| 650 | (values nil (parse-unknown-type-specifier c))))) |
---|
| 651 | (error (lambda (c) |
---|
| 652 | (break "caught error ~s" c) |
---|
| 653 | (return-from specifier-type-if-known nil)))) |
---|
| 654 | (specifier-type typespec env))) |
---|
[9245] | 655 | |
---|
[9390] | 656 | |
---|
[9338] | 657 | (defun target-element-type-type-keyword (typespec &optional env) |
---|
| 658 | (let* ((ctype (specifier-type-if-known `(array ,typespec) env))) |
---|
[9245] | 659 | (if (null ctype) |
---|
[6] | 660 | (progn |
---|
| 661 | (nx1-whine :unknown-type-declaration typespec) |
---|
| 662 | nil) |
---|
[1373] | 663 | (funcall (arch::target-array-type-name-from-ctype-function |
---|
| 664 | (backend-target-arch *target-backend*)) |
---|
| 665 | ctype)))) |
---|
[6] | 666 | |
---|
[5525] | 667 | (defun infer-array-type (dims element-type element-type-p displaced-to-p fill-pointer-p adjustable-p env) |
---|
| 668 | (let* ((ctype (make-array-ctype :complexp (or displaced-to-p fill-pointer-p adjustable-p)))) |
---|
| 669 | (if (quoted-form-p dims) |
---|
| 670 | (let* ((dims (nx-unquote dims))) |
---|
| 671 | (if (listp dims) |
---|
| 672 | (progn |
---|
| 673 | (unless (every #'fixnump dims) |
---|
| 674 | (warn "Funky-looking array dimensions ~s in MAKE-ARRAY call" dims)) |
---|
| 675 | (setf (array-ctype-dimensions ctype) dims)) |
---|
| 676 | (progn |
---|
| 677 | (unless (typep dims 'fixnum) |
---|
| 678 | (warn "Funky-looking array dimensions ~s in MAKE-ARRAY call" dims)) |
---|
| 679 | (setf (array-ctype-dimensions ctype) (list dims))))) |
---|
| 680 | (if (atom dims) |
---|
| 681 | (if (nx-form-typep dims 'fixnum env) |
---|
| 682 | (setf (array-ctype-dimensions ctype) |
---|
| 683 | (if (typep (setq dims (nx-transform dims env)) 'fixnum) |
---|
| 684 | (list dims) |
---|
| 685 | (list '*))) |
---|
| 686 | (setf (array-ctype-dimensions ctype) '*)) |
---|
| 687 | (if (eq (car dims) 'list) |
---|
| 688 | (setf (array-ctype-dimensions ctype) |
---|
| 689 | (mapcar #'(lambda (d) |
---|
| 690 | (if (typep (setq d (nx-transform d env)) 'fixnum) |
---|
| 691 | d |
---|
| 692 | '*)) |
---|
| 693 | (cdr dims))) |
---|
| 694 | ;; Wimp out |
---|
| 695 | (setf (array-ctype-dimensions ctype) |
---|
| 696 | '*)))) |
---|
[10008] | 697 | (let* ((typespec (if element-type-p |
---|
| 698 | (if (constantp element-type) |
---|
| 699 | (nx-unquote element-type) |
---|
| 700 | '*) |
---|
| 701 | t)) |
---|
[9338] | 702 | (element-type (or (specifier-type-if-known typespec env) |
---|
[9245] | 703 | (make-unknown-ctype :specifier typespec)))) |
---|
[5525] | 704 | (setf (array-ctype-element-type ctype) element-type) |
---|
| 705 | (if (typep element-type 'unknown-ctype) |
---|
[10008] | 706 | (setf (array-ctype-element-type ctype) *wild-type*)) |
---|
| 707 | (specialize-array-type ctype)) |
---|
[5525] | 708 | (type-specifier ctype))) |
---|
| 709 | |
---|
[9389] | 710 | |
---|
| 711 | |
---|
[6] | 712 | (define-compiler-macro make-array (&whole call &environment env dims &rest keys) |
---|
| 713 | (if (constant-keywords-p keys) |
---|
| 714 | (destructuring-bind (&key (element-type t element-type-p) |
---|
| 715 | (displaced-to () displaced-to-p) |
---|
| 716 | (displaced-index-offset () displaced-index-offset-p) |
---|
| 717 | (adjustable () adjustable-p) |
---|
| 718 | (fill-pointer () fill-pointer-p) |
---|
| 719 | (initial-element () initial-element-p) |
---|
[9389] | 720 | (initial-contents () initial-contents-p)) |
---|
[5525] | 721 | keys |
---|
| 722 | (declare (ignorable element-type element-type-p |
---|
| 723 | displaced-to displaced-to-p |
---|
| 724 | displaced-index-offset displaced-index-offset-p |
---|
| 725 | adjustable adjustable-p |
---|
| 726 | fill-pointer fill-pointer-p |
---|
| 727 | initial-element initial-element-p |
---|
| 728 | initial-contents initial-contents-p)) |
---|
| 729 | (let* ((element-type-keyword nil) |
---|
[9389] | 730 | (expansion |
---|
[5525] | 731 | (cond ((and initial-element-p initial-contents-p) |
---|
| 732 | (nx1-whine 'illegal-arguments call) |
---|
| 733 | call) |
---|
| 734 | (displaced-to-p |
---|
| 735 | (if (or initial-element-p initial-contents-p element-type-p) |
---|
| 736 | (comp-make-array-1 dims keys) |
---|
| 737 | (comp-make-displaced-array dims keys))) |
---|
[9389] | 738 | ((or displaced-index-offset-p |
---|
[5525] | 739 | (not (constantp element-type)) |
---|
| 740 | (null (setq element-type-keyword |
---|
| 741 | (target-element-type-type-keyword |
---|
[9338] | 742 | (eval element-type) env)))) |
---|
[5525] | 743 | (comp-make-array-1 dims keys)) |
---|
[9389] | 744 | ((and (typep element-type-keyword 'keyword) |
---|
| 745 | (nx-form-typep dims 'fixnum env) |
---|
| 746 | (null (or adjustable fill-pointer initial-contents |
---|
| 747 | initial-contents-p))) |
---|
| 748 | (if |
---|
| 749 | (or (null initial-element-p) |
---|
| 750 | (cond ((eql element-type-keyword :double-float-vector) |
---|
| 751 | (eql initial-element 0.0d0)) |
---|
| 752 | ((eql element-type-keyword :single-float-vector) |
---|
| 753 | (eql initial-element 0.0s0)) |
---|
| 754 | ((eql element-type :simple-string) |
---|
[5525] | 755 | (eql initial-element #\Null)) |
---|
| 756 | (t (eql initial-element 0)))) |
---|
[9389] | 757 | `(allocate-typed-vector ,element-type-keyword ,dims) |
---|
| 758 | `(allocate-typed-vector ,element-type-keyword ,dims ,initial-element))) |
---|
[5525] | 759 | (t ;Should do more here |
---|
| 760 | (comp-make-uarray dims keys (type-keyword-code element-type-keyword))))) |
---|
| 761 | (type (infer-array-type dims element-type element-type-p displaced-to-p fill-pointer-p adjustable-p env))) |
---|
| 762 | `(the ,type ,expansion))) |
---|
[9389] | 763 | |
---|
[5525] | 764 | call)) |
---|
[6] | 765 | |
---|
| 766 | (defun comp-make-displaced-array (dims keys) |
---|
| 767 | (let* ((call-list (make-list 4 :initial-element nil)) |
---|
| 768 | (dims-var (make-symbol "DIMS")) |
---|
| 769 | (let-list (comp-nuke-keys keys |
---|
| 770 | '((:displaced-to 0) |
---|
| 771 | (:fill-pointer 1) |
---|
| 772 | (:adjustable 2) |
---|
| 773 | (:displaced-index-offset 3)) |
---|
| 774 | call-list |
---|
| 775 | `((,dims-var ,dims))))) |
---|
| 776 | |
---|
| 777 | `(let ,let-list |
---|
[609] | 778 | (%make-displaced-array ,dims-var ,@call-list t)))) |
---|
[6] | 779 | |
---|
| 780 | (defun comp-make-uarray (dims keys subtype) |
---|
[1373] | 781 | (if (null keys) |
---|
| 782 | `(%make-simple-array ,subtype ,dims) |
---|
| 783 | (let* ((call-list (make-list 6)) |
---|
| 784 | (dims-var (make-symbol "DIMS")) |
---|
[10008] | 785 | (let-list (comp-nuke-keys keys |
---|
| 786 | '((:adjustable 0) |
---|
| 787 | (:fill-pointer 1) |
---|
| 788 | (:initial-element 2 3) |
---|
| 789 | (:initial-contents 4 5)) |
---|
| 790 | call-list |
---|
| 791 | `((,dims-var ,dims))))) |
---|
| 792 | `(let ,let-list |
---|
| 793 | (make-uarray-1 ,subtype ,dims-var ,@call-list nil nil))))) |
---|
[6] | 794 | |
---|
| 795 | (defun comp-make-array-1 (dims keys) |
---|
| 796 | (let* ((call-list (make-list 10 :initial-element nil)) |
---|
| 797 | (dims-var (make-symbol "DIMS")) |
---|
[9389] | 798 | (let-list (comp-nuke-keys keys |
---|
[6] | 799 | '((:element-type 0 1) |
---|
| 800 | (:displaced-to 2) |
---|
| 801 | (:displaced-index-offset 3) |
---|
| 802 | (:adjustable 4) |
---|
| 803 | (:fill-pointer 5) |
---|
| 804 | (:initial-element 6 7) |
---|
| 805 | (:initial-contents 8 9)) |
---|
| 806 | call-list |
---|
| 807 | `((,dims-var ,dims))))) |
---|
| 808 | `(let ,let-list |
---|
| 809 | (make-array-1 ,dims-var ,@call-list nil)))) |
---|
| 810 | |
---|
| 811 | (defun comp-nuke-keys (keys key-list call-list &optional required-bindings) |
---|
| 812 | ; side effects call list, returns a let-list |
---|
[10008] | 813 | (let* ((let-list (reverse required-bindings)) |
---|
| 814 | (seen nil)) |
---|
[6] | 815 | (do ((lst keys (cddr lst))) |
---|
| 816 | ((null lst) nil) |
---|
| 817 | (let* ((key (car lst)) |
---|
| 818 | (val (cadr lst)) |
---|
| 819 | (ass (assq key key-list)) |
---|
| 820 | (vpos (cadr ass)) |
---|
| 821 | (ppos (caddr ass))) |
---|
| 822 | (when ass |
---|
[10008] | 823 | (unless (memq vpos seen) |
---|
| 824 | (push vpos seen) |
---|
| 825 | (when (not (constantp val)) |
---|
| 826 | (let ((gen (gensym))) |
---|
| 827 | (setq let-list (cons (list gen val) let-list)) ; reverse him |
---|
| 828 | (setq val gen))) |
---|
| 829 | (rplaca (nthcdr vpos call-list) val) |
---|
| 830 | (if ppos (rplaca (nthcdr ppos call-list) t)))))) |
---|
[6] | 831 | (nreverse let-list))) |
---|
| 832 | |
---|
| 833 | (define-compiler-macro make-instance (&whole call class &rest initargs) |
---|
| 834 | (if (and (listp class) |
---|
| 835 | (eq (car class) 'quote) |
---|
| 836 | (symbolp (cadr class)) |
---|
| 837 | (null (cddr class))) |
---|
[7750] | 838 | (let* ((cell (gensym))) |
---|
| 839 | `(let* ((,cell (load-time-value (find-class-cell ,class t)))) |
---|
| 840 | (funcall (class-cell-instantiate ,cell) ,cell ,@initargs))) |
---|
[6] | 841 | call)) |
---|
| 842 | |
---|
| 843 | |
---|
| 844 | |
---|
| 845 | |
---|
| 846 | |
---|
| 847 | |
---|
[9389] | 848 | |
---|
[6] | 849 | (define-compiler-macro mapc (&whole call fn lst &rest more) |
---|
| 850 | (if more |
---|
| 851 | call |
---|
| 852 | (let* ((temp-var (gensym)) |
---|
| 853 | (elt-var (gensym)) |
---|
| 854 | (fn-var (gensym))) |
---|
| 855 | `(let* ((,fn-var ,fn) |
---|
| 856 | (,temp-var ,lst)) |
---|
| 857 | (dolist (,elt-var ,temp-var ,temp-var) |
---|
| 858 | (funcall ,fn-var ,elt-var)) |
---|
| 859 | )))) |
---|
| 860 | |
---|
| 861 | (define-compiler-macro mapcar (&whole call fn lst &rest more) |
---|
| 862 | (if more |
---|
| 863 | call |
---|
| 864 | (let* ((temp-var (gensym)) |
---|
| 865 | (result-var (gensym)) |
---|
| 866 | (elt-var (gensym)) |
---|
| 867 | (fn-var (gensym))) |
---|
| 868 | `(let* ((,temp-var (cons nil nil)) |
---|
| 869 | (,result-var ,temp-var) |
---|
| 870 | (,fn-var ,fn)) |
---|
| 871 | (declare (dynamic-extent ,temp-var) |
---|
| 872 | (type cons ,temp-var ,result-var)) |
---|
| 873 | (dolist (,elt-var ,lst (cdr ,result-var)) |
---|
| 874 | (setq ,temp-var (setf (cdr ,temp-var) (list (funcall ,fn-var ,elt-var))))))))) |
---|
| 875 | |
---|
[7624] | 876 | (define-compiler-macro member (&whole call item list &rest keys) |
---|
| 877 | (or (remove-explicit-test-keyword-from-test-testnot-key item list keys 'memeql '((eq . memq) (eql . memeql) (equal . memequal)) 'member-test) |
---|
[6] | 878 | call)) |
---|
| 879 | |
---|
[7624] | 880 | (define-compiler-macro memequal (&whole call &environment env item list) |
---|
| 881 | (if (or (equal-iff-eql-p item env) |
---|
| 882 | (and (quoted-form-p list) |
---|
| 883 | (proper-list-p (%cadr list)) |
---|
| 884 | (every (lambda (elt) (equal-iff-eql-p elt env)) (%cadr list)))) |
---|
| 885 | `(memeql ,item ,list) |
---|
| 886 | call)) |
---|
[9389] | 887 | |
---|
[7624] | 888 | (define-compiler-macro memeql (&whole call &environment env item list) |
---|
| 889 | (if (or (eql-iff-eq-p item env) |
---|
| 890 | (and (quoted-form-p list) |
---|
| 891 | (proper-list-p (%cadr list)) |
---|
| 892 | (every (lambda (elt) (eql-iff-eq-p elt env)) (%cadr list)))) |
---|
| 893 | `(memq ,item ,list) |
---|
| 894 | call)) |
---|
| 895 | |
---|
[6] | 896 | (define-compiler-macro memq (&whole call &environment env item list) |
---|
[7624] | 897 | ;;(memq x '(y)) => (if (eq x 'y) '(y)) |
---|
| 898 | ;;Would it be worth making a two elt list into an OR? Maybe if |
---|
| 899 | ;;optimizing for speed... |
---|
[6] | 900 | (if (and (or (quoted-form-p list) |
---|
| 901 | (null list)) |
---|
| 902 | (null (cdr (%cadr list)))) |
---|
| 903 | (if list `(if (eq ,item ',(%caadr list)) ,list)) |
---|
[7624] | 904 | (let* ((x (gensym)) |
---|
| 905 | (tail (gensym))) |
---|
| 906 | `(do* ((,x ,item) |
---|
| 907 | (,tail ,list (cdr (the list ,tail)))) |
---|
| 908 | ((null ,tail)) |
---|
| 909 | (if (eq (car ,tail) ,x) (return ,tail)))))) |
---|
[6] | 910 | |
---|
| 911 | (define-compiler-macro minusp (x) |
---|
| 912 | `(< ,x 0)) |
---|
| 913 | |
---|
| 914 | (define-compiler-macro notany (&whole call &environment env &rest ignore) |
---|
| 915 | (declare (ignore ignore)) |
---|
| 916 | (some-xx-transform call env)) |
---|
| 917 | |
---|
| 918 | (define-compiler-macro notevery (&whole call &environment env &rest ignore) |
---|
| 919 | (declare (ignore ignore)) |
---|
| 920 | (some-xx-transform call env)) |
---|
| 921 | |
---|
| 922 | (define-compiler-macro nth (&whole call &environment env count list) |
---|
| 923 | (if (and (fixnump count) |
---|
| 924 | (%i>= count 0) |
---|
| 925 | (%i< count 3)) |
---|
| 926 | `(,(svref '#(car cadr caddr) count) ,list) |
---|
[7624] | 927 | `(car (nthcdr ,count ,list)))) |
---|
[6] | 928 | |
---|
| 929 | (define-compiler-macro nthcdr (&whole call &environment env count list) |
---|
| 930 | (if (and (fixnump count) |
---|
| 931 | (%i>= count 0) |
---|
[9389] | 932 | (%i< count 4)) |
---|
[6] | 933 | (if (%izerop count) |
---|
[7624] | 934 | `(require-type ,list 'list) |
---|
[6] | 935 | `(,(svref '#(cdr cddr cdddr) (%i- count 1)) ,list)) |
---|
[7624] | 936 | (let* ((i (gensym)) |
---|
| 937 | (n (gensym)) ; evaluation order |
---|
| 938 | (tail (gensym))) |
---|
| 939 | `(let* ((,n (require-type ,count 'unsigned-byte)) |
---|
| 940 | (,tail (require-type ,list 'list))) |
---|
| 941 | (dotimes (,i ,n ,tail) |
---|
| 942 | (unless (setq ,tail (cdr ,tail)) |
---|
| 943 | (return nil))))))) |
---|
[6] | 944 | |
---|
| 945 | (define-compiler-macro plusp (x) |
---|
| 946 | `(> ,x 0)) |
---|
| 947 | |
---|
| 948 | (define-compiler-macro progn (&whole call &optional (first nil first-p) &rest rest) |
---|
| 949 | (if first-p |
---|
| 950 | (if rest call first))) |
---|
| 951 | |
---|
[1989] | 952 | ;;; This isn't quite right... The idea is that (car (require-type foo |
---|
| 953 | ;;; 'list)) ;can become just (<typechecking-car> foo) [regardless of |
---|
| 954 | ;;; optimize settings], ;but I don't think this can be done just with |
---|
| 955 | ;;; optimizers... For now, at least try to get it to become (%car |
---|
| 956 | ;;; (<typecheck> foo)). |
---|
[9245] | 957 | (define-compiler-macro require-type (&whole call &environment env arg type &aux ctype) |
---|
[8032] | 958 | (cond ((and (or (eq type t) |
---|
| 959 | (and (quoted-form-p type) |
---|
| 960 | (setq type (%cadr type)))) |
---|
[9338] | 961 | (setq ctype (specifier-type-if-known type env))) |
---|
[6] | 962 | (cond ((nx-form-typep arg type env) arg) |
---|
| 963 | ((eq type 'simple-vector) |
---|
| 964 | `(the simple-vector (require-simple-vector ,arg))) |
---|
| 965 | ((eq type 'simple-string) |
---|
| 966 | `(the simple-string (require-simple-string ,arg))) |
---|
| 967 | ((eq type 'integer) |
---|
| 968 | `(the integer (require-integer ,arg))) |
---|
| 969 | ((eq type 'fixnum) |
---|
| 970 | `(the fixnum (require-fixnum ,arg))) |
---|
| 971 | ((eq type 'real) |
---|
| 972 | `(the real (require-real ,arg))) |
---|
| 973 | ((eq type 'list) |
---|
| 974 | `(the list (require-list ,arg))) |
---|
| 975 | ((eq type 'character) |
---|
| 976 | `(the character (require-character ,arg))) |
---|
| 977 | ((eq type 'number) |
---|
| 978 | `(the number (require-number ,arg))) |
---|
| 979 | ((eq type 'symbol) |
---|
| 980 | `(the symbol (require-symbol ,arg))) |
---|
[9245] | 981 | ((type= ctype |
---|
[5217] | 982 | (specifier-type '(signed-byte 8))) |
---|
[9389] | 983 | `(the (signed-byte 8) (require-s8 ,arg))) |
---|
[9245] | 984 | ((type= ctype |
---|
[5217] | 985 | (specifier-type '(unsigned-byte 8))) |
---|
| 986 | `(the (unsigned-byte 8) (require-u8 ,arg))) |
---|
[9245] | 987 | ((type= ctype |
---|
[5217] | 988 | (specifier-type '(signed-byte 16))) |
---|
| 989 | `(the (signed-byte 16) (require-s16 ,arg))) |
---|
[9245] | 990 | ((type= ctype |
---|
[5217] | 991 | (specifier-type '(unsigned-byte 16))) |
---|
[9389] | 992 | `(the (unsigned-byte 16) (require-u16 ,arg))) |
---|
[9245] | 993 | ((type= ctype |
---|
[5217] | 994 | (specifier-type '(signed-byte 32))) |
---|
| 995 | `(the (signed-byte 32) (require-s32 ,arg))) |
---|
[9245] | 996 | ((type= ctype |
---|
[5217] | 997 | (specifier-type '(unsigned-byte 32))) |
---|
| 998 | `(the (unsigned-byte 32) (require-u32 ,arg))) |
---|
[9245] | 999 | ((type= ctype |
---|
[5217] | 1000 | (specifier-type '(signed-byte 64))) |
---|
| 1001 | `(the (signed-byte 64) (require-s64 ,arg))) |
---|
[9245] | 1002 | ((type= ctype |
---|
[5217] | 1003 | (specifier-type '(unsigned-byte 64))) |
---|
[8032] | 1004 | `(the (unsigned-byte 64) (require-u64 ,arg))) |
---|
| 1005 | #+nil |
---|
[6] | 1006 | ((and (symbolp type) |
---|
| 1007 | (let ((simpler (type-predicate type))) |
---|
| 1008 | (if simpler `(the ,type (%require-type ,arg ',simpler)))))) |
---|
[8032] | 1009 | #+nil |
---|
[6] | 1010 | ((and (symbolp type)(find-class type nil env)) |
---|
| 1011 | `(%require-type-class-cell ,arg (load-time-value (find-class-cell ',type t)))) |
---|
[7940] | 1012 | (t (let* ((val (gensym))) |
---|
| 1013 | `(let* ((,val ,arg)) |
---|
| 1014 | (if (typep ,val ',type) |
---|
| 1015 | ,val |
---|
| 1016 | (%kernel-restart $xwrongtype ,val ',type))))))) |
---|
[6] | 1017 | (t call))) |
---|
| 1018 | |
---|
| 1019 | (define-compiler-macro proclaim (&whole call decl) |
---|
| 1020 | (if (and (quoted-form-p decl) |
---|
| 1021 | (eq (car (setq decl (%cadr decl))) 'special)) |
---|
| 1022 | (do ((vars (%cdr decl) (%cdr vars)) (decls ())) |
---|
| 1023 | ((null vars) |
---|
| 1024 | (cons 'progn (nreverse decls))) |
---|
| 1025 | (unless (and (car vars) |
---|
| 1026 | (neq (%car vars) t) |
---|
| 1027 | (symbolp (%car vars))) |
---|
| 1028 | (return call)) |
---|
| 1029 | (push (list '%proclaim-special (list 'quote (%car vars))) decls)) |
---|
| 1030 | call)) |
---|
| 1031 | |
---|
| 1032 | |
---|
| 1033 | (define-compiler-macro some (&whole call &environment env &rest ignore) |
---|
| 1034 | (declare (ignore ignore)) |
---|
| 1035 | (some-xx-transform call env)) |
---|
| 1036 | |
---|
| 1037 | (define-compiler-macro struct-ref (&whole call &environment env struct offset) |
---|
| 1038 | (if (nx-inhibit-safety-checking env) |
---|
| 1039 | `(%svref ,struct ,offset) |
---|
| 1040 | call)) |
---|
| 1041 | |
---|
| 1042 | ;;; expand find-if and find-if-not |
---|
| 1043 | |
---|
| 1044 | (define-compiler-macro find-if (&whole call &environment env |
---|
| 1045 | test sequence &rest keys) |
---|
| 1046 | `(find ,test ,sequence |
---|
| 1047 | :test #'funcall |
---|
| 1048 | ,@keys)) |
---|
| 1049 | |
---|
| 1050 | (define-compiler-macro find-if-not (&whole call &environment env |
---|
| 1051 | test sequence &rest keys) |
---|
| 1052 | `(find ,test ,sequence |
---|
| 1053 | :test-not #'funcall |
---|
| 1054 | ,@keys)) |
---|
| 1055 | |
---|
| 1056 | ;;; inline some cases, and use a positional function in others |
---|
| 1057 | |
---|
| 1058 | (define-compiler-macro find (&whole call &environment env |
---|
| 1059 | item sequence &rest keys) |
---|
| 1060 | (if (constant-keywords-p keys) |
---|
| 1061 | (destructuring-bind (&key from-end test test-not (start 0) end key) keys |
---|
| 1062 | (if (and (eql start 0) |
---|
| 1063 | (null end) |
---|
| 1064 | (null from-end) |
---|
| 1065 | (not (and test test-not))) |
---|
| 1066 | (let ((find-test (or test test-not '#'eql)) |
---|
| 1067 | (loop-test (if test-not 'unless 'when)) |
---|
| 1068 | (loop-function (nx-form-sequence-iterator sequence env))) |
---|
| 1069 | (if loop-function |
---|
| 1070 | (let ((item-var (unless (or (constantp item) |
---|
| 1071 | (and (equal find-test '#'funcall) |
---|
| 1072 | (function-form-p item))) |
---|
| 1073 | (gensym))) |
---|
| 1074 | (elt-var (gensym))) |
---|
| 1075 | `(let (,@(when item-var `((,item-var ,item)))) |
---|
| 1076 | (,loop-function (,elt-var ,sequence) |
---|
| 1077 | (,loop-test (funcall ,find-test ,(or item-var item) |
---|
| 1078 | (funcall ,(or key '#'identity) ,elt-var)) |
---|
| 1079 | (return ,elt-var))))) |
---|
| 1080 | (let ((find-function (if test-not 'find-positional-test-not-key 'find-positional-test-key)) |
---|
| 1081 | (item-var (gensym)) |
---|
| 1082 | (sequence-var (gensym)) |
---|
| 1083 | (test-var (gensym)) |
---|
| 1084 | (key-var (gensym))) |
---|
| 1085 | `(let ((,item-var ,item) |
---|
| 1086 | (,sequence-var ,sequence) |
---|
| 1087 | (,test-var ,(or test test-not)) |
---|
| 1088 | (,key-var ,key)) |
---|
| 1089 | (declare (dynamic-extent ,item-var ,sequence-var ,test-var ,key-var)) |
---|
| 1090 | (,find-function ,item-var ,sequence-var ,test-var ,key-var))))) |
---|
| 1091 | call)) |
---|
| 1092 | call)) |
---|
| 1093 | |
---|
| 1094 | ;;; expand position-if and position-if-not |
---|
| 1095 | |
---|
| 1096 | (define-compiler-macro position-if (&whole call &environment env |
---|
| 1097 | test sequence &rest keys) |
---|
| 1098 | `(position ,test ,sequence |
---|
| 1099 | :test #'funcall |
---|
| 1100 | ,@keys)) |
---|
| 1101 | |
---|
| 1102 | (define-compiler-macro position-if-not (&whole call &environment env |
---|
| 1103 | test sequence &rest keys) |
---|
| 1104 | `(position ,test ,sequence |
---|
| 1105 | :test-not #'funcall |
---|
| 1106 | ,@keys)) |
---|
| 1107 | |
---|
| 1108 | ;;; inline some cases, and use positional functions for others |
---|
| 1109 | |
---|
| 1110 | (define-compiler-macro position (&whole call &environment env |
---|
| 1111 | item sequence &rest keys) |
---|
| 1112 | (if (constant-keywords-p keys) |
---|
| 1113 | (destructuring-bind (&key from-end test test-not (start 0) end key) keys |
---|
| 1114 | (if (and (eql start 0) |
---|
| 1115 | (null end) |
---|
| 1116 | (null from-end) |
---|
| 1117 | (not (and test test-not))) |
---|
| 1118 | (let ((position-test (or test test-not '#'eql)) |
---|
| 1119 | (loop-test (if test-not 'unless 'when)) |
---|
| 1120 | (sequence-value (if (constantp sequence) |
---|
| 1121 | (eval-constant sequence) |
---|
| 1122 | sequence))) |
---|
| 1123 | (cond ((nx-form-typep sequence-value 'list env) |
---|
| 1124 | (let ((item-var (unless (or (constantp item) |
---|
| 1125 | (and (equal position-test '#'funcall) |
---|
| 1126 | (function-form-p item))) |
---|
| 1127 | (gensym))) |
---|
| 1128 | (elt-var (gensym)) |
---|
| 1129 | (position-var (gensym))) |
---|
| 1130 | `(let (,@(when item-var `((,item-var ,item))) |
---|
| 1131 | (,position-var 0)) |
---|
| 1132 | (dolist (,elt-var ,sequence) |
---|
| 1133 | (,loop-test (funcall ,position-test ,(or item-var item) |
---|
| 1134 | (funcall ,(or key '#'identity) ,elt-var)) |
---|
| 1135 | (return ,position-var)) |
---|
| 1136 | (incf ,position-var))))) |
---|
| 1137 | ((nx-form-typep sequence-value 'vector env) |
---|
| 1138 | (let ((item-var (unless (or (constantp item) |
---|
| 1139 | (and (equal position-test '#'funcall) |
---|
| 1140 | (function-form-p item))) |
---|
| 1141 | (gensym))) |
---|
| 1142 | (sequence-var (gensym)) |
---|
| 1143 | (position-var (gensym))) |
---|
| 1144 | `(let (,@(when item-var `((,item-var ,item))) |
---|
| 1145 | (,sequence-var ,sequence)) |
---|
| 1146 | ,@(let ((type (nx-form-type sequence env))) |
---|
| 1147 | (unless (eq type t) |
---|
| 1148 | `((declare (type ,type ,sequence-var))))) |
---|
| 1149 | (dotimes (,position-var (length ,sequence-var)) |
---|
| 1150 | (,loop-test (funcall ,position-test ,(or item-var item) |
---|
| 1151 | (funcall ,(or key '#'identity) |
---|
| 1152 | (locally (declare (optimize (speed 3) (safety 0))) |
---|
| 1153 | (aref ,sequence ,position-var)))) |
---|
| 1154 | (return ,position-var)))))) |
---|
| 1155 | (t |
---|
| 1156 | (let ((position-function (if test-not |
---|
| 1157 | 'position-positional-test-not-key |
---|
| 1158 | 'position-positional-test-key)) |
---|
| 1159 | (item-var (gensym)) |
---|
| 1160 | (sequence-var (gensym)) |
---|
| 1161 | (test-var (gensym)) |
---|
| 1162 | (key-var (gensym))) |
---|
| 1163 | `(let ((,item-var ,item) |
---|
| 1164 | (,sequence-var ,sequence) |
---|
| 1165 | (,test-var ,(or test test-not)) |
---|
| 1166 | (,key-var ,key)) |
---|
| 1167 | (declare (dynamic-extent ,sequence-var ,test-var ,key-var)) |
---|
| 1168 | (,position-function ,item-var ,sequence-var ,test-var ,key-var)))))) |
---|
| 1169 | call)) |
---|
| 1170 | call)) |
---|
| 1171 | |
---|
| 1172 | ;;; inline some cases of remove-if and remove-if-not |
---|
| 1173 | |
---|
| 1174 | (define-compiler-macro remove-if (&whole call &environment env &rest ignore) |
---|
| 1175 | (declare (ignore ignore)) |
---|
| 1176 | (remove-if-transform call env)) |
---|
| 1177 | |
---|
| 1178 | (define-compiler-macro remove-if-not (&whole call &environment env &rest ignore) |
---|
| 1179 | (declare (ignore ignore)) |
---|
| 1180 | (remove-if-transform call env)) |
---|
| 1181 | |
---|
| 1182 | (defun remove-if-transform (call env) |
---|
| 1183 | (destructuring-bind (function test sequence &rest keys) call |
---|
| 1184 | (if (constant-keywords-p keys) |
---|
| 1185 | (destructuring-bind (&key from-end (start 0) end count (key '#'identity)) keys |
---|
| 1186 | (if (and (eql start 0) |
---|
| 1187 | (null end) |
---|
| 1188 | (null from-end) |
---|
| 1189 | (null count) |
---|
| 1190 | (nx-form-typep sequence 'list env)) |
---|
| 1191 | ;; only do the list case, since it's hard to collect vector results |
---|
| 1192 | (let ((temp-var (gensym)) |
---|
| 1193 | (result-var (gensym)) |
---|
| 1194 | (elt-var (gensym)) |
---|
| 1195 | (loop-test (ecase function (remove-if 'unless) (remove-if-not 'when)))) |
---|
| 1196 | `(the list |
---|
| 1197 | (let* ((,temp-var (cons nil nil)) |
---|
| 1198 | (,result-var ,temp-var)) |
---|
| 1199 | (declare (dynamic-extent ,temp-var)) |
---|
| 1200 | (dolist (,elt-var ,sequence (%cdr ,result-var)) |
---|
| 1201 | (,loop-test (funcall ,test (funcall ,key ,elt-var)) |
---|
[9389] | 1202 | (setq ,temp-var |
---|
| 1203 | (%cdr |
---|
[6] | 1204 | (%rplacd ,temp-var (list ,elt-var))))))))) |
---|
| 1205 | call)) |
---|
| 1206 | call))) |
---|
| 1207 | |
---|
| 1208 | |
---|
| 1209 | |
---|
| 1210 | (define-compiler-macro struct-set (&whole call &environment env struct offset new) |
---|
| 1211 | (if (nx-inhibit-safety-checking env) |
---|
| 1212 | `(%svset ,struct ,offset ,new) |
---|
| 1213 | call)) |
---|
| 1214 | |
---|
| 1215 | (define-compiler-macro zerop (arg &environment env) |
---|
| 1216 | (let* ((z (if (nx-form-typep arg 'float env) |
---|
| 1217 | (coerce 0 (nx-form-type arg env)) |
---|
| 1218 | 0))) |
---|
| 1219 | `(= ,arg ,z))) |
---|
| 1220 | |
---|
| 1221 | |
---|
| 1222 | (define-compiler-macro = (&whole w n0 &optional (n1 nil n1p) &rest more) |
---|
| 1223 | (if (not n1p) |
---|
| 1224 | `(require-type ,n0 'number) |
---|
| 1225 | (if more |
---|
| 1226 | w |
---|
| 1227 | `(=-2 ,n0 ,n1)))) |
---|
| 1228 | |
---|
| 1229 | (define-compiler-macro /= (&whole w n0 &optional (n1 nil n1p) &rest more) |
---|
| 1230 | (if (not n1p) |
---|
| 1231 | `(require-type ,n0 'number) |
---|
| 1232 | (if more |
---|
| 1233 | w |
---|
| 1234 | `(/=-2 ,n0 ,n1)))) |
---|
| 1235 | |
---|
| 1236 | (define-compiler-macro + (&whole w &environment env &optional (n0 nil n0p) (n1 nil n1p) &rest more) |
---|
| 1237 | (if more |
---|
[1733] | 1238 | `(+ (+-2 ,n0 ,n1) ,@more) |
---|
[6] | 1239 | (if n1p |
---|
| 1240 | `(+-2 ,n0 ,n1) |
---|
| 1241 | (if n0p |
---|
| 1242 | `(require-type ,n0 'number) |
---|
| 1243 | 0)))) |
---|
| 1244 | |
---|
| 1245 | (define-compiler-macro - (&whole w &environment env n0 &optional (n1 nil n1p) &rest more) |
---|
| 1246 | (if more |
---|
[1733] | 1247 | `(- (--2 ,n0 ,n1) ,@more) |
---|
[6] | 1248 | (if n1p |
---|
| 1249 | `(--2 ,n0 ,n1) |
---|
| 1250 | `(%negate ,n0)))) |
---|
| 1251 | |
---|
| 1252 | (define-compiler-macro * (&whole w &environment env &optional (n0 nil n0p) (n1 nil n1p) &rest more) |
---|
| 1253 | (if more |
---|
| 1254 | (let ((type (nx-form-type w env))) |
---|
| 1255 | (if (and type (numeric-type-p type)) ; go pairwise if type known, else not |
---|
| 1256 | `(*-2 ,n0 (* ,n1 ,@more)) |
---|
| 1257 | w)) |
---|
| 1258 | (if n1p |
---|
| 1259 | `(*-2 ,n0 ,n1) |
---|
| 1260 | (if n0p |
---|
| 1261 | `(require-type ,n0 'number) |
---|
| 1262 | 1)))) |
---|
| 1263 | |
---|
| 1264 | (define-compiler-macro / (&whole w n0 &optional (n1 nil n1p) &rest more) |
---|
| 1265 | (if more |
---|
| 1266 | w |
---|
| 1267 | (if n1p |
---|
| 1268 | `(/-2 ,n0 ,n1) |
---|
| 1269 | `(%quo-1 ,n0)))) |
---|
| 1270 | |
---|
[1989] | 1271 | ;;; beware of limits - truncate of most-negative-fixnum & -1 ain't a |
---|
| 1272 | ;;; fixnum - too bad |
---|
[6] | 1273 | (define-compiler-macro truncate (&whole w &environment env n0 &optional (n1 nil n1p)) |
---|
| 1274 | (let ((*nx-form-type* t)) |
---|
| 1275 | (if (nx-form-typep n0 'fixnum env) |
---|
| 1276 | (if (not n1p) |
---|
| 1277 | n0 |
---|
| 1278 | (if (nx-form-typep n1 'fixnum env) |
---|
| 1279 | `(%fixnum-truncate ,n0 ,n1) |
---|
| 1280 | w)) |
---|
| 1281 | w))) |
---|
| 1282 | |
---|
| 1283 | (define-compiler-macro floor (&whole w &environment env n0 &optional (n1 nil n1p)) |
---|
| 1284 | (let ((*nx-form-type* t)) |
---|
| 1285 | (if (nx-form-typep n0 'fixnum env) |
---|
| 1286 | (if (not n1p) |
---|
| 1287 | n0 |
---|
| 1288 | (if (nx-form-typep n1 'fixnum env) |
---|
| 1289 | `(%fixnum-floor ,n0 ,n1) |
---|
| 1290 | w)) |
---|
| 1291 | w))) |
---|
| 1292 | |
---|
| 1293 | (define-compiler-macro round (&whole w &environment env n0 &optional (n1 nil n1p)) |
---|
| 1294 | (let ((*nx-form-type* t)) ; it doesn't matter what the result type is declared to be |
---|
| 1295 | (if (nx-form-typep n0 'fixnum env) |
---|
| 1296 | (if (not n1p) |
---|
| 1297 | n0 |
---|
| 1298 | (if (nx-form-typep n1 'fixnum env) |
---|
| 1299 | `(%fixnum-round ,n0 ,n1) |
---|
| 1300 | w)) |
---|
| 1301 | w))) |
---|
| 1302 | |
---|
| 1303 | (define-compiler-macro ceiling (&whole w &environment env n0 &optional (n1 nil n1p)) |
---|
| 1304 | (let ((*nx-form-type* t)) |
---|
| 1305 | (if (nx-form-typep n0 'fixnum env) |
---|
| 1306 | (if (not n1p) |
---|
| 1307 | n0 |
---|
| 1308 | (if (nx-form-typep n1 'fixnum env) |
---|
| 1309 | `(%fixnum-ceiling ,n0 ,n1) |
---|
| 1310 | w)) |
---|
| 1311 | w))) |
---|
| 1312 | |
---|
| 1313 | (define-compiler-macro oddp (&whole w &environment env n0) |
---|
| 1314 | (if (nx-form-typep n0 'fixnum env) |
---|
| 1315 | `(logbitp 0 (the fixnum ,n0)) |
---|
| 1316 | w)) |
---|
| 1317 | |
---|
| 1318 | (define-compiler-macro evenp (&whole w &environment env n0) |
---|
| 1319 | (if (nx-form-typep n0 'fixnum env) |
---|
| 1320 | `(not (logbitp 0 (the fixnum ,n0))) |
---|
| 1321 | w)) |
---|
| 1322 | |
---|
[9389] | 1323 | |
---|
[6] | 1324 | (define-compiler-macro logandc2 (n0 n1) |
---|
| 1325 | (let ((n1var (gensym)) |
---|
| 1326 | (n0var (gensym))) |
---|
| 1327 | `(let ((,n0var ,n0) |
---|
| 1328 | (,n1var ,n1)) |
---|
| 1329 | (logandc1 ,n1var ,n0var)))) |
---|
| 1330 | |
---|
| 1331 | (define-compiler-macro logorc2 (n0 n1) |
---|
| 1332 | (let ((n1var (gensym)) |
---|
| 1333 | (n0var (gensym))) |
---|
| 1334 | `(let ((,n0var ,n0) |
---|
| 1335 | (,n1var ,n1)) |
---|
| 1336 | (logorc1 ,n1var ,n0var)))) |
---|
| 1337 | |
---|
| 1338 | (define-compiler-macro lognand (n0 n1) |
---|
| 1339 | `(lognot (logand ,n0 ,n1))) |
---|
| 1340 | |
---|
| 1341 | (define-compiler-macro lognor (n0 n1) |
---|
| 1342 | `(lognot (logior ,n0 ,n1))) |
---|
| 1343 | |
---|
| 1344 | |
---|
[1907] | 1345 | (defun transform-logop (whole identity binop &optional (transform-complement t)) |
---|
[6] | 1346 | (destructuring-bind (op &optional (n0 nil n0p) (n1 nil n1p) &rest more) whole |
---|
| 1347 | (if (and n1p (eql n0 identity)) |
---|
| 1348 | `(,op ,n1 ,@more) |
---|
[1907] | 1349 | (if (and transform-complement n1p (eql n0 (lognot identity))) |
---|
[6] | 1350 | `(progn |
---|
| 1351 | (,op ,n1 ,@more) |
---|
| 1352 | ,(lognot identity)) |
---|
| 1353 | (if more |
---|
| 1354 | (if (cdr more) |
---|
| 1355 | whole |
---|
| 1356 | `(,binop ,n0 (,binop ,n1 ,(car more)))) |
---|
| 1357 | (if n1p |
---|
| 1358 | `(,binop ,n0 ,n1) |
---|
| 1359 | (if n0p |
---|
| 1360 | `(require-type ,n0 'integer) |
---|
| 1361 | identity))))))) |
---|
[9389] | 1362 | |
---|
[6] | 1363 | (define-compiler-macro logand (&whole w &rest all) |
---|
| 1364 | (declare (ignore all)) |
---|
| 1365 | (transform-logop w -1 'logand-2)) |
---|
| 1366 | |
---|
| 1367 | (define-compiler-macro logior (&whole w &rest all) |
---|
| 1368 | (declare (ignore all)) |
---|
| 1369 | (transform-logop w 0 'logior-2)) |
---|
| 1370 | |
---|
| 1371 | (define-compiler-macro logxor (&whole w &rest all) |
---|
| 1372 | (declare (ignore all)) |
---|
[1907] | 1373 | (transform-logop w 0 'logxor-2 nil)) |
---|
[6] | 1374 | |
---|
| 1375 | (define-compiler-macro lognot (&whole w &environment env n1) |
---|
| 1376 | (if (nx-form-typep n1 'fixnum env) |
---|
| 1377 | `(%ilognot ,n1) |
---|
| 1378 | w)) |
---|
| 1379 | |
---|
| 1380 | (define-compiler-macro logtest (&whole w &environment env n1 n2) |
---|
| 1381 | (if (and (nx-form-typep n1 'fixnum env) |
---|
| 1382 | (nx-form-typep n2 'fixnum env)) |
---|
| 1383 | `(not (eql 0 (logand ,n1 ,n2))) |
---|
| 1384 | w)) |
---|
| 1385 | |
---|
[9389] | 1386 | |
---|
[6] | 1387 | (defmacro defsynonym (from to) |
---|
| 1388 | ;Should maybe check for circularities. |
---|
| 1389 | `(progn |
---|
| 1390 | (setf (compiler-macro-function ',from) nil) |
---|
| 1391 | (let ((pair (assq ',from *nx-synonyms*))) |
---|
[9389] | 1392 | (if pair (rplacd pair ',to) |
---|
| 1393 | (push (cons ',from ',to) |
---|
[6] | 1394 | *nx-synonyms*)) |
---|
| 1395 | ',to))) |
---|
| 1396 | |
---|
| 1397 | (defsynonym first car) |
---|
| 1398 | (defsynonym second cadr) |
---|
| 1399 | (defsynonym third caddr) |
---|
| 1400 | (defsynonym fourth cadddr) |
---|
| 1401 | (defsynonym rest cdr) |
---|
| 1402 | |
---|
| 1403 | |
---|
| 1404 | (defsynonym functionp lfunp) |
---|
| 1405 | (defsynonym null not) |
---|
| 1406 | (defsynonym char-int char-code) |
---|
| 1407 | |
---|
| 1408 | ;;; Improvemets file by Bob Cassels |
---|
| 1409 | ;;; Just what are "Improvemets", anyway ? |
---|
| 1410 | |
---|
[1989] | 1411 | ;;; Optimize some CL sequence functions, mostly by inlining them in |
---|
| 1412 | ;;; simple cases when the type of the sequence is known. In some |
---|
| 1413 | ;;; cases, dynamic-extent declarations are automatically inserted. |
---|
| 1414 | ;;; For some sequence functions, if the type of the sequence is known |
---|
| 1415 | ;;; at compile time, the function is inlined. If the type isn't known |
---|
| 1416 | ;;; but the call is "simple", a call to a faster (positional-arg) |
---|
[6] | 1417 | ;;; function is substituted. |
---|
| 1418 | |
---|
| 1419 | |
---|
| 1420 | (defun nx-form-sequence-iterator (sequence-form env) |
---|
| 1421 | (cond ((nx-form-typep sequence-form 'vector env) 'dovector) |
---|
| 1422 | ((nx-form-typep sequence-form 'list env) 'dolist))) |
---|
| 1423 | |
---|
| 1424 | (defun function-form-p (form) |
---|
| 1425 | ;; c.f. quoted-form-p |
---|
| 1426 | (and (consp form) |
---|
| 1427 | (eq (%car form) 'function) |
---|
| 1428 | (consp (%cdr form)) |
---|
| 1429 | (null (%cdr (%cdr form))))) |
---|
| 1430 | |
---|
[7940] | 1431 | |
---|
| 1432 | ;; Return a form that checks to see if THING is if type CTYPE, or |
---|
| 1433 | ;; NIL if we can't do that for some reason. |
---|
| 1434 | (defun optimize-ctypep (thing ctype) |
---|
| 1435 | (when (eq *target-backend* *host-backend*) |
---|
| 1436 | (typecase ctype |
---|
| 1437 | (numeric-ctype |
---|
| 1438 | (cond ((eq :real (numeric-ctype-complexp ctype)) |
---|
| 1439 | (let* ((low (numeric-ctype-low ctype)) |
---|
| 1440 | (high (numeric-ctype-high ctype)) |
---|
| 1441 | (class (numeric-ctype-class ctype)) |
---|
| 1442 | (format (numeric-ctype-format ctype)) |
---|
| 1443 | (type (if (eq class 'float) |
---|
| 1444 | (or format class) |
---|
[8970] | 1445 | (or class 'real)))) |
---|
[7940] | 1446 | (cond ((and low (eql low high) (or (not (eq class 'float)) |
---|
| 1447 | format)) |
---|
| 1448 | `(eql ,thing ,low)) |
---|
| 1449 | ((and (eq type 'float) |
---|
| 1450 | (or low high) |
---|
| 1451 | (or (null low) |
---|
| 1452 | (typep low 'single-float) |
---|
| 1453 | (not (null (ignore-errors |
---|
| 1454 | (coerce (if (atom low) |
---|
| 1455 | low |
---|
| 1456 | (car low)) |
---|
| 1457 | 'single-float))))) |
---|
| 1458 | (or (null high) |
---|
| 1459 | (typep high 'single-float) |
---|
| 1460 | (not (null (ignore-errors |
---|
| 1461 | (coerce (if (atom high) |
---|
| 1462 | high |
---|
| 1463 | (car high)) |
---|
| 1464 | 'single-float)))))) |
---|
| 1465 | (let* ((temp (gensym))) |
---|
| 1466 | (flet ((bounded-float (type low high) |
---|
| 1467 | `(,type |
---|
| 1468 | ,(if low |
---|
| 1469 | (if (listp low) |
---|
| 1470 | (list (coerce (car low) type)) |
---|
| 1471 | (coerce low type)) |
---|
| 1472 | '*) |
---|
| 1473 | ,(if high |
---|
| 1474 | (if (listp high) |
---|
| 1475 | (list (coerce (car high) type)) |
---|
| 1476 | (coerce high type)) |
---|
| 1477 | '*)))) |
---|
| 1478 | `(let* ((,temp ,thing)) |
---|
| 1479 | (or (typep ,temp ',(bounded-float 'single-float low high)) |
---|
| 1480 | (typep ,temp ',(bounded-float 'double-float low high))))))) |
---|
| 1481 | (t |
---|
| 1482 | (let* ((temp (gensym))) |
---|
[8970] | 1483 | (if (and (typep low 'fixnum) (typep high 'fixnum) |
---|
| 1484 | (eq class 'integer)) |
---|
[7940] | 1485 | (setq type 'fixnum)) |
---|
| 1486 | (if (or low high) |
---|
| 1487 | `(let* ((,temp ,thing)) |
---|
| 1488 | (and (typep ,temp ',type) |
---|
| 1489 | ,@(if low `((,(if (consp low) '> '>=) (the ,type ,temp) ,(if (consp low) (car low) low)))) |
---|
| 1490 | ,@(if high `((,(if (consp high) '< '<=) (the ,type ,temp) ,(if (consp high) (car high) high)))))) |
---|
| 1491 | `(typep ,thing ',type))))))) |
---|
| 1492 | (t `(numeric-%%typep ,thing ,ctype)))) |
---|
| 1493 | (array-ctype |
---|
| 1494 | (or |
---|
| 1495 | (let* ((typecode (array-ctype-typecode ctype)) |
---|
| 1496 | (dims (array-ctype-dimensions ctype))) |
---|
| 1497 | (cond ((and typecode (consp dims) (null (cdr dims))) |
---|
| 1498 | (case (array-ctype-complexp ctype) |
---|
| 1499 | ((nil) |
---|
| 1500 | (if (eq (car dims) '*) |
---|
| 1501 | `(eql (typecode ,thing) ,typecode) |
---|
| 1502 | (let* ((temp (gensym))) |
---|
| 1503 | `(let* ((,temp ,thing)) |
---|
| 1504 | (and (eql (typecode ,temp) ,typecode) |
---|
| 1505 | (eq (uvsize ,temp) ,(car dims))))))) |
---|
| 1506 | ((* :maybe) |
---|
| 1507 | (let* ((temp (gensym)) |
---|
| 1508 | (tempcode (gensym))) |
---|
| 1509 | `(let* ((,temp ,thing) |
---|
| 1510 | (,tempcode (typecode ,temp))) |
---|
| 1511 | (or (and (eql ,tempcode ,typecode) |
---|
| 1512 | ,@(unless (eq (car dims) '*) |
---|
[7961] | 1513 | `((eq (uvsize ,temp) ,(car dims))))) |
---|
[7940] | 1514 | (and (eql ,tempcode target::subtag-vectorH) |
---|
| 1515 | (eql (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref ,temp target::arrayH.flags-cell))) ,typecode) |
---|
| 1516 | ,@(unless (eq (car dims) '*) |
---|
| 1517 | `((eq (%svref ,temp target::vectorH.logsize-cell) ,(car dims))))))))))))) |
---|
[10008] | 1518 | `(values (array-%%typep ,thing ,ctype))))))) |
---|
[7940] | 1519 | |
---|
[9389] | 1520 | |
---|
| 1521 | |
---|
[6] | 1522 | (defun optimize-typep (thing type env) |
---|
| 1523 | ;; returns a new form, or nil if it can't optimize |
---|
[9338] | 1524 | (let* ((ctype (specifier-type-if-known type env))) |
---|
[9245] | 1525 | (when ctype |
---|
[7940] | 1526 | (let* ((type (type-specifier ctype)) |
---|
| 1527 | (predicate (if (typep type 'symbol) (type-predicate type)))) |
---|
| 1528 | (if (and predicate (symbolp predicate)) |
---|
| 1529 | `(,predicate ,thing) |
---|
[9938] | 1530 | (let* ((pair (assq type *istruct-cells*)) |
---|
| 1531 | (class (and pair (%wrapper-class (istruct-cell-info pair))))) |
---|
| 1532 | (if (and class (not (%class-direct-subclasses class))) |
---|
| 1533 | `(istruct-typep ,thing ',type) |
---|
| 1534 | (or (optimize-ctypep thing ctype) |
---|
| 1535 | (cond ((symbolp type) |
---|
| 1536 | (cond ((%deftype-expander type) |
---|
| 1537 | ;; recurse here, rather than returning the |
---|
| 1538 | ;; partially-expanded form mostly since it doesn't |
---|
| 1539 | ;; seem to further optimize the result otherwise |
---|
| 1540 | (let ((expanded-type (type-expand type))) |
---|
| 1541 | (or (optimize-typep thing expanded-type env) |
---|
| 1542 | ;; at least do the first expansion |
---|
| 1543 | `(typep ,thing ',expanded-type)))) |
---|
| 1544 | ((structure-class-p type env) |
---|
| 1545 | `(structure-typep ,thing ',(find-class-cell type t))) |
---|
| 1546 | ((find-class type nil env) |
---|
| 1547 | (let* ((class (find-class type nil nil)) |
---|
| 1548 | (fname |
---|
| 1549 | (if (or (null class) |
---|
| 1550 | (and (subtypep class 'standard-object) |
---|
| 1551 | (not (subtypep class 'foreign-standard-object)))) |
---|
| 1552 | 'std-instance-class-cell-typep |
---|
| 1553 | 'class-cell-typep))) |
---|
| 1554 | `(,fname ,thing (load-time-value (find-class-cell ',type t))))) |
---|
| 1555 | ((info-type-builtin type) ; bootstrap troubles here? |
---|
| 1556 | `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type)))) |
---|
| 1557 | (t nil))) |
---|
| 1558 | ((consp type) |
---|
| 1559 | (cond |
---|
| 1560 | ((info-type-builtin type) ; byte types |
---|
[7940] | 1561 | `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type)))) |
---|
[9938] | 1562 | (t |
---|
| 1563 | (case (%car type) |
---|
| 1564 | (satisfies `(funcall ',(cadr type) ,thing)) |
---|
| 1565 | (eql `(eql ,thing ',(cadr type))) |
---|
| 1566 | (member `(not (null (member ,thing ',(%cdr type))))) |
---|
| 1567 | (not `(not (typep ,thing ',(cadr type)))) |
---|
| 1568 | ((or and) |
---|
| 1569 | (let ((thing-sym (gensym))) |
---|
| 1570 | `(let ((,thing-sym ,thing)) |
---|
| 1571 | (,(%car type) |
---|
| 1572 | ,@(mapcar #'(lambda (type-spec) |
---|
| 1573 | (or (optimize-typep thing-sym type-spec env) |
---|
| 1574 | `(typep ,thing-sym ',type-spec))) |
---|
| 1575 | (%cdr type)))))) |
---|
| 1576 | ((signed-byte unsigned-byte integer mod) ; more byte types |
---|
| 1577 | `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type)))) |
---|
| 1578 | (t nil))))) |
---|
| 1579 | (t nil)))))))))) |
---|
[6] | 1580 | |
---|
| 1581 | (define-compiler-macro typep (&whole call &environment env thing type &optional e) |
---|
| 1582 | (if (quoted-form-p type) |
---|
[9338] | 1583 | (if (and (constantp thing) (specifier-type-if-known type env)) |
---|
[9360] | 1584 | (typep (if (quoted-form-p thing) (%cadr thing) thing) (%cadr type) env) |
---|
| 1585 | (or (and (null e) (optimize-typep thing (%cadr type) env)) |
---|
[8032] | 1586 | call)) |
---|
[7940] | 1587 | (if (eq type t) |
---|
| 1588 | `(progn ,thing t) |
---|
| 1589 | call))) |
---|
[6] | 1590 | |
---|
[9578] | 1591 | (define-compiler-macro structure-typep (&whole w thing type) |
---|
| 1592 | (if (not (quoted-form-p type)) |
---|
| 1593 | (progn |
---|
| 1594 | (warn "Non-qouted structure-type in ~s" w) |
---|
| 1595 | w) |
---|
| 1596 | (let* ((type (nx-unquote type))) |
---|
| 1597 | (if (symbolp type) |
---|
| 1598 | `(structure-typep ,thing ',(find-class-cell type t)) |
---|
| 1599 | w)))) |
---|
| 1600 | |
---|
[2052] | 1601 | (define-compiler-macro true (&rest args) |
---|
| 1602 | `(progn |
---|
| 1603 | ,@args |
---|
| 1604 | t)) |
---|
[6] | 1605 | |
---|
| 1606 | |
---|
[2052] | 1607 | (define-compiler-macro false (&rest args) |
---|
| 1608 | `(progn |
---|
| 1609 | ,@args |
---|
| 1610 | nil)) |
---|
| 1611 | |
---|
[6] | 1612 | (define-compiler-macro find-class (&whole call type &optional (errorp t) env) |
---|
| 1613 | (if (and (quoted-form-p type)(not *dont-find-class-optimize*)(not env)) |
---|
| 1614 | `(class-cell-find-class (load-time-value (find-class-cell ,type t)) ,errorp) |
---|
| 1615 | call)) |
---|
| 1616 | |
---|
| 1617 | |
---|
| 1618 | (define-compiler-macro gcd (&whole call &optional (n0 nil n0-p) (n1 nil n1-p) &rest rest) |
---|
| 1619 | (if rest |
---|
| 1620 | call |
---|
| 1621 | (if n1-p |
---|
| 1622 | `(gcd-2 ,n0 ,n1) |
---|
| 1623 | (if n0-p |
---|
| 1624 | `(%integer-abs ,n0) |
---|
| 1625 | 0)))) |
---|
| 1626 | |
---|
| 1627 | (define-compiler-macro lcm (&whole call &optional (n0 nil n0-p) (n1 nil n1-p) &rest rest) |
---|
| 1628 | (if rest |
---|
| 1629 | call |
---|
| 1630 | (if n1-p |
---|
| 1631 | `(lcm-2 ,n0 ,n1) |
---|
| 1632 | (if n0-p |
---|
| 1633 | `(%integer-abs ,n0) |
---|
| 1634 | 1)))) |
---|
| 1635 | |
---|
| 1636 | (define-compiler-macro max (&whole call &environment env n0 &optional (n1 nil n1-p) &rest rest) |
---|
| 1637 | (if rest |
---|
| 1638 | call |
---|
| 1639 | (if n1-p |
---|
| 1640 | (if (and (nx-form-typep n0 'fixnum env)(nx-form-typep n1 'fixnum env)) |
---|
| 1641 | `(imax-2 ,n0 ,n1) |
---|
| 1642 | `(max-2 ,n0 ,n1)) |
---|
| 1643 | `(require-type ,n0 'real)))) |
---|
| 1644 | |
---|
| 1645 | (define-compiler-macro max-2 (n0 n1) |
---|
| 1646 | (let* ((g0 (gensym)) |
---|
| 1647 | (g1 (gensym))) |
---|
| 1648 | `(let* ((,g0 ,n0) |
---|
| 1649 | (,g1 ,n1)) |
---|
| 1650 | (if (> ,g0 ,g1) ,g0 ,g1)))) |
---|
| 1651 | |
---|
| 1652 | (define-compiler-macro imax-2 (n0 n1) |
---|
| 1653 | (let* ((g0 (gensym)) |
---|
| 1654 | (g1 (gensym))) |
---|
| 1655 | `(let* ((,g0 ,n0) |
---|
| 1656 | (,g1 ,n1)) |
---|
| 1657 | (if (%i> ,g0 ,g1) ,g0 ,g1)))) |
---|
| 1658 | |
---|
| 1659 | |
---|
| 1660 | |
---|
| 1661 | |
---|
| 1662 | (define-compiler-macro min (&whole call &environment env n0 &optional (n1 nil n1-p) &rest rest) |
---|
| 1663 | (if rest |
---|
| 1664 | call |
---|
| 1665 | (if n1-p |
---|
| 1666 | (if (and (nx-form-typep n0 'fixnum env)(nx-form-typep n1 'fixnum env)) |
---|
| 1667 | `(imin-2 ,n0 ,n1) |
---|
| 1668 | `(min-2 ,n0 ,n1)) |
---|
| 1669 | `(require-type ,n0 'real)))) |
---|
| 1670 | |
---|
| 1671 | (define-compiler-macro min-2 (n0 n1) |
---|
| 1672 | (let* ((g0 (gensym)) |
---|
| 1673 | (g1 (gensym))) |
---|
| 1674 | `(let* ((,g0 ,n0) |
---|
| 1675 | (,g1 ,n1)) |
---|
| 1676 | (if (< ,g0 ,g1) ,g0 ,g1)))) |
---|
| 1677 | |
---|
| 1678 | (define-compiler-macro imin-2 (n0 n1) |
---|
| 1679 | (let* ((g0 (gensym)) |
---|
| 1680 | (g1 (gensym))) |
---|
| 1681 | `(let* ((,g0 ,n0) |
---|
| 1682 | (,g1 ,n1)) |
---|
| 1683 | (if (%i< ,g0 ,g1) ,g0 ,g1)))) |
---|
| 1684 | |
---|
| 1685 | |
---|
| 1686 | (defun eq-test-p (test) |
---|
| 1687 | (or (equal test ''eq) (equal test '#'eq))) |
---|
| 1688 | |
---|
| 1689 | (defun eql-test-p (test) |
---|
| 1690 | (or (equal test ''eql) (equal test '#'eql))) |
---|
| 1691 | |
---|
| 1692 | (define-compiler-macro adjoin (&whole whole elt list &rest keys) |
---|
| 1693 | (if (constant-keywords-p keys) |
---|
| 1694 | (destructuring-bind (&key (test ''eql) test-not key) keys |
---|
| 1695 | (or (and (null test-not) |
---|
| 1696 | (null key) |
---|
| 1697 | (cond ((eq-test-p test) |
---|
| 1698 | `(adjoin-eq ,elt ,list)) |
---|
| 1699 | ((eql-test-p test) |
---|
| 1700 | `(adjoin-eql ,elt ,list)) |
---|
| 1701 | (t nil))) |
---|
| 1702 | whole)) |
---|
| 1703 | whole)) |
---|
| 1704 | |
---|
| 1705 | (define-compiler-macro union (&whole whole list1 list2 &rest keys) |
---|
| 1706 | (if (constant-keywords-p keys) |
---|
| 1707 | (destructuring-bind (&key (test ''eql) test-not key) keys |
---|
| 1708 | (or (and (null test-not) |
---|
| 1709 | (null key) |
---|
| 1710 | (cond ((eq-test-p test) |
---|
| 1711 | `(union-eq ,list1 ,list2)) |
---|
| 1712 | ((eql-test-p test) |
---|
| 1713 | `(union-eql ,list1 ,list2)) |
---|
| 1714 | (t nil))) |
---|
| 1715 | whole)) |
---|
| 1716 | whole)) |
---|
| 1717 | |
---|
| 1718 | (define-compiler-macro slot-value (&whole whole &environment env |
---|
| 1719 | instance slot-name-form) |
---|
[97] | 1720 | (declare (ignore env)) |
---|
| 1721 | (let* ((name (and (quoted-form-p slot-name-form) |
---|
| 1722 | (typep (cadr slot-name-form) 'symbol) |
---|
| 1723 | (cadr slot-name-form)))) |
---|
| 1724 | (if name |
---|
| 1725 | `(slot-id-value ,instance (load-time-value (ensure-slot-id ',name))) |
---|
| 1726 | whole))) |
---|
[6] | 1727 | |
---|
[97] | 1728 | |
---|
[6] | 1729 | (define-compiler-macro set-slot-value (&whole whole &environment env |
---|
| 1730 | instance slot-name-form value-form) |
---|
[97] | 1731 | (declare (ignore env)) |
---|
| 1732 | (let* ((name (and (quoted-form-p slot-name-form) |
---|
| 1733 | (typep (cadr slot-name-form) 'symbol) |
---|
| 1734 | (cadr slot-name-form)))) |
---|
| 1735 | (if name |
---|
| 1736 | `(set-slot-id-value |
---|
| 1737 | ,instance |
---|
| 1738 | (load-time-value (ensure-slot-id ',name)) |
---|
| 1739 | ,value-form) |
---|
| 1740 | whole))) |
---|
[6] | 1741 | |
---|
| 1742 | |
---|
[9578] | 1743 | (define-compiler-macro slot-boundp (&whole whole instance slot-name-form) |
---|
| 1744 | (let* ((name (and (quoted-form-p slot-name-form) |
---|
| 1745 | (typep (cadr slot-name-form) 'symbol) |
---|
| 1746 | (cadr slot-name-form)))) |
---|
| 1747 | (if name |
---|
| 1748 | `(slot-id-boundp ,instance (load-time-value (ensure-slot-id ',name))) |
---|
| 1749 | whole))) |
---|
[97] | 1750 | |
---|
[6] | 1751 | (defsynonym %get-unsigned-byte %get-byte) |
---|
| 1752 | (defsynonym %get-unsigned-word %get-word) |
---|
| 1753 | (defsynonym %get-signed-long %get-long) |
---|
| 1754 | |
---|
| 1755 | |
---|
| 1756 | |
---|
| 1757 | |
---|
| 1758 | (define-compiler-macro arrayp (arg) |
---|
[1334] | 1759 | `(>= (the fixnum (typecode ,arg)) |
---|
[3228] | 1760 | ,(nx-lookup-target-uvector-subtag :array-header))) |
---|
[6] | 1761 | |
---|
| 1762 | (define-compiler-macro vectorp (arg) |
---|
[1334] | 1763 | `(>= (the fixnum (typecode ,arg)) |
---|
[3228] | 1764 | ,(nx-lookup-target-uvector-subtag :vector-header))) |
---|
[6] | 1765 | |
---|
| 1766 | |
---|
[3228] | 1767 | |
---|
[6] | 1768 | (define-compiler-macro fixnump (arg) |
---|
[3228] | 1769 | (let* ((fixnum-tag |
---|
| 1770 | (arch::target-fixnum-tag (backend-target-arch *target-backend*)))) |
---|
| 1771 | `(eql (lisptag ,arg) ,fixnum-tag))) |
---|
[6] | 1772 | |
---|
| 1773 | |
---|
[6177] | 1774 | |
---|
[6] | 1775 | (define-compiler-macro double-float-p (n) |
---|
[3228] | 1776 | (let* ((tag (arch::target-double-float-tag (backend-target-arch *target-backend*)))) |
---|
| 1777 | `(eql (typecode ,n) ,tag))) |
---|
[6] | 1778 | |
---|
| 1779 | |
---|
| 1780 | (define-compiler-macro short-float-p (n) |
---|
[3228] | 1781 | (let* ((arch (backend-target-arch *target-backend*)) |
---|
| 1782 | (tag (arch::target-single-float-tag arch)) |
---|
| 1783 | (op (if (arch::target-single-float-tag-is-subtag arch) |
---|
| 1784 | 'typecode |
---|
| 1785 | 'fulltag))) |
---|
| 1786 | `(eql (,op ,n) ,tag))) |
---|
[6] | 1787 | |
---|
| 1788 | |
---|
| 1789 | (define-compiler-macro floatp (n) |
---|
[3228] | 1790 | (let* ((typecode (make-symbol "TYPECODE")) |
---|
| 1791 | (arch (backend-target-arch *target-backend*)) |
---|
| 1792 | (single (arch::target-single-float-tag arch)) |
---|
| 1793 | (double (arch::target-double-float-tag arch))) |
---|
[6] | 1794 | `(let* ((,typecode (typecode ,n))) |
---|
| 1795 | (declare (fixnum ,typecode)) |
---|
[3228] | 1796 | (or (= ,typecode ,single) |
---|
| 1797 | (= ,typecode ,double))))) |
---|
[6] | 1798 | |
---|
| 1799 | (define-compiler-macro functionp (n) |
---|
[3228] | 1800 | (let* ((arch (backend-target-arch *target-backend*)) |
---|
| 1801 | (tag (arch::target-function-tag arch)) |
---|
| 1802 | (op (if (arch::target-function-tag-is-subtag arch) |
---|
| 1803 | 'typecode |
---|
| 1804 | 'fulltag))) |
---|
| 1805 | `(eql (,op ,n) ,tag))) |
---|
[6] | 1806 | |
---|
[1615] | 1807 | (define-compiler-macro symbolp (s) |
---|
[3228] | 1808 | (let* ((arch (backend-target-arch *target-backend*)) |
---|
| 1809 | (symtag (arch::target-symbol-tag arch)) |
---|
| 1810 | (op (if (arch::target-symbol-tag-is-subtag arch) |
---|
| 1811 | 'typecode |
---|
| 1812 | 'fulltag)) |
---|
| 1813 | (niltag (arch::target-null-tag arch))) |
---|
| 1814 | (if (eql niltag symtag) |
---|
| 1815 | `(eql (,op ,s) ,symtag) |
---|
| 1816 | (let* ((sym (gensym))) |
---|
| 1817 | `(let* ((,sym ,s)) |
---|
| 1818 | (if ,sym (eql (,op ,sym) ,symtag) t)))))) |
---|
| 1819 | |
---|
| 1820 | ;;; If NIL isn't tagged as a symbol, assume that LISPTAG only looks |
---|
| 1821 | ;;; at bits that NIL shares with a cons. |
---|
[6] | 1822 | (define-compiler-macro listp (n) |
---|
[3228] | 1823 | (let* ((arch (backend-target-arch *target-backend*)) |
---|
| 1824 | (cons-tag (arch::target-cons-tag arch)) |
---|
| 1825 | (nil-tag (arch::target-null-tag arch)) |
---|
| 1826 | (symbol-tag (arch::target-symbol-tag arch))) |
---|
| 1827 | (if (= nil-tag symbol-tag) |
---|
| 1828 | (let* ((nvar (gensym))) |
---|
| 1829 | `(let* ((,nvar ,n)) |
---|
| 1830 | (if ,nvar (consp ,nvar) t))) |
---|
| 1831 | `(eql (lisptag ,n) ,cons-tag)))) |
---|
[6] | 1832 | |
---|
| 1833 | (define-compiler-macro consp (n) |
---|
[3228] | 1834 | (let* ((cons-tag (arch::target-cons-tag (backend-target-arch *target-backend*)))) |
---|
| 1835 | `(eql (fulltag ,n) ,cons-tag))) |
---|
[6] | 1836 | |
---|
| 1837 | (define-compiler-macro bignump (n) |
---|
[3228] | 1838 | `(eql (typecode ,n) ,(nx-lookup-target-uvector-subtag :bignum))) |
---|
[6] | 1839 | |
---|
| 1840 | (define-compiler-macro ratiop (n) |
---|
[3228] | 1841 | `(eql (typecode ,n) ,(nx-lookup-target-uvector-subtag :ratio))) |
---|
[6] | 1842 | |
---|
| 1843 | (define-compiler-macro complexp (n) |
---|
[3228] | 1844 | `(eql (typecode ,n) ,(nx-lookup-target-uvector-subtag :complex))) |
---|
[6] | 1845 | |
---|
[3876] | 1846 | (define-compiler-macro macptrp (n) |
---|
| 1847 | `(eql (typecode ,n) ,(nx-lookup-target-uvector-subtag :macptr))) |
---|
[6] | 1848 | |
---|
[4910] | 1849 | (define-compiler-macro basic-stream-p (n) |
---|
| 1850 | `(eql (typecode ,n) ,(nx-lookup-target-uvector-subtag :basic-stream))) |
---|
| 1851 | |
---|
[6] | 1852 | (define-compiler-macro aref (&whole call a &rest subscripts &environment env) |
---|
[3228] | 1853 | (let* ((ctype (if (nx-form-typep a 'array env) |
---|
[9338] | 1854 | (specifier-type (nx-form-type a env) env))) |
---|
[3228] | 1855 | (type (if ctype (type-specifier (array-ctype-specialized-element-type ctype)))) |
---|
| 1856 | (useful (unless (or (eq type *) (eq type t)) |
---|
[9389] | 1857 | type))) |
---|
[3228] | 1858 | (if (= 2 (length subscripts)) |
---|
[5516] | 1859 | (setq call `(%aref2 ,a ,@subscripts)) |
---|
| 1860 | (if (= 3 (length subscripts)) |
---|
| 1861 | (setq call `(%aref3 ,a ,@subscripts)))) |
---|
[3228] | 1862 | (if useful |
---|
| 1863 | `(the ,useful ,call) |
---|
| 1864 | call))) |
---|
[6] | 1865 | |
---|
| 1866 | |
---|
| 1867 | (define-compiler-macro aset (&whole call a &rest subs&val) |
---|
| 1868 | (if (= 3 (length subs&val)) |
---|
[5516] | 1869 | `(%aset2 ,a ,@subs&val) |
---|
| 1870 | (if (= 4 (length subs&val)) |
---|
| 1871 | `(%aset3 ,a ,@subs&val) |
---|
| 1872 | call))) |
---|
[6] | 1873 | |
---|
| 1874 | |
---|
| 1875 | (define-compiler-macro make-sequence (&whole call &environment env typespec len &rest keys &key initial-element) |
---|
| 1876 | (declare (ignore typespec len keys initial-element)) |
---|
| 1877 | call) |
---|
| 1878 | |
---|
| 1879 | (define-compiler-macro make-string (&whole call size &rest keys) |
---|
| 1880 | (if (constant-keywords-p keys) |
---|
| 1881 | (destructuring-bind (&key (element-type () element-type-p) |
---|
| 1882 | (initial-element () initial-element-p)) |
---|
| 1883 | keys |
---|
| 1884 | (if (and element-type-p |
---|
| 1885 | (quoted-form-p element-type)) |
---|
| 1886 | (let* ((element-type (cadr element-type))) |
---|
| 1887 | (if (subtypep element-type 'base-char) |
---|
[1334] | 1888 | `(allocate-typed-vector :simple-string ,size ,@(if initial-element-p `(,initial-element))) |
---|
[6] | 1889 | call)) |
---|
| 1890 | (if (not element-type-p) |
---|
[1334] | 1891 | `(allocate-typed-vector :simple-string ,size ,@(if initial-element-p `(,initial-element))) |
---|
[6] | 1892 | call))) |
---|
| 1893 | call)) |
---|
| 1894 | |
---|
[5404] | 1895 | (define-compiler-macro make-string-output-stream (&whole whole &rest keys) |
---|
| 1896 | (if (null keys) |
---|
| 1897 | '(make-simple-string-output-stream) |
---|
| 1898 | whole)) |
---|
| 1899 | |
---|
| 1900 | |
---|
[9464] | 1901 | (define-compiler-macro write-string (&environment env &whole call |
---|
| 1902 | string &optional (stream nil) &rest keys) |
---|
| 1903 | (if (nx-form-typep string 'simple-string env) |
---|
| 1904 | (if keys |
---|
| 1905 | `((lambda (string stream &key start end) |
---|
| 1906 | (write-simple-string string stream start end)) |
---|
| 1907 | ,string ,stream ,@keys) |
---|
| 1908 | `(write-simple-string ,string ,stream 0 nil)) |
---|
| 1909 | call)) |
---|
| 1910 | |
---|
| 1911 | (define-compiler-macro format (&environment env &whole call stream string &rest args) |
---|
| 1912 | (if (stringp string) |
---|
| 1913 | (cond ((string-equal string "~a") |
---|
| 1914 | (destructuring-bind (object) args |
---|
| 1915 | (cond ((null stream) |
---|
| 1916 | `(princ-to-string ,object)) |
---|
| 1917 | ((or (eq stream t) (nx-form-typep stream 'stream env)) |
---|
[9483] | 1918 | `(progn (princ ,object ,(and (neq stream t) stream)) nil)) |
---|
[9464] | 1919 | (t `(let ((stream ,stream) |
---|
| 1920 | (object ,object)) |
---|
| 1921 | (if (or (null stream) (stringp stream)) |
---|
| 1922 | (format-to-string stream ,string object) |
---|
[9483] | 1923 | (progn (princ object (and (neq stream t) stream)) nil))))))) |
---|
[9464] | 1924 | ((string-equal string "~s") |
---|
| 1925 | (destructuring-bind (object) args |
---|
| 1926 | (cond ((null stream) |
---|
| 1927 | `(prin1-to-string ,object)) |
---|
| 1928 | ((or (eq stream t) (nx-form-typep stream 'stream env)) |
---|
[9483] | 1929 | `(progn (prin1 ,object ,(and (neq stream t) stream)) nil)) |
---|
[9464] | 1930 | (t `(let ((stream ,stream) |
---|
| 1931 | (object ,object)) |
---|
| 1932 | (if (or (null stream) (stringp stream)) |
---|
| 1933 | (format-to-string stream ,string object) |
---|
[9483] | 1934 | (progn (prin1 object (and (neq stream t) stream)) nil))))))) |
---|
[9464] | 1935 | ((and (null (position #\~ string)) (null args)) |
---|
| 1936 | (cond ((null stream) |
---|
| 1937 | string) |
---|
| 1938 | ((or (eq stream t) (nx-form-typep stream 'stream env)) |
---|
[9483] | 1939 | `(progn (write-string ,string ,(and (neq stream t) stream)) nil)) |
---|
[9464] | 1940 | (t `(let ((stream ,stream)) |
---|
| 1941 | (if (or (null stream) (stringp stream)) |
---|
| 1942 | (format-to-string stream ,string) |
---|
[9483] | 1943 | (progn (write-string ,string (and (neq stream t) stream)) nil)))))) |
---|
| 1944 | ((optimize-format-call stream string args env)) |
---|
[9464] | 1945 | (t call)) |
---|
| 1946 | call)) |
---|
| 1947 | |
---|
[9483] | 1948 | (defun count-known-format-args (string start end) |
---|
| 1949 | (declare (fixnum start end)) |
---|
| 1950 | (loop with count = 0 |
---|
| 1951 | do (setq start (position #\~ string :start start :end end)) |
---|
| 1952 | when (null start) |
---|
| 1953 | do (return count) |
---|
| 1954 | unless (< (incf start) end) |
---|
| 1955 | do (return nil) |
---|
| 1956 | do (let ((ch (aref string start))) |
---|
| 1957 | (cond ((memq ch '(#\a #\A #\s #\S)) (incf count)) |
---|
| 1958 | ((memq ch '(#\~ #\% #\&))) |
---|
| 1959 | (t (return nil))) |
---|
| 1960 | (incf start)))) |
---|
| 1961 | |
---|
| 1962 | (defun optimize-format-call (stream string args env) |
---|
| 1963 | (let* ((start (or (search "~/" string) |
---|
| 1964 | (return-from optimize-format-call nil))) |
---|
[9464] | 1965 | (ipos (+ start 2)) |
---|
[9483] | 1966 | (epos (or (position #\/ string :start ipos) |
---|
| 1967 | (return-from optimize-format-call nil))) |
---|
| 1968 | (nargs (or (count-known-format-args string 0 start) |
---|
| 1969 | (return-from optimize-format-call nil)))) |
---|
[9464] | 1970 | (when (and |
---|
[9483] | 1971 | ;; Must be able to split args |
---|
| 1972 | (< nargs (length args)) |
---|
[9464] | 1973 | ;; Don't deal with packages |
---|
| 1974 | (not (position #\: string :start ipos :end epos))) |
---|
| 1975 | (let* ((func (intern (string-upcase (subseq string ipos epos)) :cl-user)) |
---|
| 1976 | (prev (and (< 0 start) (subseq string 0 start))) |
---|
[9483] | 1977 | (prev-args (subseq args 0 nargs)) |
---|
[9464] | 1978 | (rest (and (< (1+ epos) (length string)) (subseq string (1+ epos)))) |
---|
[9483] | 1979 | (rest-args (nthcdr nargs args)) |
---|
| 1980 | (obj (pop rest-args)) |
---|
[9464] | 1981 | (stream-var (gensym)) |
---|
[9483] | 1982 | (body `(,@(and prev `((format ,stream-var ,prev ,@prev-args))) |
---|
[9464] | 1983 | (,func ,stream-var ,obj nil nil) |
---|
[9483] | 1984 | ,(if rest `(format ,stream-var ,rest ,@rest-args) `nil)))) |
---|
[9464] | 1985 | (cond ((null stream) |
---|
| 1986 | `(with-output-to-string (,stream-var) |
---|
| 1987 | (declare (type stream ,stream-var)) |
---|
| 1988 | ,@body)) |
---|
| 1989 | ((or (eq stream t) (nx-form-typep stream 'stream env)) |
---|
| 1990 | `(let ((,stream-var ,(if (eq stream t) '*standard-output* stream))) |
---|
| 1991 | (declare (type stream ,stream-var)) |
---|
| 1992 | ,@body)) |
---|
| 1993 | (t |
---|
| 1994 | `(let ((,stream-var ,stream)) |
---|
| 1995 | (if (or (null ,stream-var) (stringp ,stream-var)) |
---|
[9617] | 1996 | (format-to-string ,stream-var ,string ,@args) |
---|
[9483] | 1997 | (let ((,stream-var |
---|
| 1998 | (if (eq ,stream-var t) *standard-output* ,stream-var))) |
---|
| 1999 | ;; For the purposes of body, it's ok to assume stream-var |
---|
| 2000 | ;; is a stream. method dispatch will signal any errors |
---|
| 2001 | ;; at runtime if it's not true... |
---|
| 2002 | (declare (type stream ,stream-var)) |
---|
[9464] | 2003 | ,@body))))))))) |
---|
| 2004 | |
---|
| 2005 | |
---|
[6] | 2006 | (define-compiler-macro sbit (&environment env &whole call v &optional sub0 &rest others) |
---|
| 2007 | (if (and sub0 (null others)) |
---|
[1245] | 2008 | `(aref (the simple-bit-vector ,v) ,sub0) |
---|
[6] | 2009 | call)) |
---|
| 2010 | |
---|
| 2011 | (define-compiler-macro %sbitset (&environment env &whole call v sub0 &optional (newval nil newval-p) &rest newval-was-really-sub1) |
---|
| 2012 | (if (and newval-p (not newval-was-really-sub1) ) |
---|
[1245] | 2013 | `(setf (aref (the simple-bit-vector ,v) ,sub0) ,newval) |
---|
[6] | 2014 | call)) |
---|
| 2015 | |
---|
| 2016 | (define-compiler-macro simple-base-string-p (thing) |
---|
[3228] | 2017 | `(= (the fixnum (typecode ,thing)) ,(nx-lookup-target-uvector-subtag :simple-string))) |
---|
[6] | 2018 | |
---|
| 2019 | (define-compiler-macro simple-string-p (thing) |
---|
| 2020 | `(simple-base-string-p ,thing)) |
---|
| 2021 | |
---|
[7940] | 2022 | (define-compiler-macro stringp (thing) |
---|
| 2023 | `(base-string-p ,thing)) |
---|
[6] | 2024 | |
---|
[7940] | 2025 | (define-compiler-macro base-string-p (thing) |
---|
| 2026 | (let* ((gthing (gensym)) |
---|
| 2027 | (gtype (gensym))) |
---|
| 2028 | `(let* ((,gthing ,thing) |
---|
[10008] | 2029 | (,gtype (typecode ,gthing))) |
---|
[7940] | 2030 | (declare (type (unsigned-byte 8) ,gtype)) |
---|
| 2031 | (if (= ,gtype ,(nx-lookup-target-uvector-subtag :vector-header)) |
---|
| 2032 | (= (the (unsigned-byte 8) |
---|
| 2033 | (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref ,gthing target::arrayH.flags-cell)))) |
---|
| 2034 | ,(nx-lookup-target-uvector-subtag :simple-string)) |
---|
| 2035 | (= ,gtype ,(nx-lookup-target-uvector-subtag :simple-string)))))) |
---|
| 2036 | |
---|
| 2037 | |
---|
[9578] | 2038 | |
---|
[6] | 2039 | (defsetf %misc-ref %misc-set) |
---|
| 2040 | |
---|
| 2041 | (define-compiler-macro lockp (lock) |
---|
[9038] | 2042 | (let* ((tag (nx-lookup-target-uvector-subtag :lock))) |
---|
[3228] | 2043 | `(eq ,tag (typecode ,lock)))) |
---|
[6] | 2044 | |
---|
[9578] | 2045 | (define-compiler-macro structurep (s) |
---|
| 2046 | (let* ((tag (nx-lookup-target-uvector-subtag :struct))) |
---|
| 2047 | `(eq ,tag (typecode ,s)))) |
---|
| 2048 | |
---|
[3228] | 2049 | |
---|
[9389] | 2050 | (define-compiler-macro integerp (thing) |
---|
[3228] | 2051 | (let* ((typecode (gensym)) |
---|
| 2052 | (fixnum-tag (arch::target-fixnum-tag (backend-target-arch *target-backend*))) |
---|
| 2053 | (bignum-tag (nx-lookup-target-uvector-subtag :bignum))) |
---|
| 2054 | `(let* ((,typecode (typecode ,thing))) |
---|
| 2055 | (declare (fixnum ,typecode)) |
---|
[7940] | 2056 | (if (= ,typecode ,fixnum-tag) |
---|
| 2057 | t |
---|
| 2058 | (= ,typecode ,bignum-tag))))) |
---|
[8970] | 2059 | |
---|
| 2060 | (define-compiler-macro realp (&whole call x) |
---|
| 2061 | (if (not (eq *host-backend* *target-backend*)) |
---|
| 2062 | call |
---|
| 2063 | (let* ((typecode (gensym))) |
---|
| 2064 | `(let* ((,typecode (typecode ,x))) |
---|
| 2065 | (declare (type (unsigned-byte 8) ,typecode)) |
---|
| 2066 | #+ppc32-target |
---|
| 2067 | (or (= ,typecode ppc32::tag-fixnum) |
---|
| 2068 | (and (>= ,typecode ppc32::min-numeric-subtag) |
---|
| 2069 | (<= ,typecode ppc32::max-real-subtag))) |
---|
| 2070 | #+ppc64-target |
---|
| 2071 | (if (<= ,typecode ppc64::subtag-double-float) |
---|
| 2072 | (logbitp (the (integer 0 #.ppc64::subtag-double-float) ,typecode) |
---|
| 2073 | (logior (ash 1 ppc64::tag-fixnum) |
---|
| 2074 | (ash 1 ppc64::subtag-single-float) |
---|
| 2075 | (ash 1 ppc64::subtag-double-float) |
---|
| 2076 | (ash 1 ppc64::subtag-bignum) |
---|
| 2077 | (ash 1 ppc64::subtag-ratio)))) |
---|
| 2078 | #+x8664-target |
---|
| 2079 | (if (<= ,typecode x8664::subtag-double-float) |
---|
| 2080 | (logbitp (the (integer 0 #.x8664::subtag-double-float) ,typecode) |
---|
| 2081 | (logior (ash 1 x8664::tag-fixnum) |
---|
| 2082 | (ash 1 x8664::subtag-bignum) |
---|
| 2083 | (ash 1 x8664::tag-single-float) |
---|
| 2084 | (ash 1 x8664::subtag-double-float) |
---|
| 2085 | (ash 1 x8664::subtag-ratio)))))))) |
---|
[9389] | 2086 | |
---|
[388] | 2087 | (define-compiler-macro %composite-pointer-ref (size pointer offset) |
---|
| 2088 | (if (constantp size) |
---|
| 2089 | `(%inc-ptr ,pointer ,offset) |
---|
| 2090 | `(progn |
---|
| 2091 | ,size |
---|
| 2092 | (%inc-ptr ,pointer ,offset)))) |
---|
[6] | 2093 | |
---|
[1140] | 2094 | |
---|
| 2095 | (define-compiler-macro char= (&whole call ch &optional (other nil other-p) &rest others) |
---|
| 2096 | (if (null others) |
---|
| 2097 | (if other-p |
---|
| 2098 | `(eq (char-code ,ch) (char-code ,other)) |
---|
| 2099 | `(progn (char-code ,ch) t)) |
---|
[2248] | 2100 | (if (null (cdr others)) |
---|
| 2101 | (let* ((third (car others)) |
---|
[10008] | 2102 | (code (gensym)) |
---|
| 2103 | (code2 (gensym)) |
---|
| 2104 | (code3 (gensym))) |
---|
| 2105 | `(let* ((,code (char-code ,ch)) |
---|
| 2106 | (,code2 (char-code ,other)) |
---|
| 2107 | (,code3 (char-code ,third))) |
---|
| 2108 | (and (eq ,code ,code2) |
---|
| 2109 | (eq ,code2 ,code3)))) |
---|
[2248] | 2110 | call))) |
---|
[1140] | 2111 | |
---|
[3423] | 2112 | (define-compiler-macro char-equal (&whole call ch &optional (other nil other-p) &rest others) |
---|
| 2113 | (if (null others) |
---|
| 2114 | (if other-p |
---|
[9578] | 2115 | `(eq (%char-code-upcase (char-code ,ch)) (%char-code-upcase (char-code ,other))) |
---|
[3423] | 2116 | `(progn (char-code ,ch) t)) |
---|
| 2117 | (if (null (cdr others)) |
---|
| 2118 | (let* ((third (car others)) |
---|
[10008] | 2119 | (code (gensym)) |
---|
| 2120 | (code2 (gensym)) |
---|
| 2121 | (code3 (gensym))) |
---|
| 2122 | `(let* ((,code (%char-code-upcase (char-code ,ch))) |
---|
| 2123 | (,code2 (%char-code-upcase (char-code ,other))) |
---|
| 2124 | (,code3 (%char-code-upcase (char-code ,third)))) |
---|
| 2125 | (and (eq ,code ,code2) |
---|
| 2126 | (eq ,code ,code3)))) |
---|
[3423] | 2127 | call))) |
---|
| 2128 | |
---|
[1140] | 2129 | (define-compiler-macro char/= (&whole call ch &optional (other nil other-p) &rest others) |
---|
| 2130 | (if (null others) |
---|
| 2131 | (if other-p |
---|
| 2132 | `(not (eq (char-code ,ch) (char-code ,other))) |
---|
| 2133 | `(progn (char-code ,ch) t)) |
---|
| 2134 | call)) |
---|
| 2135 | |
---|
| 2136 | |
---|
| 2137 | (define-compiler-macro char< (&whole call ch &optional (other nil other-p) &rest others) |
---|
| 2138 | (if (null others) |
---|
| 2139 | (if other-p |
---|
| 2140 | `(< (the fixnum (char-code ,ch)) (the fixnum (char-code ,other))) |
---|
| 2141 | `(progn (char-code ,ch) t)) |
---|
[2248] | 2142 | (if (null (cdr others)) |
---|
| 2143 | (let* ((third (car others)) |
---|
[10008] | 2144 | (code (gensym)) |
---|
| 2145 | (code2 (gensym)) |
---|
| 2146 | (code3 (gensym))) |
---|
| 2147 | ;; We have to evaluate all forms for side-effects. |
---|
| 2148 | ;; Hopefully, there won't be any |
---|
| 2149 | `(let* ((,code (char-code ,ch)) |
---|
| 2150 | (,code2 (char-code ,other)) |
---|
| 2151 | (,code3 (char-code ,third))) |
---|
| 2152 | (declare (fixnum ,code ,code2 ,code3)) |
---|
| 2153 | (and (< ,code ,code2) |
---|
| 2154 | (< ,code2 ,code3)))) |
---|
[2248] | 2155 | call))) |
---|
[1140] | 2156 | |
---|
| 2157 | (define-compiler-macro char<= (&whole call ch &optional (other nil other-p) &rest others) |
---|
| 2158 | (if (null others) |
---|
| 2159 | (if other-p |
---|
| 2160 | `(<= (the fixnum (char-code ,ch)) (the fixnum (char-code ,other))) |
---|
| 2161 | `(progn (char-code ,ch) t)) |
---|
[2248] | 2162 | (if (null (cdr others)) |
---|
| 2163 | (let* ((third (car others)) |
---|
[10008] | 2164 | (code (gensym)) |
---|
| 2165 | (code2 (gensym)) |
---|
| 2166 | (code3 (gensym))) |
---|
| 2167 | `(let* ((,code (char-code ,ch)) |
---|
| 2168 | (,code2 (char-code ,other)) |
---|
| 2169 | (,code3 (char-code ,third))) |
---|
| 2170 | (declare (fixnum ,code ,code2 ,code3)) |
---|
| 2171 | (and (<= ,code ,code2) |
---|
| 2172 | (<= ,code2 ,code3)))) |
---|
[2248] | 2173 | call))) |
---|
[1140] | 2174 | |
---|
| 2175 | (define-compiler-macro char> (&whole call ch &optional (other nil other-p) &rest others) |
---|
| 2176 | (if (null others) |
---|
| 2177 | (if other-p |
---|
| 2178 | `(> (the fixnum (char-code ,ch)) (the fixnum (char-code ,other))) |
---|
| 2179 | `(progn (char-code ,ch) t)) |
---|
[2248] | 2180 | (if (null (cdr others)) |
---|
| 2181 | (let* ((third (car others)) |
---|
[10008] | 2182 | (code (gensym)) |
---|
| 2183 | (code2 (gensym)) |
---|
| 2184 | (code3 (gensym))) |
---|
| 2185 | `(let* ((,code (char-code ,ch)) |
---|
| 2186 | (,code2 (char-code ,other)) |
---|
| 2187 | (,code3 (char-code ,third))) |
---|
[10348] | 2188 | (declare (fixnum ,code ,code2 ,code3)) |
---|
[10008] | 2189 | (and (> ,code ,code2) |
---|
| 2190 | (> ,code2 ,code3)))) |
---|
[2248] | 2191 | call))) |
---|
[1140] | 2192 | |
---|
| 2193 | (define-compiler-macro char>= (&whole call ch &optional (other nil other-p) &rest others) |
---|
| 2194 | (if (null others) |
---|
| 2195 | (if other-p |
---|
| 2196 | `(>= (the fixnum (char-code ,ch)) (the fixnum (char-code ,other))) |
---|
| 2197 | `(progn (char-code ,ch) t)) |
---|
[2248] | 2198 | (if (null (cdr others)) |
---|
| 2199 | (let* ((third (car others)) |
---|
[10008] | 2200 | (code (gensym)) |
---|
| 2201 | (code2 (gensym)) |
---|
| 2202 | (code3 (gensym))) |
---|
| 2203 | `(let* ((,code (char-code ,ch)) |
---|
| 2204 | (,code2 (char-code ,other)) |
---|
| 2205 | (,code3 (char-code ,third))) |
---|
| 2206 | (declare (fixnum ,code ,code2 ,code3)) |
---|
| 2207 | (and (>= ,code ,code2) |
---|
| 2208 | (>= ,code2 ,code3)))) |
---|
[2248] | 2209 | call))) |
---|
[1140] | 2210 | |
---|
[6177] | 2211 | (define-compiler-macro float (&whole call number &optional (other 0.0f0 other-p) &environment env) |
---|
[9389] | 2212 | |
---|
[3660] | 2213 | (cond ((and (typep other 'single-float) |
---|
| 2214 | (nx-form-typep number 'double-float env)) |
---|
| 2215 | `(the single-float (%double-to-single ,number))) |
---|
| 2216 | ((and (typep other 'double-float) |
---|
| 2217 | (nx-form-typep number 'single-float env)) |
---|
| 2218 | `(the double-float (%single-to-double ,number))) |
---|
[6473] | 2219 | ((and other-p (typep other 'single-float)) |
---|
[6177] | 2220 | `(the single-float (%short-float ,number))) |
---|
| 2221 | ((typep other 'double-float) |
---|
| 2222 | `(the double-float (%double-float ,number))) |
---|
[6473] | 2223 | ((null other-p) |
---|
| 2224 | (let* ((temp (gensym))) |
---|
| 2225 | `(let* ((,temp ,number)) |
---|
| 2226 | (if (typep ,temp 'double-float) |
---|
| 2227 | ,temp |
---|
| 2228 | (the single-float (%short-float ,temp)))))) |
---|
[3660] | 2229 | (t call))) |
---|
| 2230 | |
---|
| 2231 | (define-compiler-macro coerce (&whole call thing type) |
---|
| 2232 | (if (quoted-form-p type) |
---|
| 2233 | (setq type (cadr type))) |
---|
| 2234 | (if (ignore-errors (subtypep type 'single-float)) |
---|
| 2235 | `(float ,thing 0.0f0) |
---|
| 2236 | (if (ignore-errors (subtypep type 'double-float)) |
---|
| 2237 | `(float ,thing 0.0d0) |
---|
| 2238 | call))) |
---|
| 2239 | |
---|
[7624] | 2240 | (define-compiler-macro equal (&whole call x y &environment env) |
---|
| 2241 | (if (or (equal-iff-eql-p x env) |
---|
| 2242 | (equal-iff-eql-p y env)) |
---|
| 2243 | `(eql ,x ,y) |
---|
| 2244 | call)) |
---|
| 2245 | |
---|
[8032] | 2246 | (define-compiler-macro instance-slots (&whole w instance) |
---|
| 2247 | (if (and (constantp instance) |
---|
| 2248 | (eql (typecode instance) (nx-lookup-target-uvector-subtag :instance))) |
---|
| 2249 | `(instance.slots ,instance) |
---|
[9350] | 2250 | (let* ((itemp (gensym)) |
---|
| 2251 | (typecode (gensym))) |
---|
| 2252 | `(let* ((,itemp ,instance) |
---|
| 2253 | (,typecode (typecode ,itemp))) |
---|
| 2254 | (declare (type (unsigned-byte 8) ,typecode)) |
---|
| 2255 | (if (eql ,typecode ,(nx-lookup-target-uvector-subtag :instance)) |
---|
| 2256 | (instance.slots ,itemp) |
---|
| 2257 | (%non-standard-instance-slots ,itemp ,typecode)))))) |
---|
[8032] | 2258 | |
---|
[9350] | 2259 | (define-compiler-macro instance-class-wrapper (instance) |
---|
| 2260 | (let* ((itemp (gensym))) |
---|
| 2261 | `(let* ((,itemp ,instance)) |
---|
| 2262 | (if (eql (the (unsigned-byte 8) (typecode ,itemp)) |
---|
| 2263 | ,(nx-lookup-target-uvector-subtag :instance)) |
---|
| 2264 | (instance.class-wrapper ,itemp) |
---|
[9938] | 2265 | (non-standard-instance-class-wrapper ,itemp))))) |
---|
[9350] | 2266 | |
---|
| 2267 | ;; Instance must be a standard-instance. |
---|
| 2268 | (define-compiler-macro %class-of-instance (instance) |
---|
| 2269 | `(%wrapper-class (instance.class-wrapper ,instance))) |
---|
| 2270 | |
---|
| 2271 | (define-compiler-macro standard-object-p (thing) |
---|
| 2272 | (let* ((temp (gensym)) |
---|
| 2273 | (typecode (gensym))) |
---|
| 2274 | `(let* ((,temp ,thing) |
---|
| 2275 | (,typecode (typecode ,temp))) |
---|
| 2276 | (declare (type (unsigned-byte 8) ,typecode)) |
---|
| 2277 | (if (= ,typecode ,(nx-lookup-target-uvector-subtag :instance)) |
---|
| 2278 | (instance.class-wrapper ,temp) |
---|
| 2279 | (if (= ,typecode ,(nx-lookup-target-uvector-subtag :macptr)) |
---|
| 2280 | (foreign-instance-class-wrapper ,temp)))))) |
---|
| 2281 | |
---|
[9578] | 2282 | (define-compiler-macro %class-ordinal (class &optional error) |
---|
| 2283 | (let* ((temp (gensym))) |
---|
| 2284 | `(let* ((,temp ,class)) |
---|
| 2285 | (if (eql (the (unsigned-byte 8) (typecode ,temp)) |
---|
| 2286 | ,(nx-lookup-target-uvector-subtag :instance)) |
---|
| 2287 | (instance.hash ,temp) |
---|
| 2288 | (funcall '%class-ordinal ,temp ,error))))) |
---|
| 2289 | |
---|
| 2290 | (define-compiler-macro native-class-p (class) |
---|
| 2291 | (let* ((temp (gensym))) |
---|
| 2292 | `(let* ((,temp ,class)) |
---|
| 2293 | (if (eql (the (unsigned-byte 8) (typecode ,temp)) |
---|
| 2294 | ,(nx-lookup-target-uvector-subtag :instance)) |
---|
| 2295 | (< (the fixnum (instance.hash ,temp)) max-class-ordinal))))) |
---|
| 2296 | |
---|
| 2297 | |
---|
| 2298 | |
---|
[8032] | 2299 | (define-compiler-macro unsigned-byte-p (x) |
---|
| 2300 | (if (typep (nx-unquote x) 'unsigned-byte) |
---|
| 2301 | t |
---|
| 2302 | (let* ((val (gensym))) |
---|
| 2303 | `(let* ((,val ,x)) |
---|
| 2304 | (and (integerp ,val) (not (< ,val 0))))))) |
---|
| 2305 | |
---|
[9578] | 2306 | (define-compiler-macro subtypep (&whole w t1 t2 &optional rtenv &environment env) |
---|
| 2307 | (if (and (consp t1) |
---|
| 2308 | (consp (cdr t1)) |
---|
| 2309 | (null (cddr t1)) |
---|
| 2310 | (eq (car t1) 'type-of)) |
---|
| 2311 | ;; People really write code like this. I've seen it. |
---|
| 2312 | `(typep ,(cadr t1) ,t2 ,@(and rtenv `(,rtenv))) |
---|
| 2313 | (if (and (null rtenv) (quoted-form-p t2)) |
---|
| 2314 | `(cell-csubtypep-2 ,t1 (load-time-value (register-type-cell ,t2))) |
---|
| 2315 | w))) |
---|
| 2316 | |
---|
| 2317 | |
---|
| 2318 | (define-compiler-macro string-equal (&whole w s1 s2 &rest keys) |
---|
| 2319 | (if (null keys) |
---|
| 2320 | `(%fixed-string-equal ,s1 ,s2) |
---|
| 2321 | (let* ((s1-arg (gensym)) |
---|
| 2322 | (s2-arg (gensym))) |
---|
| 2323 | `(funcall |
---|
| 2324 | (lambda (,s1-arg ,s2-arg &key start1 end1 start2 end2) |
---|
| 2325 | (%bounded-string-equal ,s1-arg ,s2-arg start1 end1 start2 end2)) |
---|
| 2326 | ,s1 ,s2 ,@keys)))) |
---|
| 2327 | |
---|
| 2328 | ;;; Try to use "package-references" to speed up package lookup when |
---|
| 2329 | ;;; a package name is used as a constant argument to some functions. |
---|
| 2330 | |
---|
| 2331 | (defun package-ref-form (arg) |
---|
| 2332 | (when (and arg (constantp arg) (typep (setq arg (nx-unquote arg)) |
---|
| 2333 | '(or symbol string))) |
---|
| 2334 | `(load-time-value (register-package-ref ,(string arg))))) |
---|
| 2335 | |
---|
| 2336 | |
---|
[9938] | 2337 | |
---|
[9578] | 2338 | (define-compiler-macro intern (&whole w string &optional package) |
---|
| 2339 | (let* ((ref (package-ref-form package))) |
---|
| 2340 | (if (or ref |
---|
| 2341 | (setq ref (and (consp package) |
---|
| 2342 | (eq (car package) 'find-package) |
---|
| 2343 | (consp (cdr package)) |
---|
| 2344 | (null (cddr package)) |
---|
| 2345 | (package-ref-form (cadr package))))) |
---|
| 2346 | `(%pkg-ref-intern ,string ,ref) |
---|
| 2347 | w))) |
---|
| 2348 | |
---|
| 2349 | (define-compiler-macro find-symbol (&whole w string &optional package) |
---|
| 2350 | (let* ((ref (package-ref-form package))) |
---|
| 2351 | (if (or ref |
---|
| 2352 | (setq ref (and (consp package) |
---|
| 2353 | (eq (car package) 'find-package) |
---|
| 2354 | (consp (cdr package)) |
---|
| 2355 | (null (cddr package)) |
---|
| 2356 | (package-ref-form (cadr package))))) |
---|
| 2357 | `(%pkg-ref-find-symbol ,string ,ref) |
---|
| 2358 | w))) |
---|
| 2359 | |
---|
| 2360 | (define-compiler-macro find-package (&whole w package) |
---|
| 2361 | (let* ((ref (package-ref-form package))) |
---|
| 2362 | (if ref |
---|
| 2363 | `(package-ref.pkg ,ref) |
---|
| 2364 | w))) |
---|
| 2365 | |
---|
| 2366 | (define-compiler-macro pkg-arg (&whole w package &optional allow-deleted) |
---|
| 2367 | (let* ((ref (unless allow-deleted (package-ref-form package)))) |
---|
| 2368 | (if ref |
---|
| 2369 | (let* ((r (gensym))) |
---|
| 2370 | `(let* ((,r ,ref)) |
---|
| 2371 | (or (package-ref.pkg ,ref) |
---|
| 2372 | (%kernel-restart $xnopkg (package-ref.pkg ,r))))) |
---|
| 2373 | w))) |
---|
| 2374 | |
---|
| 2375 | |
---|
| 2376 | ;;; In practice, things that're STREAMP are almost always |
---|
| 2377 | ;;; BASIC-STREAMs or FUNDAMENTAL-STREAMs, but STREAMP is a generic |
---|
| 2378 | ;;; function. |
---|
| 2379 | (define-compiler-macro streamp (arg) |
---|
| 2380 | (let* ((s (gensym))) |
---|
| 2381 | `(let* ((,s ,arg)) |
---|
| 2382 | (or (typep ,s 'basic-stream) |
---|
| 2383 | (typep ,s 'fundamental-stream) |
---|
| 2384 | ;; Don't recurse |
---|
| 2385 | (funcall 'streamp ,s))))) |
---|
| 2386 | |
---|
| 2387 | |
---|
| 2388 | (define-compiler-macro %char-code-case-fold (&whole w code vector &environment env) |
---|
| 2389 | (if (nx-open-code-in-line env) |
---|
| 2390 | (let* ((c (gensym)) |
---|
| 2391 | (table (gensym))) |
---|
| 2392 | `(let* ((,c ,code) |
---|
| 2393 | (,table ,vector)) |
---|
| 2394 | (declare (type (mod #x110000) ,c) |
---|
| 2395 | (type (simple-array (signed-byte 16) (*)) ,table)) |
---|
| 2396 | (if (< ,c (length ,table)) |
---|
| 2397 | (the fixnum (+ ,c (the (signed-byte 16) |
---|
| 2398 | (locally (declare (optimize (speed 3) (safety 0))) |
---|
| 2399 | (aref ,table ,c))))) |
---|
| 2400 | ,c))) |
---|
| 2401 | w)) |
---|
| 2402 | |
---|
| 2403 | (define-compiler-macro %char-code-upcase (&whole w code &environment env) |
---|
| 2404 | (if (typep code '(mod #x110000)) |
---|
| 2405 | (%char-code-upcase code) |
---|
| 2406 | `(%char-code-case-fold ,code *lower-to-upper*))) |
---|
| 2407 | |
---|
| 2408 | (define-compiler-macro %char-code-downcase (&whole w code &environment env) |
---|
| 2409 | (if (typep code '(mod #x110000)) |
---|
| 2410 | (%char-code-downcase code) |
---|
| 2411 | `(%char-code-case-fold ,code *upper-to-lower*))) |
---|
| 2412 | |
---|
| 2413 | (define-compiler-macro char-upcase (char) |
---|
| 2414 | `(code-char (%char-code-upcase (char-code ,char)))) |
---|
| 2415 | |
---|
| 2416 | |
---|
| 2417 | (define-compiler-macro register-istruct-cell (&whole w arg) |
---|
| 2418 | (if (and (quoted-form-p arg) |
---|
| 2419 | (cadr arg) |
---|
| 2420 | (typep (cadr arg) 'symbol)) |
---|
| 2421 | `',(register-istruct-cell (cadr arg)) |
---|
| 2422 | w)) |
---|
| 2423 | |
---|
| 2424 | (define-compiler-macro get-character-encoding (&whole w name) |
---|
| 2425 | (or (if (typep name 'keyword) (lookup-character-encoding name)) |
---|
| 2426 | w)) |
---|
[9938] | 2427 | |
---|
| 2428 | (define-compiler-macro read-char (&optional stream (eof-error-p t) eof-value recursive-p) |
---|
| 2429 | `(read-char-internal ,stream ,eof-error-p (values ,eof-value ,recursive-p))) |
---|
| 2430 | |
---|
[6] | 2431 | (provide "OPTIMIZERS") |
---|