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

Last change on this file since 13067 was 13067, checked in by rme, 12 years ago

Update copyright notices.

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