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

Last change on this file since 12339 was 12339, checked in by gz, 11 years ago

Merge source location and code coverage implementation from the trunk. Some of the effects include:

  • make source notes take up less space
  • for code coverage, don't use with-code-coverage in pass2, therefore less impact on produced code.
  • accept method-function's in source location lookup
  • fix some cases that caused function source notes to not get recorded
  • record source files if source locations recording is not on.
  • record source locations in compile-time eval-when's.
  • better tracking of source notes through file compilation in some cases.
  • restore *fasl-eof-forms* support.
  • export a source-note API instead of converting to plists
  • only count emitted notes in cover coverage form totals
  • code coverage now more often has the source note for the whole definition.

Added :CCL-1.4 to *features*, to allow swank to be conditionalized for these changes (which will be part of CCL's 1.4 release)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 95.8 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 &environment env 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 &environment env 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 &environment env 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 &environment env 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 &environment env &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 (&whole call &environment env 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  (&whole call &environment env 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 (&whole call &environment env 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 (&whole call &environment env
1028                                       test sequence &rest keys)
1029  `(find ,test ,sequence
1030        :test #'funcall
1031        ,@keys))
1032
1033(define-compiler-macro find-if-not (&whole call &environment env
1034                                           test sequence &rest keys)
1035  `(find ,test ,sequence
1036        :test-not #'funcall
1037        ,@keys))
1038
1039;;; inline some cases, and use a positional function in others
1040
1041(define-compiler-macro find (&whole call &environment env
1042                                    item sequence &rest keys)
1043  (if (constant-keywords-p keys)
1044    (destructuring-bind (&key from-end test test-not (start 0) end key) keys
1045      (if (and (eql start 0)
1046               (null end)
1047               (null from-end)
1048               (not (and test test-not)))
1049        (let ((find-test (or test test-not '#'eql))
1050              (loop-test (if test-not 'unless 'when))
1051              (loop-function (nx-form-sequence-iterator sequence env)))
1052          (if loop-function
1053            (let ((item-var (unless (or (nx-form-constant-p item env)
1054                                        (and (equal find-test '#'funcall)
1055                                             (function-form-p item)))
1056                              (gensym)))
1057                  (elt-var (gensym)))
1058              `(let (,@(when item-var `((,item-var ,item))))
1059                 (,loop-function (,elt-var ,sequence)
1060                                 (,loop-test (funcall ,find-test ,(or item-var item)
1061                                                      (funcall ,(or key '#'identity) ,elt-var))
1062                                             (return ,elt-var)))))
1063            (let ((find-function (if test-not 'find-positional-test-not-key 'find-positional-test-key))
1064                  (item-var (gensym))
1065                  (sequence-var (gensym))
1066                  (test-var (gensym))
1067                  (key-var (gensym)))
1068              `(let ((,item-var ,item)
1069                     (,sequence-var ,sequence)
1070                     (,test-var ,(or test test-not))
1071                     (,key-var ,key))
1072                 (declare (dynamic-extent ,item-var ,sequence-var ,test-var ,key-var))
1073                 (,find-function ,item-var ,sequence-var ,test-var ,key-var)))))
1074        call))
1075      call))
1076
1077;;; expand position-if and position-if-not
1078
1079(define-compiler-macro position-if (&whole call &environment env
1080                                           test sequence &rest keys)
1081  `(position ,test ,sequence
1082             :test #'funcall
1083             ,@keys))
1084
1085(define-compiler-macro position-if-not (&whole call &environment env
1086                                               test sequence &rest keys)
1087  `(position ,test ,sequence
1088             :test-not #'funcall
1089             ,@keys))
1090
1091;;; inline some cases, and use positional functions for others
1092
1093(define-compiler-macro position (&whole call &environment env
1094                                        item sequence &rest keys)
1095  (if (constant-keywords-p keys)
1096    (destructuring-bind (&key from-end test test-not (start 0) end key) keys
1097      (if (and (eql start 0)
1098               (null end)
1099               (null from-end)
1100               (not (and test test-not)))
1101        (let ((position-test (or test test-not '#'eql))
1102              (loop-test (if test-not 'unless 'when)))
1103          (cond ((nx-form-typep sequence 'list env)
1104                 (let ((item-var (unless (or (nx-form-constant-p item env)
1105                                             (and (equal position-test '#'funcall)
1106                                                  (function-form-p item)))
1107                                   (gensym)))
1108                       (elt-var (gensym))
1109                       (position-var (gensym)))
1110                   `(let (,@(when item-var `((,item-var ,item)))
1111                          (,position-var 0))
1112                      (dolist (,elt-var ,sequence)
1113                        (,loop-test (funcall ,position-test ,(or item-var item)
1114                                             (funcall ,(or key '#'identity) ,elt-var))
1115                                    (return ,position-var))
1116                        (incf ,position-var)))))
1117                ((nx-form-typep sequence 'vector env)
1118                 (let ((item-var (unless (or (nx-form-constant-p item env)
1119                                             (and (equal position-test '#'funcall)
1120                                                  (function-form-p item)))
1121                                   (gensym)))
1122                       (sequence-var (gensym))
1123                       (position-var (gensym)))
1124                   `(let (,@(when item-var `((,item-var ,item)))
1125                          (,sequence-var ,sequence))
1126                      ,@(let ((type (nx-form-type sequence env)))
1127                          (unless (eq type t)
1128                            `((declare (type ,type ,sequence-var)))))
1129                      (dotimes (,position-var (length ,sequence-var))
1130                        (,loop-test (funcall ,position-test ,(or item-var item)
1131                                             (funcall ,(or key '#'identity)
1132                                                      (locally (declare (optimize (speed 3) (safety 0)))
1133                                                        (aref ,sequence ,position-var))))
1134                                    (return ,position-var))))))
1135                (t
1136                 (let ((position-function (if test-not
1137                                            'position-positional-test-not-key
1138                                            'position-positional-test-key))
1139                       (item-var (gensym))
1140                       (sequence-var (gensym))
1141                       (test-var (gensym))
1142                       (key-var (gensym)))
1143                   `(let ((,item-var ,item)
1144                          (,sequence-var ,sequence)
1145                          (,test-var ,(or test test-not))
1146                          (,key-var ,key))
1147                      (declare (dynamic-extent ,sequence-var ,test-var ,key-var))
1148                      (,position-function ,item-var ,sequence-var ,test-var ,key-var))))))
1149        call))
1150    call))
1151
1152;;; inline some cases of remove-if and remove-if-not
1153
1154(define-compiler-macro remove-if (&whole call &environment env &rest ignore)
1155  (declare (ignore ignore))
1156  (remove-if-transform call env))
1157
1158(define-compiler-macro remove-if-not (&whole call &environment env &rest ignore)
1159  (declare (ignore ignore))
1160  (remove-if-transform call env))
1161
1162(defun remove-if-transform (call env)
1163  (destructuring-bind (function test sequence &rest keys) call
1164    (if (constant-keywords-p keys)
1165      (destructuring-bind (&key from-end (start 0) end count (key '#'identity)) keys
1166        (if (and (eql start 0)
1167                 (null end)
1168                 (null from-end)
1169                 (null count)
1170                 (nx-form-typep sequence 'list env))
1171          ;; only do the list case, since it's hard to collect vector results
1172          (let ((temp-var (gensym))
1173                (result-var (gensym))
1174                (elt-var (gensym))
1175                (loop-test (ecase function (remove-if 'unless) (remove-if-not 'when))))
1176            `(the list
1177               (let* ((,temp-var (cons nil nil))
1178                      (,result-var ,temp-var))
1179                 (declare (dynamic-extent ,temp-var))
1180                 (dolist (,elt-var ,sequence (%cdr ,result-var))
1181                   (,loop-test (funcall ,test (funcall ,key ,elt-var))
1182                               (setq ,temp-var
1183                                     (%cdr
1184                                      (%rplacd ,temp-var (list ,elt-var)))))))))
1185          call))
1186      call)))
1187
1188
1189
1190(define-compiler-macro struct-set (&whole call &environment env struct offset new)
1191  (if (nx-inhibit-safety-checking env)
1192    `(%svset ,struct ,offset ,new)
1193    call))
1194
1195(define-compiler-macro zerop (arg &environment env)
1196  (let* ((z (if (nx-form-typep arg 'float env)
1197              (coerce 0 (nx-form-type arg env))
1198              0)))
1199    `(= ,arg ,z)))
1200
1201
1202(define-compiler-macro = (&whole w n0 &optional (n1 nil n1p) &rest more)
1203  (if (not n1p)
1204    `(require-type ,n0 'number)
1205    (if more
1206      w
1207      `(=-2 ,n0 ,n1))))
1208
1209(define-compiler-macro /= (&whole w n0 &optional (n1 nil n1p) &rest more)
1210  (if (not n1p)
1211    `(require-type ,n0 'number)
1212    (if more
1213      w
1214      `(/=-2 ,n0 ,n1))))
1215
1216(define-compiler-macro + (&whole w  &environment env &optional (n0 nil n0p) (n1 nil n1p) &rest more)
1217  (if more
1218    `(+ (+-2 ,n0 ,n1) ,@more)
1219    (if n1p
1220      `(+-2 ,n0 ,n1)
1221      (if n0p
1222        `(require-type ,n0 'number)
1223        0))))
1224
1225(define-compiler-macro - (&whole w &environment env n0 &optional (n1 nil n1p) &rest more)
1226  (if more
1227    `(- (--2 ,n0 ,n1) ,@more)
1228    (if n1p
1229      `(--2 ,n0 ,n1)
1230      `(%negate ,n0))))
1231
1232(define-compiler-macro * (&whole w &environment env &optional (n0 nil n0p) (n1 nil n1p) &rest more)
1233  (if more
1234    (let ((type (nx-form-type w env)))
1235      (if (and type (numeric-type-p type)) ; go pairwise if type known, else not
1236        `(*-2 ,n0 (* ,n1 ,@more))
1237        w))
1238    (if n1p
1239      `(*-2 ,n0 ,n1)
1240      (if n0p
1241        `(require-type ,n0 'number)
1242        1))))
1243
1244(define-compiler-macro / (&whole w n0 &optional (n1 nil n1p) &rest more)
1245  (if more
1246    w
1247    (if n1p
1248      `(/-2 ,n0 ,n1)
1249      `(%quo-1 ,n0))))
1250
1251;;; beware of limits - truncate of most-negative-fixnum & -1 ain't a
1252;;; fixnum - too bad
1253(define-compiler-macro truncate (&whole w &environment env n0 &optional (n1 nil n1p))
1254  (let ((*nx-form-type* t))
1255    (if (nx-form-typep n0 'fixnum env)
1256      (if (not n1p)
1257        n0
1258        (if (nx-form-typep n1 'fixnum env)
1259          `(%fixnum-truncate ,n0 ,n1)
1260          w))
1261      w)))
1262
1263(define-compiler-macro floor (&whole w &environment env n0 &optional (n1 nil n1p))
1264  (let ((*nx-form-type* t))
1265    (if (nx-form-typep n0 'fixnum env)
1266      (if (not n1p)
1267        n0
1268        (if (nx-form-typep n1 'fixnum env)
1269          `(%fixnum-floor ,n0 ,n1)
1270          w))
1271      w)))
1272
1273(define-compiler-macro round (&whole w &environment env n0 &optional (n1 nil n1p))
1274  (let ((*nx-form-type* t)) ; it doesn't matter what the result type is declared to be
1275    (if (nx-form-typep n0 'fixnum env)
1276      (if (not n1p)
1277        n0
1278        (if (nx-form-typep n1 'fixnum env)
1279          `(%fixnum-round ,n0 ,n1)
1280          w))
1281      w)))
1282
1283(define-compiler-macro ceiling (&whole w &environment env n0 &optional (n1 nil n1p))
1284  (let ((*nx-form-type* t))
1285    (if (nx-form-typep n0 'fixnum env)
1286      (if (not n1p)
1287        n0
1288        (if (nx-form-typep n1 'fixnum env)
1289          `(%fixnum-ceiling ,n0 ,n1)
1290          w))
1291      w)))
1292
1293(define-compiler-macro oddp (&whole w &environment env n0)
1294  (if (nx-form-typep n0 'fixnum env)
1295    `(logbitp 0 (the fixnum ,n0))
1296    w))
1297
1298(define-compiler-macro evenp (&whole w &environment env n0)
1299  (if (nx-form-typep n0 'fixnum env)
1300    `(not (logbitp 0 (the fixnum ,n0)))
1301    w))
1302
1303
1304(define-compiler-macro logandc2 (n0 n1)
1305  (let ((n1var (gensym))
1306        (n0var (gensym)))
1307    `(let ((,n0var ,n0)
1308           (,n1var ,n1))
1309       (logandc1 ,n1var ,n0var))))
1310
1311(define-compiler-macro logorc2 (n0 n1)
1312  (let ((n1var (gensym))
1313        (n0var (gensym)))
1314    `(let ((,n0var ,n0)
1315           (,n1var ,n1))
1316       (logorc1 ,n1var ,n0var))))
1317
1318(define-compiler-macro lognand (n0 n1)
1319  `(lognot (logand ,n0 ,n1)))
1320
1321(define-compiler-macro lognor (n0 n1)
1322  `(lognot (logior ,n0 ,n1)))
1323
1324
1325(defun transform-logop (whole identity binop &optional (transform-complement t))
1326  (destructuring-bind (op &optional (n0 nil n0p) (n1 nil n1p) &rest more) whole
1327    (if (and n1p (eql n0 identity))
1328      `(,op ,n1 ,@more)
1329      (if (and transform-complement n1p (eql n0 (lognot identity)))
1330        `(progn
1331           (,op ,n1 ,@more)
1332           ,(lognot identity))
1333        (if more
1334          (if (cdr more)
1335            whole
1336            `(,binop ,n0 (,binop ,n1 ,(car more))))
1337          (if n1p
1338            `(,binop ,n0 ,n1)
1339            (if n0p
1340              `(require-type ,n0 'integer)
1341              identity)))))))
1342
1343(define-compiler-macro logand (&whole w &rest all)
1344  (declare (ignore all))
1345  (transform-logop w -1 'logand-2))
1346
1347(define-compiler-macro logior (&whole w &rest all)
1348  (declare (ignore all))
1349  (transform-logop w 0 'logior-2))
1350
1351(define-compiler-macro logxor (&whole w &rest all)
1352  (declare (ignore all))
1353  (transform-logop w 0 'logxor-2 nil))
1354
1355(define-compiler-macro lognot (&whole w &environment env n1)
1356  (if (nx-form-typep n1 'fixnum env)
1357    `(%ilognot ,n1)
1358    w))
1359
1360(define-compiler-macro logtest (&whole w &environment env n1 n2)
1361  (if (and (nx-form-typep n1 'fixnum env)
1362           (nx-form-typep n2 'fixnum env))
1363    `(not (eql 0 (logand ,n1 ,n2)))
1364    w))
1365
1366
1367(defmacro defsynonym (from to)
1368  ;Should maybe check for circularities.
1369  `(progn
1370     (setf (compiler-macro-function ',from) nil)
1371     (let ((pair (assq ',from *nx-synonyms*)))
1372       (if pair (rplacd pair ',to)
1373           (push (cons ',from ',to)
1374                 *nx-synonyms*))
1375       ',to)))
1376
1377(defsynonym first car)
1378(defsynonym second cadr)
1379(defsynonym third caddr)
1380(defsynonym fourth cadddr)
1381(defsynonym rest cdr)
1382
1383
1384(defsynonym functionp lfunp)
1385(defsynonym null not)
1386(defsynonym char-int char-code)
1387
1388;;; Improvemets file by Bob Cassels
1389;;; Just what are "Improvemets", anyway ?
1390
1391;;; Optimize some CL sequence functions, mostly by inlining them in
1392;;; simple cases when the type of the sequence is known.  In some
1393;;; cases, dynamic-extent declarations are automatically inserted.
1394;;; For some sequence functions, if the type of the sequence is known
1395;;; at compile time, the function is inlined.  If the type isn't known
1396;;; but the call is "simple", a call to a faster (positional-arg)
1397;;; function is substituted.
1398
1399
1400(defun nx-form-sequence-iterator (sequence-form env)
1401  (cond ((nx-form-typep sequence-form 'vector env) 'dovector)
1402        ((nx-form-typep sequence-form 'list env) 'dolist)))
1403
1404(defun function-form-p (form)
1405   ;; c.f. quoted-form-p
1406   (and (consp form)
1407        (eq (%car form) 'function)
1408        (consp (%cdr form))
1409        (null (%cdr (%cdr form)))))
1410
1411
1412;; Return a form that checks to see if THING is if type CTYPE, or
1413;; NIL if we can't do that for some reason.
1414(defun optimize-ctypep (thing ctype)
1415  (when (eq *target-backend* *host-backend*)
1416    (typecase ctype
1417      (numeric-ctype
1418       (cond ((eq :real (numeric-ctype-complexp ctype))
1419              (let* ((low (numeric-ctype-low ctype))
1420                     (high (numeric-ctype-high ctype))
1421                     (class (numeric-ctype-class ctype))
1422                     (format (numeric-ctype-format ctype))
1423                     (type (if (eq class 'float)
1424                             (or format class)
1425                             (or class 'real))))
1426                (cond ((and low (eql low high) (or (not (eq class 'float))
1427                                                   format))
1428                       `(eql ,thing ,low))
1429                      ((and (eq type 'float)
1430                            (or low high)
1431                            (or (null low)
1432                                (typep low 'single-float)
1433                                (not (null (ignore-errors
1434                                             (coerce (if (atom low)
1435                                                       low
1436                                                       (car low))
1437                                                     'single-float)))))
1438                            (or (null high)
1439                                (typep high 'single-float)
1440                                (not (null (ignore-errors
1441                                             (coerce (if (atom high)
1442                                                       high
1443                                                       (car high))
1444                                                     'single-float))))))
1445                       (let* ((temp (gensym)))
1446                         (flet ((bounded-float (type low high)
1447                                  `(,type
1448                                    ,(if low
1449                                         (if (listp low)
1450                                           (list (coerce (car low) type))
1451                                           (coerce low type))
1452                                         '*)
1453                                    ,(if high
1454                                         (if (listp high)
1455                                           (list (coerce (car high) type))
1456                                           (coerce high type))
1457                                         '*))))
1458                         `(let* ((,temp ,thing))
1459                           (or (typep ,temp ',(bounded-float 'single-float low high))
1460                            (typep ,temp ',(bounded-float 'double-float low high)))))))
1461                      (t
1462                       (let* ((temp (gensym)))
1463                         (if (and (typep low 'fixnum) (typep high 'fixnum)
1464                                  (eq class 'integer))
1465                           (setq type 'fixnum))
1466                         (if (or low high)
1467                           `(let* ((,temp ,thing))
1468                             (and (typep ,temp ',type)
1469                              ,@(if low `((,(if (consp low) '> '>=) (the ,type ,temp) ,(if (consp low) (car low) low))))
1470                              ,@(if high `((,(if (consp high) '< '<=) (the ,type ,temp) ,(if (consp high) (car high) high))))))
1471                           `(typep ,thing ',type)))))))
1472             (t `(numeric-%%typep ,thing ,ctype))))
1473      (array-ctype
1474       (or
1475        (let* ((typecode (array-ctype-typecode ctype))
1476               (dims (array-ctype-dimensions ctype)))
1477          (cond ((and typecode (consp dims) (null (cdr dims)))
1478                 (case (array-ctype-complexp ctype)
1479                   ((nil)
1480                    (if (eq (car dims) '*)
1481                      `(eql (typecode ,thing) ,typecode)
1482                      (let* ((temp (gensym)))
1483                        `(let* ((,temp ,thing))
1484                          (and (eql (typecode ,temp) ,typecode)
1485                           (eq (uvsize ,temp) ,(car dims)))))))
1486                   ((* :maybe)
1487                    (let* ((temp (gensym))
1488                           (tempcode (gensym)))
1489                      `(let* ((,temp ,thing)
1490                              (,tempcode (typecode ,temp)))
1491                        (or (and (eql ,tempcode ,typecode)
1492                             ,@(unless (eq (car dims) '*)
1493                                       `((eq (uvsize ,temp) ,(car dims)))))
1494                         (and (eql ,tempcode target::subtag-vectorH)
1495                          (eql (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref ,temp target::arrayH.flags-cell))) ,typecode)
1496                          ,@(unless (eq (car dims) '*)
1497                                    `((eq (%svref ,temp target::vectorH.logsize-cell) ,(car dims)))))))))))))
1498        `(values (array-%%typep ,thing ,ctype)))))))
1499
1500
1501(defun optimize-typep (thing type env)
1502  ;; returns a new form, or nil if it can't optimize
1503  (let ((ctype (specifier-type-if-known type env :whine t)))
1504    (when ctype
1505      (let* ((type (type-specifier ctype))
1506             (predicate (if (typep type 'symbol) (type-predicate type))))
1507        (if (and predicate (symbolp predicate))
1508          `(,predicate ,thing)
1509          (let* ((pair (assq type *istruct-cells*))
1510                 (class (and pair (%wrapper-class (istruct-cell-info pair)))))
1511            (if (and class (not (%class-direct-subclasses class)))
1512              `(istruct-typep ,thing ',type)             
1513              (or (optimize-ctypep thing ctype)
1514                  (cond ((symbolp type)
1515                         (cond ((%deftype-expander type)
1516                                ;; recurse here, rather than returning the
1517                                ;; partially-expanded form mostly since it doesn't
1518                                ;; seem to further optimize the result otherwise
1519                                (let ((expanded-type (type-expand type)))
1520                                  (or (optimize-typep thing expanded-type env)
1521                                      ;; at least do the first expansion
1522                                      `(typep ,thing ',expanded-type))))
1523                               ((structure-class-p type env)
1524                                `(structure-typep ,thing ',(find-class-cell type t)))
1525                               ((find-class type nil env)
1526                                ;; If we know for sure that the class
1527                                ;; is one whose instances are all
1528                                ;; STANDARD-INSTANCEs (not funcallable,
1529                                ;; not foreign), we can use
1530                                ;; STD-INSTANCE-CLASS-CELL-TYPEP, which
1531                                ;; can be a little faster then the more
1532                                ;; general CLASS-CELL-TYPEP.  We can
1533                                ;; only be sure of that if the class
1534                                ;; exists (as a non-COMPILE-TIME-CLASS)
1535                                (let* ((class (find-class type nil nil))
1536                                       (fname 
1537                                        (if (and class
1538                                                 (subtypep class 'standard-object)
1539                                                 (not (subtypep class 'foreign-standard-object))
1540                                                 (not (subtypep class 'funcallable-standard-object)))
1541                                          'std-instance-class-cell-typep
1542                                          'class-cell-typep)))
1543                                  `(,fname ,thing (load-time-value (find-class-cell ',type t)))))
1544                               ((info-type-builtin type) ; bootstrap troubles here?
1545                                `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type))))
1546                               (t nil)))
1547                        ((consp type)
1548                         (cond
1549                           ((info-type-builtin type) ; byte types
1550                            `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type))))
1551                           (t
1552                            (case (%car type)
1553                              (satisfies `(funcall ',(cadr type) ,thing))
1554                              (eql `(eql ,thing ',(cadr type)))
1555                              (member `(not (null (member ,thing ',(%cdr type)))))
1556                              (not `(not (typep ,thing ',(cadr type))))
1557                              ((or and)
1558                               (let ((thing-sym (gensym)))
1559                                 `(let ((,thing-sym ,thing))
1560                                   (,(%car type)
1561                                    ,@(mapcar #'(lambda (type-spec)
1562                                                  (or (optimize-typep thing-sym type-spec env)
1563                                                      `(typep ,thing-sym ',type-spec)))
1564                                              (%cdr type))))))
1565                              ((signed-byte unsigned-byte integer mod) ; more byte types
1566                               `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type))))
1567                              (t nil)))))
1568                        (t nil))))))))))
1569
1570(define-compiler-macro typep  (&whole call &environment env thing type &optional e)
1571  (if (nx-form-constant-p type env)
1572    (let ((type-val (nx-form-constant-value type env)))
1573      (if (eq type-val t)
1574        `(progn ,thing t)
1575        (if (and (nx-form-constant-p thing env)
1576                 (specifier-type-if-known type-val env))
1577          (typep (nx-form-constant-value thing env) type-val env)
1578          (or (and (null e) (optimize-typep thing type-val env))
1579              call))))
1580    call))
1581
1582(define-compiler-macro structure-typep (&whole w thing type)
1583  (if (not (quoted-form-p type))
1584    (progn
1585      (warn "Non-quoted structure-type in ~s" w)
1586      w)
1587    (let* ((type (nx-unquote type)))
1588      (if (symbolp type)
1589        `(structure-typep ,thing ',(find-class-cell type t))
1590        w))))
1591
1592(define-compiler-macro true (&rest args)
1593  `(progn
1594    ,@args
1595    t))
1596
1597
1598(define-compiler-macro false (&rest args)
1599  `(progn
1600    ,@args
1601    nil))
1602
1603(define-compiler-macro find-class (&whole call type &optional (errorp t) env)
1604  (if (and (quoted-form-p type)(not *dont-find-class-optimize*)(not env))
1605      `(class-cell-find-class (load-time-value (find-class-cell ,type t)) ,errorp)
1606    call))
1607
1608
1609(define-compiler-macro gcd (&whole call &optional (n0 nil n0-p) (n1 nil n1-p) &rest rest)
1610  (if rest
1611    call
1612    (if n1-p
1613      `(gcd-2 ,n0 ,n1)
1614      (if n0-p
1615        `(%integer-abs ,n0)
1616        0))))
1617
1618(define-compiler-macro lcm (&whole call &optional (n0 nil n0-p) (n1 nil n1-p) &rest rest)
1619  (if rest
1620    call
1621    (if n1-p
1622      `(lcm-2 ,n0 ,n1)
1623      (if n0-p
1624        `(%integer-abs ,n0)
1625        1))))
1626
1627(define-compiler-macro max (&whole call &environment env n0 &optional (n1 nil n1-p) &rest rest)
1628  (if rest
1629    call
1630    (if n1-p
1631      (if (and (nx-form-typep n0 'fixnum env)(nx-form-typep n1 'fixnum env))
1632        `(imax-2 ,n0 ,n1)
1633        `(max-2 ,n0 ,n1))
1634      `(require-type ,n0 'real))))
1635
1636(define-compiler-macro max-2 (n0 n1)
1637  (let* ((g0 (gensym))
1638         (g1 (gensym)))
1639   `(let* ((,g0 ,n0)
1640           (,g1 ,n1))
1641      (if (> ,g0 ,g1) ,g0 ,g1))))
1642
1643(define-compiler-macro imax-2 (n0 n1)
1644  (let* ((g0 (gensym))
1645         (g1 (gensym)))
1646   `(let* ((,g0 ,n0)
1647           (,g1 ,n1))
1648      (if (%i> ,g0 ,g1) ,g0 ,g1))))
1649
1650
1651
1652
1653(define-compiler-macro min (&whole call &environment env n0 &optional (n1 nil n1-p) &rest rest)
1654  (if rest
1655    call
1656    (if n1-p
1657      (if (and (nx-form-typep n0 'fixnum env)(nx-form-typep n1 'fixnum env))
1658        `(imin-2 ,n0 ,n1)
1659        `(min-2 ,n0 ,n1))
1660      `(require-type ,n0 'real))))
1661
1662(define-compiler-macro min-2 (n0 n1)
1663  (let* ((g0 (gensym))
1664         (g1 (gensym)))
1665   `(let* ((,g0 ,n0)
1666           (,g1 ,n1))
1667      (if (< ,g0 ,g1) ,g0 ,g1))))
1668
1669(define-compiler-macro imin-2 (n0 n1)
1670  (let* ((g0 (gensym))
1671         (g1 (gensym)))
1672   `(let* ((,g0 ,n0)
1673           (,g1 ,n1))
1674      (if (%i< ,g0 ,g1) ,g0 ,g1))))
1675
1676
1677(defun eq-test-p (test)
1678  (or (equal test ''eq) (equal test '#'eq)))
1679
1680(defun eql-test-p (test)
1681  (or (equal test ''eql) (equal test '#'eql)))
1682
1683(define-compiler-macro adjoin (&whole whole elt list &rest keys)
1684  (if (constant-keywords-p keys)
1685    (destructuring-bind (&key (test ''eql) test-not key) keys
1686      (or (and (null test-not)
1687               (null key)
1688               (cond ((eq-test-p test)
1689                      `(adjoin-eq ,elt ,list))
1690                     ((eql-test-p test)
1691                      `(adjoin-eql ,elt ,list))
1692                     (t nil)))
1693          whole))
1694    whole))
1695
1696(define-compiler-macro union (&whole whole list1 list2 &rest keys)
1697  (if (constant-keywords-p keys)
1698    (destructuring-bind (&key (test ''eql) test-not key) keys
1699      (or (and (null test-not)
1700               (null key)
1701               (cond ((eq-test-p test)
1702                      `(union-eq ,list1 ,list2))
1703                     ((eql-test-p test)
1704                      `(union-eql ,list1 ,list2))
1705                     (t nil)))
1706          whole))
1707    whole))
1708
1709(define-compiler-macro slot-value (&whole whole &environment env
1710                                          instance slot-name-form)
1711  (declare (ignore env))
1712  (let* ((name (and (quoted-form-p slot-name-form)
1713                    (typep (cadr slot-name-form) 'symbol)
1714                    (cadr slot-name-form))))
1715    (if name
1716      `(slot-id-value ,instance (load-time-value (ensure-slot-id ',name)))
1717      whole)))
1718
1719
1720(define-compiler-macro set-slot-value (&whole whole &environment env
1721                                          instance slot-name-form value-form)
1722  (declare (ignore env))
1723  (let* ((name (and (quoted-form-p slot-name-form)
1724                    (typep (cadr slot-name-form) 'symbol)
1725                    (cadr slot-name-form))))
1726    (if name
1727      `(set-slot-id-value
1728        ,instance
1729        (load-time-value (ensure-slot-id ',name))
1730        ,value-form)
1731      whole)))
1732
1733
1734(define-compiler-macro slot-boundp (&whole whole instance slot-name-form)
1735  (let* ((name (and (quoted-form-p slot-name-form)
1736                    (typep (cadr slot-name-form) 'symbol)
1737                    (cadr slot-name-form))))
1738    (if name
1739      `(slot-id-boundp ,instance (load-time-value (ensure-slot-id ',name)))
1740      whole)))
1741
1742(defsynonym %get-unsigned-byte %get-byte)
1743(defsynonym %get-unsigned-word %get-word)
1744(defsynonym %get-signed-long %get-long)
1745
1746
1747
1748
1749(define-compiler-macro arrayp (arg)
1750  `(>= (the fixnum (typecode ,arg))
1751    ,(nx-lookup-target-uvector-subtag :array-header)))
1752
1753(define-compiler-macro vectorp (arg)
1754  `(>= (the fixnum (typecode ,arg))
1755    ,(nx-lookup-target-uvector-subtag :vector-header)))
1756
1757
1758
1759(define-compiler-macro fixnump (arg)
1760  (let* ((fixnum-tag
1761          (arch::target-fixnum-tag (backend-target-arch *target-backend*))))
1762    `(eql (lisptag ,arg) ,fixnum-tag)))
1763
1764
1765
1766(define-compiler-macro double-float-p (n)
1767  (let* ((tag (arch::target-double-float-tag (backend-target-arch *target-backend*))))
1768    `(eql (typecode ,n) ,tag)))
1769
1770
1771(define-compiler-macro short-float-p (n)
1772  (let* ((arch (backend-target-arch *target-backend*))
1773         (tag (arch::target-single-float-tag arch))
1774         (op (if (arch::target-single-float-tag-is-subtag arch)
1775               'typecode
1776               'fulltag)))
1777    `(eql (,op ,n) ,tag)))
1778
1779
1780(define-compiler-macro floatp (n)
1781  (let* ((typecode (make-symbol "TYPECODE"))
1782         (arch (backend-target-arch *target-backend*))
1783         (single (arch::target-single-float-tag arch))
1784         (double (arch::target-double-float-tag arch)))
1785    `(let* ((,typecode (typecode ,n)))
1786       (declare (fixnum ,typecode))
1787       (or (= ,typecode ,single)
1788           (= ,typecode ,double)))))
1789
1790(define-compiler-macro functionp (n)
1791  (let* ((arch (backend-target-arch *target-backend*))
1792         (tag (arch::target-function-tag arch))
1793         (op (if (arch::target-function-tag-is-subtag arch)
1794               'typecode
1795               'fulltag)))
1796    `(eql (,op  ,n) ,tag)))
1797
1798(define-compiler-macro symbolp (s)
1799  (let* ((arch (backend-target-arch *target-backend*))
1800         (symtag (arch::target-symbol-tag arch))
1801         (op (if (arch::target-symbol-tag-is-subtag arch)
1802               'typecode
1803               'fulltag))
1804         (niltag (arch::target-null-tag arch)))
1805    (if (eql niltag symtag)
1806      `(eql (,op ,s) ,symtag)
1807      (let* ((sym (gensym)))
1808        `(let* ((,sym ,s))
1809          (if ,sym (eql (,op ,sym) ,symtag) t))))))
1810
1811;;; If NIL isn't tagged as a symbol, assume that LISPTAG only looks
1812;;; at bits that NIL shares with a cons.
1813(define-compiler-macro listp (n)
1814  (let* ((arch (backend-target-arch *target-backend*))
1815         (cons-tag (arch::target-cons-tag arch))
1816         (nil-tag  (arch::target-null-tag arch))
1817         (symbol-tag (arch::target-symbol-tag arch)))
1818    (if (= nil-tag symbol-tag)
1819      (let* ((nvar (gensym)))
1820        `(let* ((,nvar ,n))
1821          (if ,nvar (consp ,nvar) t)))
1822      `(eql (lisptag ,n) ,cons-tag))))
1823
1824(define-compiler-macro consp (&whole call n)
1825  (let* ((arch (backend-target-arch *target-backend*))
1826         (cons-tag (arch::target-cons-tag arch))
1827         (nil-tag (arch::target-null-tag arch)))
1828    (if (= nil-tag cons-tag)
1829      call
1830      `(eql (fulltag ,n) ,cons-tag))))
1831
1832(define-compiler-macro bignump (n)
1833  `(eql (typecode ,n) ,(nx-lookup-target-uvector-subtag :bignum)))
1834
1835(define-compiler-macro ratiop (n)
1836  `(eql (typecode ,n) ,(nx-lookup-target-uvector-subtag :ratio)))
1837
1838(define-compiler-macro complexp (n)
1839  `(eql (typecode ,n) ,(nx-lookup-target-uvector-subtag :complex)))
1840
1841(define-compiler-macro macptrp (n)
1842  `(eql (typecode ,n) ,(nx-lookup-target-uvector-subtag :macptr)))
1843
1844(define-compiler-macro basic-stream-p (n)
1845  `(eql (typecode ,n) ,(nx-lookup-target-uvector-subtag :basic-stream)))
1846
1847(define-compiler-macro aref (&whole call a &rest subscripts &environment env)
1848  (let* ((ctype (if (nx-form-typep a 'array env)
1849                  (specifier-type (nx-form-type a env) env)))
1850         (ectype (typecase ctype
1851                   (array-ctype (array-ctype-specialized-element-type ctype))
1852                   (union-ctype (when (every #'array-ctype-p (union-ctype-types ctype))
1853                                  (%type-union
1854                                   (mapcar (lambda (ct) (array-ctype-specialized-element-type ct))
1855                                           (union-ctype-types ctype)))))))
1856         (etype (and ectype (type-specifier ectype)))
1857         (useful (unless (or (eq etype *) (eq etype t))
1858                   etype)))
1859    (if (= 2 (length subscripts))
1860      (setq call `(%aref2 ,a ,@subscripts))
1861      (if (= 3 (length subscripts))
1862        (setq call `(%aref3 ,a ,@subscripts))))
1863    (if useful
1864      `(the ,useful ,call)
1865      call)))
1866
1867
1868(define-compiler-macro aset (&whole call a &rest subs&val)
1869  (if (= 3 (length subs&val))
1870    `(%aset2 ,a ,@subs&val)
1871    (if (= 4 (length subs&val))
1872      `(%aset3 ,a ,@subs&val)
1873      call)))
1874
1875
1876(define-compiler-macro make-sequence (&whole call &environment env typespec len &rest keys &key initial-element)
1877  (declare (ignore typespec len keys initial-element))
1878  call)
1879
1880(define-compiler-macro make-string (&whole call &environment env size &rest keys)
1881  (if (constant-keywords-p keys)
1882    (destructuring-bind (&key (element-type () element-type-p)
1883                              (initial-element () initial-element-p))
1884                        keys
1885      (if (and element-type-p
1886               (nx-form-constant-p element-type env))
1887        (let* ((element-type (nx-form-constant-value element-type env)))
1888          (if (subtypep element-type 'base-char)
1889            `(allocate-typed-vector :simple-string ,size ,@(if initial-element-p `(,initial-element)))
1890            call))
1891        (if (not element-type-p)
1892          `(allocate-typed-vector :simple-string ,size ,@(if initial-element-p `(,initial-element)))
1893          call)))
1894    call))
1895
1896(define-compiler-macro make-string-output-stream (&whole whole &rest keys)
1897  (if (null keys)
1898    '(make-simple-string-output-stream)
1899    whole))
1900
1901
1902(define-compiler-macro write-string (&environment env &whole call
1903                                                  string &optional (stream nil) &rest keys)
1904  (if (nx-form-typep string 'simple-string env)
1905    (if keys
1906      `((lambda (string stream &key (start 0) end)
1907          (write-simple-string string stream start end))
1908        ,string ,stream ,@keys)
1909      `(write-simple-string ,string ,stream 0 nil))
1910    call))
1911
1912(define-compiler-macro format (&environment env &whole call stream string &rest args)
1913  (if (stringp string)
1914    (cond ((and (string-equal string "~a") args (null (cdr args)))
1915           (destructuring-bind (object) args
1916             (cond ((null stream)
1917                    `(princ-to-string ,object))
1918                   ((or (eq stream t) (nx-form-typep stream 'stream env))
1919                    `(progn (princ ,object ,(and (neq stream t) stream)) nil))
1920                   (t `(let ((stream ,stream)
1921                             (object ,object))
1922                         (if (or (null stream) (stringp stream))
1923                           (format-to-string stream ,string object)
1924                           (progn (princ object (and (neq stream t) stream)) nil)))))))
1925          ((and (string-equal string "~s") args (null (cdr args)))
1926           (destructuring-bind (object) args
1927             (cond ((null stream)
1928                    `(prin1-to-string ,object))
1929                   ((or (eq stream t) (nx-form-typep stream 'stream env))
1930                    `(progn (prin1 ,object ,(and (neq stream t) stream)) nil))
1931                   (t `(let ((stream ,stream)
1932                             (object ,object))
1933                         (if (or (null stream) (stringp stream))
1934                           (format-to-string stream ,string object)
1935                           (progn (prin1 object (and (neq stream t) stream)) nil)))))))
1936          ((and (null (position #\~ string)) (null args))
1937           (cond ((null stream)
1938                  string)
1939                 ((or (eq stream t) (nx-form-typep stream 'stream env))
1940                  `(progn (write-string ,string ,(and (neq stream t) stream)) nil))
1941                 (t `(let ((stream ,stream))
1942                       (if (or (null stream) (stringp stream))
1943                         (format-to-string stream ,string)
1944                         (progn (write-string ,string (and (neq stream t) stream)) nil))))))
1945          ((let ((new (format-string-sans~newlines string)))
1946             (and (neq new string) (setq string new)))
1947           `(format ,stream ,string ,@args))
1948          ((optimize-format-call stream string args env))
1949          (t call))
1950    call))
1951
1952(defun format-string-sans~newlines (string)
1953  (loop as pos = 0 then (position #\Newline string :start pos) while pos
1954        as ch = (and (> pos 0) (schar string (1- pos)))
1955        do (cond ((not (or (eq ch #\~)
1956                           (and (or (eq ch #\:) (eq ch #\@))
1957                                (> pos 1) (eq (schar string (- pos 2)) #\~))))
1958                  (incf pos))
1959                 ((eq ch #\:)
1960                  (decf pos 2)
1961                  (setq string (%str-cat (subseq string 0 pos) (subseq string (+ pos 3)))))
1962                 ((eq ch #\@)
1963                  (setq string (%str-cat (subseq string 0 (- pos 2))
1964                                         "~%"
1965                                         (subseq string (or
1966                                                         (position-if-not #'whitespacep string
1967                                                                          :start (1+ pos))
1968                                                         (1+ pos))))))
1969                  ((eq ch #\~)
1970                  (decf pos)
1971                  (setq string (%str-cat (subseq string 0 pos)
1972                                         (subseq string (or (position-if-not #'whitespacep string
1973                                                                         :start (1+ pos))
1974                                                            (1+ pos))))))))
1975  string)
1976
1977(defun count-known-format-args (string start end)
1978  (declare (fixnum end))
1979  (loop with count = 0
1980        do (setq start (position #\~ string :start start :end end))
1981        when (null start)
1982          do (return count)
1983        unless (< (incf start) end)
1984          do (return nil)
1985        do (let ((ch (aref string start)))
1986             (cond ((memq ch '(#\a #\A #\s #\S)) (incf count))
1987                   ((memq ch '(#\~ #\% #\&)))
1988                   (t (return nil)))
1989             (incf start))))
1990
1991(defun optimize-format-call (stream string args env)
1992  (let* ((start (or (search "~/" string)
1993                    (return-from optimize-format-call nil)))
1994         (ipos (+ start 2))
1995         (epos (or (position #\/ string :start ipos)
1996                   (return-from optimize-format-call nil)))
1997         (nargs (or (count-known-format-args string 0 start)
1998                    (return-from optimize-format-call nil))))
1999    (when (and
2000           ;; Must be able to split args
2001           (< nargs (length args))
2002           ;; Don't deal with packages
2003           (not (position #\: string :start ipos :end epos)))
2004      (let* ((func (intern (string-upcase (subseq string ipos epos)) :cl-user))
2005             (prev (and (< 0 start) (subseq string 0 start)))
2006             (prev-args (subseq args 0 nargs))
2007             (rest (and (< (1+ epos) (length string)) (subseq string (1+ epos))))
2008             (rest-args (nthcdr nargs args))
2009             (obj (pop rest-args))
2010             (stream-var (gensym))
2011             (body `(,@(and prev `((format ,stream-var ,prev ,@prev-args)))
2012                       (,func ,stream-var ,obj nil nil)
2013                       ,(if rest `(format ,stream-var ,rest ,@rest-args) `nil))))
2014        (cond ((null stream)
2015               `(with-output-to-string (,stream-var)
2016                  (declare (type stream ,stream-var))
2017                  ,@body))
2018              ((or (eq stream t) (nx-form-typep stream 'stream env))
2019               `(let ((,stream-var ,(if (eq stream t) '*standard-output* stream)))
2020                  (declare (type stream ,stream-var))
2021                  ,@body))
2022              (t
2023               `(let ((,stream-var ,stream))
2024                  (if (or (null ,stream-var) (stringp ,stream-var))
2025                    (format-to-string ,stream-var ,string ,@args)
2026                    (let ((,stream-var
2027                           (if (eq ,stream-var t) *standard-output* ,stream-var)))
2028                      ;; For the purposes of body, it's ok to assume stream-var
2029                      ;; is a stream. method dispatch will signal any errors
2030                      ;; at runtime if it's not true...
2031                      (declare (type stream ,stream-var))
2032                      ,@body)))))))))
2033
2034
2035(define-compiler-macro sbit (&environment env &whole call v &optional sub0 &rest others)
2036  (if (and sub0 (null others))
2037    `(aref (the simple-bit-vector ,v) ,sub0)
2038    call))
2039
2040(define-compiler-macro %sbitset (&environment env &whole call v sub0 &optional (newval nil newval-p) &rest newval-was-really-sub1)
2041  (if (and newval-p (not newval-was-really-sub1) )
2042    `(setf (aref (the simple-bit-vector ,v) ,sub0) ,newval)
2043    call))
2044
2045(define-compiler-macro simple-base-string-p (thing)
2046  `(= (the fixnum (typecode ,thing)) ,(nx-lookup-target-uvector-subtag :simple-string)))
2047
2048(define-compiler-macro simple-string-p (thing)
2049  `(simple-base-string-p ,thing))
2050
2051(define-compiler-macro stringp (thing)
2052  `(base-string-p  ,thing))
2053
2054(define-compiler-macro base-string-p (thing)
2055  (let* ((gthing (gensym))
2056         (gtype (gensym)))
2057    `(let* ((,gthing ,thing)
2058            (,gtype (typecode ,gthing)))
2059      (declare (type (unsigned-byte 8) ,gtype))
2060      (if (= ,gtype ,(nx-lookup-target-uvector-subtag :vector-header))
2061        (= (the (unsigned-byte 8)
2062             (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref ,gthing target::arrayH.flags-cell))))
2063           ,(nx-lookup-target-uvector-subtag :simple-string))
2064        (= ,gtype ,(nx-lookup-target-uvector-subtag :simple-string))))))
2065
2066
2067
2068(defsetf %misc-ref %misc-set)
2069
2070(define-compiler-macro lockp (lock)
2071  (let* ((tag (nx-lookup-target-uvector-subtag :lock)))
2072    `(eq ,tag (typecode ,lock))))
2073
2074(define-compiler-macro structurep (s)
2075  (let* ((tag (nx-lookup-target-uvector-subtag :struct)))
2076    `(eq ,tag (typecode ,s))))
2077 
2078
2079(define-compiler-macro integerp (thing)
2080  (let* ((typecode (gensym))
2081         (fixnum-tag (arch::target-fixnum-tag (backend-target-arch *target-backend*)))
2082         (bignum-tag (nx-lookup-target-uvector-subtag :bignum)))
2083    `(let* ((,typecode (typecode ,thing)))
2084      (declare (fixnum ,typecode))
2085      (if (= ,typecode ,fixnum-tag)
2086        t
2087        (= ,typecode ,bignum-tag)))))
2088
2089(define-compiler-macro realp (&whole call x)
2090  (if (not (eq *host-backend* *target-backend*))
2091    call
2092    (let* ((typecode (gensym)))
2093      `(let* ((,typecode (typecode ,x)))
2094        (declare (type (unsigned-byte 8) ,typecode))
2095        #+(or ppc32-target x8632-target)
2096        (or (= ,typecode target::tag-fixnum)
2097         (and (>= ,typecode target::min-numeric-subtag)
2098          (<= ,typecode target::max-real-subtag)))
2099        #+ppc64-target
2100        (if (<= ,typecode ppc64::subtag-double-float)
2101          (logbitp (the (integer 0 #.ppc64::subtag-double-float) ,typecode)
2102                   (logior (ash 1 ppc64::tag-fixnum)
2103                           (ash 1 ppc64::subtag-single-float)
2104                           (ash 1 ppc64::subtag-double-float)
2105                           (ash 1 ppc64::subtag-bignum)
2106                           (ash 1 ppc64::subtag-ratio))))
2107        #+x8664-target
2108        (if (<= ,typecode x8664::subtag-double-float)
2109          (logbitp (the (integer 0 #.x8664::subtag-double-float) ,typecode)
2110                   (logior (ash 1 x8664::tag-fixnum)
2111                           (ash 1 x8664::subtag-bignum)
2112                           (ash 1 x8664::tag-single-float)
2113                           (ash 1 x8664::subtag-double-float)
2114                           (ash 1 x8664::subtag-ratio))))))))
2115
2116(define-compiler-macro %composite-pointer-ref (size pointer offset)
2117  (if (constantp size)
2118    `(%inc-ptr ,pointer ,offset)
2119    `(progn
2120      ,size
2121      (%inc-ptr ,pointer ,offset))))
2122
2123
2124(define-compiler-macro char= (&whole call ch &optional (other nil other-p) &rest others)
2125  (if (null others)
2126    (if other-p
2127      `(eq (char-code ,ch) (char-code ,other))
2128      `(progn (char-code ,ch) t))
2129    (if (null (cdr others))
2130      (let* ((third (car others))
2131             (code (gensym))
2132             (code2 (gensym))
2133             (code3 (gensym)))
2134        `(let* ((,code (char-code ,ch))
2135                (,code2 (char-code ,other))
2136                (,code3 (char-code ,third)))
2137          (and (eq ,code ,code2)
2138           (eq ,code2 ,code3))))
2139      call)))
2140
2141(define-compiler-macro char-equal (&whole call ch &optional (other nil other-p) &rest others)
2142  (if (null others)
2143    (if other-p
2144      `(eq (%char-code-upcase (char-code ,ch)) (%char-code-upcase (char-code ,other)))
2145      `(progn (char-code ,ch) t))
2146    (if (null (cdr others))
2147      (let* ((third (car others))
2148             (code (gensym))
2149             (code2 (gensym))
2150             (code3 (gensym)))
2151        `(let* ((,code (%char-code-upcase (char-code ,ch)))
2152                (,code2 (%char-code-upcase (char-code ,other)))
2153                (,code3 (%char-code-upcase (char-code ,third))))
2154          (and (eq ,code ,code2)
2155           (eq ,code ,code3))))
2156      call)))
2157
2158(define-compiler-macro char/= (&whole call ch &optional (other nil other-p) &rest others)
2159  (if (null others)
2160    (if other-p
2161      `(not (eq (char-code ,ch) (char-code ,other)))
2162      `(progn (char-code ,ch) t))
2163    call))
2164
2165
2166(define-compiler-macro char< (&whole call ch &optional (other nil other-p) &rest others)
2167  (if (null others)
2168    (if other-p
2169      `(< (the fixnum (char-code ,ch)) (the fixnum (char-code ,other)))
2170      `(progn (char-code ,ch) t))
2171    (if (null (cdr others))
2172      (let* ((third (car others))
2173             (code (gensym))
2174             (code2 (gensym))
2175             (code3 (gensym)))
2176        ;; We have to evaluate all forms for side-effects.
2177        ;; Hopefully, there won't be any
2178        `(let* ((,code (char-code ,ch))
2179                (,code2 (char-code ,other))
2180                (,code3 (char-code ,third)))
2181          (declare (fixnum ,code ,code2 ,code3))
2182          (and (< ,code ,code2)
2183           (< ,code2 ,code3))))
2184      call)))
2185
2186(define-compiler-macro char<= (&whole call ch &optional (other nil other-p) &rest others)
2187  (if (null others)
2188    (if other-p
2189      `(<= (the fixnum (char-code ,ch)) (the fixnum (char-code ,other)))
2190      `(progn (char-code ,ch) t))
2191    (if (null (cdr others))
2192      (let* ((third (car others))
2193             (code (gensym))
2194             (code2 (gensym))
2195             (code3 (gensym)))
2196        `(let* ((,code (char-code ,ch))
2197                (,code2 (char-code ,other))
2198                (,code3 (char-code ,third)))
2199          (declare (fixnum ,code ,code2 ,code3))
2200          (and (<= ,code ,code2)
2201           (<= ,code2 ,code3))))
2202      call)))
2203
2204(define-compiler-macro char> (&whole call ch &optional (other nil other-p) &rest others)
2205  (if (null others)
2206    (if other-p
2207      `(> (the fixnum (char-code ,ch)) (the fixnum (char-code ,other)))
2208      `(progn (char-code ,ch) t))
2209    (if (null (cdr others))
2210      (let* ((third (car others))
2211             (code (gensym))
2212             (code2 (gensym))
2213             (code3 (gensym)))
2214        `(let* ((,code (char-code ,ch))
2215                (,code2 (char-code ,other))
2216                (,code3 (char-code ,third)))
2217          (declare (fixnum ,code ,code2 ,code3))
2218          (and (> ,code ,code2)
2219           (> ,code2 ,code3))))
2220      call)))
2221
2222(define-compiler-macro char>= (&whole call ch &optional (other nil other-p) &rest others)
2223  (if (null others)
2224    (if other-p
2225      `(>= (the fixnum (char-code ,ch)) (the fixnum (char-code ,other)))
2226      `(progn (char-code ,ch) t))
2227    (if (null (cdr others))
2228      (let* ((third (car others))
2229             (code (gensym))
2230             (code2 (gensym))
2231             (code3 (gensym)))
2232        `(let* ((,code (char-code ,ch))
2233                (,code2 (char-code ,other))
2234                (,code3 (char-code ,third)))
2235          (declare (fixnum ,code ,code2 ,code3))
2236          (and (>= ,code ,code2)
2237           (>= ,code2 ,code3))))
2238      call)))
2239
2240(define-compiler-macro float (&whole call number &optional (other 0.0f0 other-p) &environment env)
2241
2242  (cond ((and (typep other 'single-float)
2243              (nx-form-typep number 'double-float env))
2244         `(the single-float (%double-to-single ,number)))
2245        ((and (typep other 'double-float)
2246              (nx-form-typep number 'single-float env))
2247         `(the double-float (%single-to-double ,number)))
2248        ((and other-p (typep other 'single-float))
2249         `(the single-float (%short-float ,number)))
2250        ((typep other 'double-float)
2251         `(the double-float (%double-float ,number)))
2252        ((null other-p)
2253         (let* ((temp (gensym)))
2254           `(let* ((,temp ,number))
2255             (if (typep ,temp 'double-float)
2256               ,temp
2257               (the single-float (%short-float ,temp))))))
2258        (t call)))
2259
2260(define-compiler-macro coerce (&whole call &environment env thing type)
2261  (cond ((nx-form-constant-p type env)
2262         (setq type (nx-form-constant-value type env))
2263         (let ((ctype (specifier-type-if-known type env :whine t)))
2264           (if ctype
2265             (if (csubtypep ctype (specifier-type 'single-float))
2266                 `(float ,thing 0.0f0)
2267                 (if (csubtypep ctype (specifier-type 'double-float))
2268                     `(float ,thing 0.0d0)
2269                     (let ((simple nil)
2270                           (extra nil))
2271                       (if (and (typep ctype 'array-ctype)
2272                                (equal (array-ctype-dimensions ctype) '(*)))
2273                           (if (eq (array-ctype-specialized-element-type ctype)
2274                                   (specifier-type 'character))
2275                               (setq simple '%coerce-to-string)
2276                               (if (and (eq *host-backend* *target-backend*)
2277                                        (array-ctype-typecode ctype))
2278                                   (setq simple '%coerce-to-vector
2279                                         extra (list (array-ctype-typecode ctype)))))
2280                           (if (eq ctype (specifier-type 'list))
2281                               (setq simple '%coerce-to-list)))
2282                       (if simple
2283                           (let* ((temp (gensym)))
2284                             `(let* ((,temp ,thing))
2285                                (if (typep ,temp ',(type-specifier ctype))
2286                                    ,temp
2287                                    (,simple ,temp ,@extra))))
2288                           call))))
2289             call)))
2290        (t call)))
2291
2292(define-compiler-macro equal (&whole call x y &environment env)
2293  (if (or (equal-iff-eql-p x env)
2294          (equal-iff-eql-p y env))
2295    `(eql ,x ,y)
2296    call))
2297
2298(define-compiler-macro instance-slots (&whole w instance &environment env)
2299  (if (and (nx-form-constant-p instance env)
2300           (eql (typecode (nx-form-constant-value instance env)) (nx-lookup-target-uvector-subtag :instance)))
2301    `(instance.slots ,instance)
2302    (let* ((itemp (gensym))
2303           (typecode (gensym)))
2304      `(let* ((,itemp ,instance)
2305              (,typecode (typecode ,itemp)))
2306        (declare (type (unsigned-byte 8) ,typecode))
2307        (if (eql ,typecode ,(nx-lookup-target-uvector-subtag :instance))
2308          (instance.slots ,itemp)
2309          (%non-standard-instance-slots ,itemp ,typecode))))))
2310
2311(define-compiler-macro instance-class-wrapper (instance)
2312  (let* ((itemp (gensym)))
2313    `(let* ((,itemp ,instance))
2314      (if (eql (the (unsigned-byte 8) (typecode ,itemp))
2315               ,(nx-lookup-target-uvector-subtag :instance))
2316        (instance.class-wrapper ,itemp)
2317        (non-standard-instance-class-wrapper ,itemp)))))
2318
2319;; Instance must be a standard-instance.
2320(define-compiler-macro %class-of-instance (instance)
2321  `(%wrapper-class (instance.class-wrapper ,instance)))
2322
2323(define-compiler-macro standard-object-p (thing)
2324  (let* ((temp (gensym))
2325         (typecode (gensym)))
2326    `(let* ((,temp ,thing)
2327            (,typecode (typecode ,temp)))
2328      (declare (type (unsigned-byte 8) ,typecode))
2329      (if (= ,typecode ,(nx-lookup-target-uvector-subtag :instance))
2330        (instance.class-wrapper ,temp)
2331        (if (= ,typecode ,(nx-lookup-target-uvector-subtag :macptr))
2332          (foreign-instance-class-wrapper ,temp))))))
2333
2334(define-compiler-macro %class-ordinal (class &optional error)
2335  (let* ((temp (gensym)))
2336    `(let* ((,temp ,class))
2337      (if (eql (the (unsigned-byte 8) (typecode ,temp))
2338               ,(nx-lookup-target-uvector-subtag :instance))
2339        (instance.hash ,temp)
2340        (funcall '%class-ordinal ,temp ,error)))))
2341
2342(define-compiler-macro native-class-p (class)
2343  (let* ((temp (gensym)))
2344    `(let* ((,temp ,class))
2345      (if (eql (the (unsigned-byte 8) (typecode ,temp))
2346               ,(nx-lookup-target-uvector-subtag :instance))
2347        (< (the fixnum (instance.hash ,temp)) max-class-ordinal)))))
2348 
2349
2350
2351(define-compiler-macro unsigned-byte-p (x)
2352  (if (typep (nx-unquote x) 'unsigned-byte)
2353    t
2354    (let* ((val (gensym)))
2355      `(let* ((,val ,x))
2356        (and (integerp ,val) (not (< ,val 0)))))))
2357
2358(define-compiler-macro subtypep (&whole w t1 t2 &optional rtenv  &environment env)
2359  (if (and (consp t1)
2360           (consp (cdr t1))
2361           (null (cddr t1))
2362           (eq (car t1) 'type-of))
2363    ;; People really write code like this.  I've seen it.
2364    `(typep ,(cadr t1) ,t2 ,@(and rtenv `(,rtenv)))
2365    (if (and (null rtenv) (quoted-form-p t2))
2366      `(cell-csubtypep-2 ,t1 (load-time-value (register-type-cell ,t2)))
2367      w)))
2368
2369
2370(define-compiler-macro string-equal (&whole w s1 s2 &rest keys)
2371  (if (null keys)
2372    `(%fixed-string-equal ,s1 ,s2)
2373    (let* ((s1-arg (gensym))
2374           (s2-arg (gensym)))
2375      `(funcall
2376        (lambda (,s1-arg ,s2-arg &key start1 end1 start2 end2)
2377          (%bounded-string-equal ,s1-arg ,s2-arg start1 end1 start2 end2))
2378        ,s1 ,s2 ,@keys))))
2379
2380;;; Try to use "package-references" to speed up package lookup when
2381;;; a package name is used as a constant argument to some functions.
2382
2383(defun package-ref-form (arg env)
2384  (when (and arg (nx-form-constant-p arg env)
2385             (typep (setq arg (nx-form-constant-value arg env))
2386                    '(or symbol string)))
2387    `(load-time-value (register-package-ref ,(string arg)))))
2388
2389
2390
2391(define-compiler-macro intern (&whole w string &optional package &environment env)
2392  (let* ((ref (package-ref-form package env)))
2393    (if (or ref
2394            (setq ref (and (consp package)
2395                           (eq (car package) 'find-package)
2396                           (consp (cdr package))
2397                           (null (cddr package))
2398                           (package-ref-form (cadr package) env))))
2399      `(%pkg-ref-intern ,string ,ref)
2400      w)))
2401
2402(define-compiler-macro find-symbol (&whole w string &optional package &environment env)
2403  (let* ((ref (package-ref-form package env)))
2404    (if (or ref
2405            (setq ref (and (consp package)
2406                           (eq (car package) 'find-package)
2407                           (consp (cdr package))
2408                           (null (cddr package))
2409                           (package-ref-form (cadr package) env))))
2410      `(%pkg-ref-find-symbol ,string ,ref)
2411      w)))
2412
2413(define-compiler-macro find-package (&whole w package &environment env)
2414  (let* ((ref (package-ref-form package env)))
2415    (if ref
2416      `(package-ref.pkg ,ref)
2417      w)))
2418
2419(define-compiler-macro pkg-arg (&whole w package &optional allow-deleted &environment env)
2420  (let* ((ref (unless allow-deleted (package-ref-form package env))))
2421    (if ref
2422      (let* ((r (gensym)))
2423        `(let* ((,r ,ref))
2424          (or (package-ref.pkg ,ref)
2425           (%kernel-restart $xnopkg (package-ref.pkg ,r)))))
2426      w)))
2427
2428
2429;;; In practice, things that're STREAMP are almost always
2430;;; BASIC-STREAMs or FUNDAMENTAL-STREAMs, but STREAMP is a generic
2431;;; function.
2432(define-compiler-macro streamp (arg)
2433  (let* ((s (gensym)))
2434    `(let* ((,s ,arg))
2435      (or (typep ,s 'basic-stream)
2436       (typep ,s 'fundamental-stream)
2437       ;; Don't recurse
2438       (funcall 'streamp ,s)))))
2439
2440
2441(define-compiler-macro %char-code-case-fold (&whole w code vector &environment env)
2442  (if (nx-open-code-in-line env)
2443    (let* ((c (gensym))
2444           (table (gensym)))
2445      `(let* ((,c ,code)
2446              (,table ,vector))
2447        (declare (type (mod #x110000) ,c)
2448                 (type (simple-array (signed-byte 16) (*)) ,table))
2449        (if (< ,c (length ,table))
2450          (the fixnum (+ ,c (the (signed-byte 16)
2451                              (locally (declare (optimize (speed 3) (safety 0)))
2452                                (aref ,table ,c)))))
2453          ,c)))
2454    w))
2455       
2456(define-compiler-macro %char-code-upcase (&whole w code &environment env)
2457  (if (typep code '(mod #x110000))
2458    (%char-code-upcase code)
2459    `(%char-code-case-fold ,code *lower-to-upper*)))
2460
2461(define-compiler-macro %char-code-downcase (&whole w code &environment env)
2462  (if (typep code '(mod #x110000))
2463    (%char-code-downcase code)
2464    `(%char-code-case-fold ,code *upper-to-lower*)))
2465
2466(define-compiler-macro char-upcase (char)
2467  `(code-char (the valid-char-code (%char-code-upcase (char-code ,char)))))
2468
2469(define-compiler-macro char-downcase (char)
2470  `(code-char (the valid-char-code (%char-code-downcase (char-code ,char)))))
2471
2472
2473(define-compiler-macro register-istruct-cell (&whole w arg &environment env)
2474  (if (and (nx-form-constant-p arg env)
2475           (setq arg (nx-form-constant-value arg env))
2476           (symbolp arg))
2477    `',(register-istruct-cell arg)
2478    w))
2479
2480(define-compiler-macro get-character-encoding (&whole w name)
2481  (or (if (typep name 'keyword) (lookup-character-encoding name))
2482      w))
2483
2484(define-compiler-macro read-char (&optional stream (eof-error-p t) eof-value recursive-p)
2485  `(read-char-internal ,stream ,eof-error-p (values ,eof-value ,recursive-p)))
2486
2487
2488(provide "OPTIMIZERS")
Note: See TracBrowser for help on using the repository browser.