source: branches/working-0711/ccl/compiler/optimizers.lisp @ 12534

Last change on this file since 12534 was 12534, checked in by gz, 10 years ago

Make parse-macro bind &whole/&environment vars normally, so can tell whether used or not

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