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

Last change on this file since 14559 was 14559, checked in by gb, 9 years ago

In LDB compiler macro, just do a LOGAND if the bytespec's position
is 0.

Fixes ticket:805.

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