source: trunk/source/compiler/optimizers.lisp @ 15706

Last change on this file since 15706 was 15618, checked in by gb, 7 years ago

In OPTIMIZE-FORMAT-CALL, punt if the prefix/suffix of the format
string contains a #\~. (May be a control directive.)
Fixes ticket:933 in the trunk.

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