source: trunk/source/compiler/optimizers.lisp

Last change on this file was 16785, checked in by gz, 3 years ago

constant fold #'STRING

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