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

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

Assorted tweaks for declaration checking

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