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

Last change on this file since 10319 was 10319, checked in by gb, 11 years ago

Compiler-macro on REGISTER-ISTRUCT-CELL.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 78.0 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(defun remove-explicit-test-keyword-from-test-testnot-key (item list keys default alist testonly)
146  (if (null keys)
147    `(,default ,item ,list)
148     (if (constant-keywords-p keys)
149        (destructuring-bind (&key (test nil test-p)
150                                  (test-not nil test-not-p)
151                                  (key nil key-p))
152                            keys
153          (declare (ignore test-not))
154          (if (and test-p
155                   (not test-not-p)
156                   (or (not key-p)
157                       (and (consp key)
158                            (consp (%cdr key))
159                            (null (%cddr key))
160                            (or (eq (%car key) 'function)
161                                (eq (%car key) 'quote))
162                            (eq (%cadr key) 'identity)))
163                   (consp test)
164                   (consp (%cdr test))
165                   (null (%cddr test))
166                   (or (eq (%car test) 'function)
167                       (eq (%car test) 'quote)))
168            (let* ((testname (%cadr test))
169                   (reduced (cdr (assoc testname alist))))
170              (if reduced
171                `(,reduced ,item ,list)
172                `(,testonly ,item ,list ,test))))))))
173
174
175(defun eql-iff-eq-p (thing env)
176  (if (quoted-form-p thing)
177    (setq thing (%cadr thing))
178    (if (not (self-evaluating-p thing))
179        (return-from eql-iff-eq-p
180          (or (nx-form-typep thing  'symbol env)
181              (nx-form-typep thing 'character env)
182              (nx-form-typep thing
183                             '(or fixnum
184                               #+64-bit-target single-float
185                               symbol character
186                               (and (not number) (not macptr))) env)))))
187  (or (fixnump thing) #+64-bit-target (typep thing 'single-float)
188      (symbolp thing) (characterp thing)
189      (and (not (numberp thing)) (not (macptrp thing)))))
190
191(defun equal-iff-eql-p (thing env)
192  (if (quoted-form-p thing)
193    (setq thing (%cadr thing))
194    (if (not (self-evaluating-p thing))
195      (return-from equal-iff-eql-p
196        (nx-form-typep thing
197                       '(and (not cons) (not string) (not bit-vector) (not pathname)) env))))
198  (not (typep thing '(or cons string bit-vector pathname))))
199
200
201(defun fold-constant-subforms (call env)
202    (let* ((constants nil)
203           (forms nil))
204      (declare (list constants forms))
205      (dolist (form (cdr call))
206        (setq form (nx-transform form env))
207        (if (numberp form)
208          (setq constants (%temp-cons form constants))
209          (setq forms (%temp-cons form forms))))
210      (if constants
211        (let* ((op (car call))
212               (constant (if (cdr constants) (handler-case (apply op constants)
213                                               (error (c) (declare (ignore c))
214                                                      (return-from fold-constant-subforms (values call t))))
215                             (car constants))))
216          (values (if forms (cons op (cons constant (reverse forms))) constant) t))
217        (values call nil))))
218
219;;; inline some, etc. in some cases
220;;; in all cases, add dynamic-extent declarations
221(defun some-xx-transform (call env)
222  (destructuring-bind (func predicate sequence &rest args) call
223    (multiple-value-bind (func-constant end-value loop-test)
224                         (case func
225                           (some (values $some nil 'when))
226                           (notany (values $notany t 'when))
227                           (every (values $every t 'unless))
228                           (notevery (values $notevery nil 'unless)))
229      (if args
230        (let ((func-sym (gensym))
231              (seq-sym (gensym))
232              (list-sym (gensym)))
233          `(let ((,func-sym ,predicate)
234                 (,seq-sym ,sequence)
235                 (,list-sym (list ,@args)))
236             (declare (dynamic-extent ,func-sym ,list-sym ,seq-sym))
237             (some-xx-multi ,func-constant ,end-value ,func-sym ,seq-sym ,list-sym)))
238        (let ((loop-function (nx-form-sequence-iterator sequence env)))
239          ;; inline if we know the type of the sequence and if
240          ;; the predicate is a lambda expression
241          ;; otherwise, it blows up the code for not much gain
242          (if (and loop-function
243                   (function-form-p predicate)
244                   (lambda-expression-p (second predicate)))
245            (let ((elt-var (gensym)))
246              (case func
247                (some
248                 `(,loop-function (,elt-var ,sequence ,end-value)
249                                  (let ((result (funcall ,predicate ,elt-var)))
250                                    (when result (return result)))))
251                ((every notevery notany)
252                 `(,loop-function (,elt-var ,sequence ,end-value)
253                                  (,loop-test (funcall ,predicate ,elt-var)
254                                              (return ,(not end-value)))))))
255            (let ((func-sym (gensym))
256                  (seq-sym (gensym)))
257              `(let ((,func-sym ,predicate)
258                     (,seq-sym ,sequence))
259                 (declare (dynamic-extent ,func-sym ,seq-sym))
260                 (some-xx-one ,func-constant ,end-value ,func-sym ,seq-sym)))))))))
261
262
263;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
264;;;
265;;; The new (roughly alphabetical) order.
266;;;
267;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
268
269;;; Compiler macros on functions can assume that their arguments have
270;;; already been transformed.
271
272
273(defun transform-real-n-ary-comparision (whole binary-name)
274  (destructuring-bind (n0 &optional (n1 0 n1-p) &rest more) (cdr whole)
275    (if more
276      (if (cdr more)
277        whole
278        (let* ((n2 (car more))
279               (n (gensym)))
280          `(let* ((,n ,n0))
281            (if (,binary-name ,n (setq ,n ,n1))
282              (,binary-name ,n ,n2)))))
283      (if (not n1-p)
284        `(require-type ,n0 'real)
285        `(,binary-name ,n0 ,n1)))))
286
287
288
289(define-compiler-macro < (&whole whole &rest ignore)
290  (declare (ignore ignore))
291  (transform-real-n-ary-comparision whole '<-2))
292
293(define-compiler-macro > (&whole whole &rest ignore)
294  (declare (ignore ignore))
295  (transform-real-n-ary-comparision whole '>-2))
296
297(define-compiler-macro <= (&whole whole &rest ignore)
298  (declare (ignore ignore))
299  (transform-real-n-ary-comparision whole '<=-2))
300
301(define-compiler-macro >= (&whole whole &rest ignore)
302  (declare (ignore ignore))
303  (transform-real-n-ary-comparision whole '>=-2))
304
305
306(define-compiler-macro 1- (x)
307  `(- ,x 1))
308
309(define-compiler-macro 1+ (x)
310  `(+ ,x 1))
311
312(define-compiler-macro append  (&whole call
313                                       &optional arg0
314                                       &rest
315                                       (&whole tail
316                                               &optional (junk nil arg1-p)
317                                               &rest more))
318  ;(append (list x y z) A) -> (list* x y z A)
319  (if (and arg1-p
320           (null more)
321           (consp arg0)
322           (eq (%car arg0) 'list))
323    (cons 'list* (append (%cdr arg0) tail))
324    (if (and arg1-p (null more))
325      `(append-2 ,arg0 ,junk)
326      call)))
327
328(define-compiler-macro apply  (&whole call &environment env fn arg0 &rest args)
329  ;; Special-case (apply #'make-instance 'name ...)
330  ;; Might be good to make this a little more general, e.g., there
331  ;; may be other things that can be strength-reduced even if we can't
332  ;; get rid of the APPLY.
333  (if (and (consp fn)
334           (or (eq (car fn) 'quote)
335               (eq (car fn) 'function))
336           (consp (cdr fn))
337           (null (cddr fn))
338           (eq (cadr fn) 'make-instance)
339           (consp arg0)
340           (eq (car arg0) 'quote)
341           (consp (cdr arg0))
342           (symbolp (cadr arg0)))
343    (let* ((name (cadr arg0))
344           (class-cell (gensym)))
345      `(let* ((,class-cell (load-time-value (find-class-cell ',name t))))
346        (apply (class-cell-instantiate ,class-cell) ,class-cell ,@args)))
347    (let ((original-fn fn))
348      (if (and arg0
349               (null args)
350               (consp fn)
351               (eq (%car fn) 'function)
352               (null (cdr (%cdr fn)))
353               (consp (setq fn (%cadr fn)))
354               (eq (%car fn) 'lambda))
355        (destructuring-bind (lambda-list &body body) (%cdr fn)
356          `(destructuring-bind ,lambda-list ,arg0 ,@body))
357        (let ((last (%car (last (push arg0 args)))))
358          (if (and (consp last) (memq (%car last) '(cons list* list)))
359            (cons (if (eq (%car last) 'list) 'funcall 'apply)
360                  (cons
361                   original-fn
362                   (nreconc (cdr (reverse args)) (%cdr last))))
363            call))))))
364
365
366
367(define-compiler-macro assoc (&whole call item list &rest keys)
368  (or (remove-explicit-test-keyword-from-test-testnot-key item list keys 'asseql '((eq . assq) (eql . asseql) (equal . assequal)) 'assoc-test)
369      call))
370
371(define-compiler-macro assequal (&whole call &environment env item list)
372  (if (or (equal-iff-eql-p item env)
373          (and (quoted-form-p list)
374               (proper-list-p (%cadr list))
375               (every (lambda (x) (equal-iff-eql-p (car x) env)) (%cadr list))))
376    `(asseql ,item ,list)
377    call))
378
379(define-compiler-macro asseql (&whole call &environment env item list)
380  (if (or (eql-iff-eq-p item env)
381          (and (quoted-form-p list)
382               (proper-list-p (%cadr list))
383               (every (lambda (x) (eql-iff-eq-p (car x) env)) (%cadr list))))
384    `(assq ,item ,list)
385    call))
386
387(define-compiler-macro assq (item list)
388  (let* ((itemx (gensym))
389         (listx (gensym))
390         (pair (gensym)))
391    `(let* ((,itemx ,item)
392            (,listx ,list))
393      (dolist (,pair ,listx)
394        (when (and ,pair (eq (car ,pair) ,itemx)) (return ,pair))))))
395
396(define-compiler-macro caar (form)
397  `(car (car ,form)))
398
399(define-compiler-macro cadr (form)
400  `(car (cdr ,form)))
401
402(define-compiler-macro cdar (form)
403  `(cdr (car ,form)))
404
405(define-compiler-macro cddr (form)
406  `(cdr (cdr ,form)))
407
408(define-compiler-macro caaar (form)
409  `(car (caar ,form)))
410
411(define-compiler-macro caadr (form)
412  `(car (cadr ,form)))
413
414(define-compiler-macro cadar (form)
415  `(car (cdar ,form)))
416
417(define-compiler-macro caddr (form)
418  `(car (cddr ,form)))
419
420(define-compiler-macro cdaar (form)
421  `(cdr (caar ,form)))
422
423(define-compiler-macro cdadr (form)
424  `(cdr (cadr ,form)))
425
426(define-compiler-macro cddar (form)
427  `(cdr (cdar ,form)))
428
429(define-compiler-macro cdddr (form)
430  `(cdr (cddr ,form)))
431
432(define-compiler-macro caaaar (form)
433  `(car (caaar ,form)))
434
435(define-compiler-macro caaadr (form)
436  `(car (caadr ,form)))
437
438(define-compiler-macro caadar (form)
439  `(car (cadar ,form)))
440
441(define-compiler-macro caaddr (form)
442  `(car (caddr ,form)))
443
444(define-compiler-macro cadaar (form)
445  `(car (cdaar ,form)))
446
447(define-compiler-macro cadadr (form)
448  `(car (cdadr ,form)))
449
450(define-compiler-macro caddar (form)
451  `(car (cddar ,form)))
452
453(define-compiler-macro cadddr (form)
454  `(car (cdddr ,form)))
455
456(define-compiler-macro cdaaar (form)
457  `(cdr (caaar ,form)))
458
459(define-compiler-macro cdaadr (form)
460  `(cdr (caadr ,form)))
461
462(define-compiler-macro cdadar (form)
463  `(cdr (cadar ,form)))
464
465(define-compiler-macro cdaddr (form)
466  `(cdr (caddr ,form)))
467
468(define-compiler-macro cddaar (form)
469  `(cdr (cdaar ,form)))
470
471(define-compiler-macro cddadr (form)
472  `(cdr (cdadr ,form)))
473
474(define-compiler-macro cdddar (form)
475  `(cdr (cddar ,form)))
476
477(define-compiler-macro cddddr (form)
478  `(cdr (cdddr ,form)))
479
480
481
482
483(define-compiler-macro cons (&whole call &environment env x y &aux dcall ddcall)
484   (if (consp (setq dcall y))
485     (cond
486      ((or (eq (%car dcall) 'list) (eq (%car dcall) 'list*))
487       ;(CONS A (LIST[*] . args)) -> (LIST[*] A . args)
488       (list* (%car dcall) x (%cdr dcall)))
489      ((or (neq (%car dcall) 'cons) (null (cddr dcall)) (cdddr dcall))
490       call)
491      ((null (setq ddcall (%caddr dcall)))
492       ;(CONS A (CONS B NIL)) -> (LIST A B)
493       `(list ,x ,(%cadr dcall)))
494      ((and (consp ddcall)
495            (eq (%car ddcall) 'cons)
496            (eq (list-length ddcall) 3))
497       ;(CONS A (CONS B (CONS C D))) -> (LIST* A B C D)
498       (list* 'list* x (%cadr dcall) (%cdr ddcall)))
499      (t call))
500     call))
501
502(define-compiler-macro dotimes (&whole call (i n &optional result)
503                                       &body body
504                                       &environment env)
505  (multiple-value-bind (body decls) (parse-body body env)
506    (if (nx-form-typep (setq n (nx-transform n env)) 'fixnum env)
507        (let* ((limit (gensym))
508               (upper (if (constantp n) n most-positive-fixnum))
509               (top (gensym))
510               (test (gensym)))
511          `(let* ((,limit ,n) (,i 0))
512             ,@decls
513             (declare (fixnum ,limit)
514                      (type (integer 0 ,(if (<= upper 0) 0 `(,upper))) ,i)
515                      (unsettable ,i))
516             (block nil
517               (tagbody
518                 (go ,test)
519                 ,top
520                 ,@body
521                 (locally
522                   (declare (settable ,i))
523                   (setq ,i (1+ ,i)))
524                 ,test
525                 (when (< ,i ,limit) (go ,top)))
526               ,result)))
527        call)))
528
529(define-compiler-macro dpb (&whole call &environment env value byte integer)
530  (cond ((and (integerp byte) (> byte 0))
531         (if (integerp value)
532           `(logior ,(dpb value byte 0) (logand ,(lognot byte) ,integer))
533           `(deposit-field (ash ,value ,(byte-position byte)) ,byte ,integer)))
534        ((and (consp byte)
535              (eq (%car byte) 'byte)
536              (eq (list-length (%cdr byte)) 2))
537         `(deposit-byte ,value ,(%cadr byte) ,(%caddr byte) ,integer))
538        (t call)))
539
540(define-compiler-macro eql (&whole call &environment env v1 v2)
541  (if (or (eql-iff-eq-p v1 env) (eql-iff-eq-p v2 env))
542    `(eq ,v1 ,v2)
543    call))
544
545(define-compiler-macro every (&whole call &environment env &rest ignore)
546  (declare (ignore ignore))
547  (some-xx-transform call env))
548
549
550(define-compiler-macro identity (form) form)
551
552(define-compiler-macro if (&whole call test true &optional false &environment env)
553  (multiple-value-bind (test test-win) (nx-transform test env)
554    (multiple-value-bind (true true-win) (nx-transform true env)
555      (multiple-value-bind (false false-win) (nx-transform false env)
556        (if (or (quoted-form-p test) (self-evaluating-p test))
557          (if (eval test)
558            true
559            false)
560          (if (or test-win true-win false-win)
561            `(if ,test ,true ,false)
562            call))))))
563
564(define-compiler-macro %ilsr (&whole call &environment env shift value)
565  (if (eql shift 0)
566    value
567    (if (eql value 0)
568      `(progn ,shift 0)
569      call)))
570
571
572(define-compiler-macro ldb (&whole call &environment env byte integer)
573   (cond ((and (integerp byte) (> byte 0))
574          (let ((size (byte-size byte))
575                (position (byte-position byte)))
576            (cond ((nx-form-typep integer 'fixnum env)
577                   `(logand ,(byte-mask size)
578                     (the fixnum (ash ,integer ,(- position)))))
579                  (t `(load-byte ,size ,position ,integer)))))
580         ((and (consp byte)
581               (eq (%car byte) 'byte)
582               (eq (list-length (%cdr byte)) 2))
583          (let ((size (%cadr byte))
584                (position (%caddr byte)))
585            (if (and (nx-form-typep integer 'fixnum env) (fixnump position))
586              ;; I'm not sure this is worth doing
587              `(logand (byte-mask ,size) (the fixnum (ash ,integer ,(- position))))
588              ;; this IS worth doing
589              `(load-byte ,size ,position ,integer))))
590         (t call)))
591
592(define-compiler-macro length (&whole call &environment env seq)
593  (if (nx-form-typep seq '(simple-array * (*)) env)
594    `(uvsize ,seq)
595    call))
596
597(define-compiler-macro let (&whole call (&optional (first nil first-p) &rest rest) &body body)
598  (if first-p
599    (if rest
600      call
601      `(let* (,first) ,@body))
602    `(locally ,@body)))
603
604(define-compiler-macro let* (&whole call (&rest bindings) &body body)
605  (if bindings
606    call
607    `(locally ,@body)))
608
609(define-compiler-macro list* (&whole call &environment env &rest rest  &aux (n (list-length rest)) last)
610  (cond ((%izerop n) nil)
611        ((null (setq last (%car (last call))))
612         (cons 'list (nreverse (cdr (reverse (cdr call))))))
613        ((and (consp last) (memq (%car last) '(list* list cons)))
614         (cons (if (eq (%car last) 'cons) 'list* (%car last))
615                                 (nreconc (cdr (reverse (cdr call))) (%cdr last))))
616        ((eq n 1) (list 'values last))
617        ((eq n 2) (cons 'cons (%cdr call)))
618        (t call)))
619
620
621
622;;;(CONS X NIL) is same size as (LIST X) and faster.
623(define-compiler-macro list  (&whole call &optional (first nil first-p) &rest more)
624  (if more
625    call
626    (if first-p
627      `(cons ,first nil))))
628
629
630(define-compiler-macro locally (&whole call &body body &environment env)
631  (multiple-value-bind (body decls) (parse-body body env nil)
632    (if decls
633      call
634      `(progn ,@body))))
635
636(defun specifier-type-if-known (typespec &optional env)
637  (handler-case (specifier-type typespec env)
638    (parse-unknown-type (c) (values nil (parse-unknown-type-specifier c)))
639    (error () nil)))
640
641#+debugging-version
642(defun specifier-type-if-known (typespec &optional env)
643  (handler-bind ((parse-unknown-type (lambda (c)
644                                       (break "caught unknown-type ~s" c)
645                                       (return-from specifier-type-if-known
646                                         (values nil (parse-unknown-type-specifier c)))))
647                 (error (lambda (c)
648                          (break "caught error ~s" c)
649                          (return-from specifier-type-if-known nil))))
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 (infer-array-type dims element-type element-type-p displaced-to-p fill-pointer-p adjustable-p env)))
758        `(the ,type ,expansion)))
759
760        call))
761
762(defun comp-make-displaced-array (dims keys)
763  (let* ((call-list (make-list 4 :initial-element nil))
764         (dims-var (make-symbol "DIMS"))
765         (let-list (comp-nuke-keys keys
766                                   '((:displaced-to 0)
767                                     (:fill-pointer 1)
768                                     (:adjustable 2)
769                                     (:displaced-index-offset 3))
770                                   call-list
771                                   `((,dims-var ,dims)))))
772
773    `(let ,let-list
774       (%make-displaced-array ,dims-var ,@call-list t))))
775
776(defun comp-make-uarray (dims keys subtype)
777  (if (null keys)
778    `(%make-simple-array ,subtype ,dims)
779    (let* ((call-list (make-list 6))
780           (dims-var (make-symbol "DIMS"))
781         (let-list (comp-nuke-keys keys
782                                   '((:adjustable 0)
783                                     (:fill-pointer 1)
784                                     (:initial-element 2 3)
785                                     (:initial-contents 4 5))
786                                   call-list
787                                   `((,dims-var ,dims)))))
788    `(let ,let-list
789       (make-uarray-1 ,subtype ,dims-var ,@call-list nil nil)))))
790
791(defun comp-make-array-1 (dims keys)
792  (let* ((call-list (make-list 10 :initial-element nil))
793         (dims-var (make-symbol "DIMS"))
794         (let-list (comp-nuke-keys keys
795                                   '((:element-type 0 1)
796                                     (:displaced-to 2)
797                                     (:displaced-index-offset 3)
798                                     (:adjustable 4)
799                                     (:fill-pointer 5)
800                                     (:initial-element 6 7)
801                                     (:initial-contents 8 9))
802                                   call-list
803                                   `((,dims-var ,dims)))))
804    `(let ,let-list
805       (make-array-1 ,dims-var ,@call-list nil))))
806
807(defun comp-nuke-keys (keys key-list call-list &optional required-bindings)
808  ; side effects call list, returns a let-list
809  (let* ((let-list (reverse required-bindings))
810         (seen nil))
811    (do ((lst keys (cddr lst)))
812        ((null lst) nil)
813      (let* ((key (car lst))
814             (val (cadr lst))
815             (ass (assq key key-list))
816             (vpos (cadr ass))
817             (ppos (caddr ass)))
818        (when ass
819          (unless (memq vpos seen)
820            (push vpos seen)
821            (when (not (constantp val))
822              (let ((gen (gensym)))
823                (setq let-list (cons (list gen val) let-list)) ; reverse him
824                (setq val gen)))
825            (rplaca (nthcdr vpos call-list) val)
826            (if ppos (rplaca (nthcdr ppos call-list) t))))))
827    (nreverse let-list)))
828
829(define-compiler-macro make-instance (&whole call class &rest initargs)
830  (if (and (listp class)
831           (eq (car class) 'quote)
832           (symbolp (cadr class))
833           (null (cddr class)))
834    (let* ((cell (gensym)))
835      `(let* ((,cell (load-time-value (find-class-cell ,class t))))
836        (funcall (class-cell-instantiate ,cell) ,cell ,@initargs)))
837    call))
838
839
840
841
842
843
844
845(define-compiler-macro mapc  (&whole call fn lst &rest more)
846  (if more
847    call
848    (let* ((temp-var (gensym))
849           (elt-var (gensym))
850           (fn-var (gensym)))
851       `(let* ((,fn-var ,fn)
852               (,temp-var ,lst))
853          (dolist (,elt-var ,temp-var ,temp-var)
854            (funcall ,fn-var ,elt-var))
855          ))))
856
857(define-compiler-macro mapcar (&whole call fn lst &rest more)
858  (if more
859    call
860    (let* ((temp-var (gensym))
861           (result-var (gensym))
862           (elt-var (gensym))
863           (fn-var (gensym)))
864      `(let* ((,temp-var (cons nil nil))
865              (,result-var ,temp-var)
866              (,fn-var ,fn))
867         (declare (dynamic-extent ,temp-var)
868                  (type cons ,temp-var ,result-var))
869         (dolist (,elt-var ,lst (cdr ,result-var))
870           (setq ,temp-var (setf (cdr ,temp-var) (list (funcall ,fn-var ,elt-var)))))))))
871
872(define-compiler-macro member (&whole call item list &rest keys)
873  (or (remove-explicit-test-keyword-from-test-testnot-key item list keys 'memeql '((eq . memq) (eql . memeql) (equal . memequal)) 'member-test)
874      call))
875
876(define-compiler-macro memequal (&whole call &environment env item list)
877  (if (or (equal-iff-eql-p item env)
878          (and (quoted-form-p list)
879               (proper-list-p (%cadr list))
880               (every (lambda (elt) (equal-iff-eql-p elt env)) (%cadr list))))
881    `(memeql ,item ,list)
882    call))
883
884(define-compiler-macro memeql (&whole call &environment env item list)
885  (if (or (eql-iff-eq-p item env)
886          (and (quoted-form-p list)
887               (proper-list-p (%cadr list))
888               (every (lambda (elt) (eql-iff-eq-p elt env)) (%cadr list))))
889    `(memq ,item ,list)
890    call))
891
892(define-compiler-macro memq (&whole call &environment env item list)
893  ;;(memq x '(y)) => (if (eq x 'y) '(y))
894  ;;Would it be worth making a two elt list into an OR?  Maybe if
895  ;;optimizing for speed...
896   (if (and (or (quoted-form-p list)
897                (null list))
898            (null (cdr (%cadr list))))
899     (if list `(if (eq ,item ',(%caadr list)) ,list))
900     (let* ((x (gensym))
901            (tail (gensym)))
902       `(do* ((,x ,item)
903              (,tail ,list (cdr (the list ,tail))))
904         ((null ,tail))
905         (if (eq (car ,tail) ,x) (return ,tail))))))
906
907(define-compiler-macro minusp (x)
908  `(< ,x 0))
909
910(define-compiler-macro notany (&whole call &environment env &rest ignore)
911  (declare (ignore ignore))
912  (some-xx-transform call env))
913
914(define-compiler-macro notevery (&whole call &environment env &rest ignore)
915  (declare (ignore ignore))
916  (some-xx-transform call env))
917
918(define-compiler-macro nth  (&whole call &environment env count list)
919   (if (and (fixnump count)
920            (%i>= count 0)
921            (%i< count 3))
922     `(,(svref '#(car cadr caddr) count) ,list)
923     `(car (nthcdr ,count ,list))))
924
925(define-compiler-macro nthcdr (&whole call &environment env count list)
926  (if (and (fixnump count)
927           (%i>= count 0)
928           (%i< count 4))
929     (if (%izerop count)
930       `(require-type ,list 'list)
931       `(,(svref '#(cdr cddr cdddr) (%i- count 1)) ,list))
932    (let* ((i (gensym))
933           (n (gensym))                 ; evaluation order
934           (tail (gensym)))
935      `(let* ((,n (require-type ,count 'unsigned-byte))
936              (,tail (require-type ,list 'list)))
937        (dotimes (,i ,n ,tail)
938          (unless (setq ,tail (cdr ,tail))
939            (return nil)))))))
940
941(define-compiler-macro plusp (x)
942  `(> ,x 0))
943
944(define-compiler-macro progn (&whole call &optional (first nil first-p) &rest rest)
945  (if first-p
946    (if rest call first)))
947
948;;; This isn't quite right... The idea is that (car (require-type foo
949;;; 'list)) ;can become just (<typechecking-car> foo) [regardless of
950;;; optimize settings], ;but I don't think this can be done just with
951;;; optimizers... For now, at least try to get it to become (%car
952;;; (<typecheck> foo)).
953(define-compiler-macro require-type (&whole call &environment env arg type &aux ctype)
954  (cond ((and (or (eq type t)
955                  (and (quoted-form-p type)
956                       (setq type (%cadr type))))
957              (setq ctype (specifier-type-if-known type env)))
958         (cond ((nx-form-typep arg type env) arg)
959               ((eq type 'simple-vector)
960                `(the simple-vector (require-simple-vector ,arg)))
961               ((eq type 'simple-string)
962                `(the simple-string (require-simple-string ,arg)))
963               ((eq type 'integer)
964                `(the integer (require-integer ,arg)))
965               ((eq type 'fixnum)
966                `(the fixnum (require-fixnum ,arg)))
967               ((eq type 'real)
968                `(the real (require-real ,arg)))
969               ((eq type 'list)
970                `(the list (require-list ,arg)))
971               ((eq type 'character)
972                `(the character (require-character ,arg)))
973               ((eq type 'number)
974                `(the number (require-number ,arg)))
975               ((eq type 'symbol)
976                `(the symbol (require-symbol ,arg)))
977               ((type= ctype
978                       (specifier-type '(signed-byte 8)))
979                `(the (signed-byte 8) (require-s8 ,arg)))
980               ((type= ctype
981                       (specifier-type '(unsigned-byte 8)))
982                `(the (unsigned-byte 8) (require-u8 ,arg)))
983               ((type= ctype
984                       (specifier-type '(signed-byte 16)))
985                `(the (signed-byte 16) (require-s16 ,arg)))
986               ((type= ctype
987                       (specifier-type '(unsigned-byte 16)))
988                `(the (unsigned-byte 16) (require-u16 ,arg)))
989               ((type= ctype
990                       (specifier-type '(signed-byte 32)))
991                `(the (signed-byte 32) (require-s32 ,arg)))
992               ((type= ctype
993                       (specifier-type '(unsigned-byte 32)))
994                `(the (unsigned-byte 32) (require-u32 ,arg)))
995               ((type= ctype
996                       (specifier-type '(signed-byte 64)))
997                `(the (signed-byte 64) (require-s64 ,arg)))
998               ((type= ctype
999                       (specifier-type '(unsigned-byte 64)))
1000                `(the (unsigned-byte 64) (require-u64 ,arg)))
1001               #+nil
1002               ((and (symbolp type)
1003                     (let ((simpler (type-predicate type)))
1004                       (if simpler `(the ,type (%require-type ,arg ',simpler))))))
1005               #+nil
1006               ((and (symbolp type)(find-class type nil env))
1007                  `(%require-type-class-cell ,arg (load-time-value (find-class-cell ',type t))))
1008               (t (let* ((val (gensym)))
1009                    `(let* ((,val ,arg))
1010                      (if (typep ,val ',type)
1011                        ,val
1012                        (%kernel-restart $xwrongtype ,val ',type)))))))
1013        (t call)))
1014
1015(define-compiler-macro proclaim (&whole call decl)
1016   (if (and (quoted-form-p decl)
1017            (eq (car (setq decl (%cadr decl))) 'special))
1018       (do ((vars (%cdr decl) (%cdr vars)) (decls ()))
1019           ((null vars)
1020            (cons 'progn (nreverse decls)))
1021         (unless (and (car vars)
1022                      (neq (%car vars) t)
1023                      (symbolp (%car vars)))
1024            (return call))
1025         (push (list '%proclaim-special (list 'quote (%car vars))) decls))
1026       call))
1027
1028
1029(define-compiler-macro some (&whole call &environment env &rest ignore)
1030  (declare (ignore ignore))
1031  (some-xx-transform call env))
1032
1033(define-compiler-macro struct-ref (&whole call &environment env struct offset)
1034   (if (nx-inhibit-safety-checking env)
1035    `(%svref ,struct ,offset)
1036    call))
1037
1038;;; expand find-if and find-if-not
1039
1040(define-compiler-macro find-if (&whole call &environment env
1041                                       test sequence &rest keys)
1042  `(find ,test ,sequence
1043        :test #'funcall
1044        ,@keys))
1045
1046(define-compiler-macro find-if-not (&whole call &environment env
1047                                           test sequence &rest keys)
1048  `(find ,test ,sequence
1049        :test-not #'funcall
1050        ,@keys))
1051
1052;;; inline some cases, and use a positional function in others
1053
1054(define-compiler-macro find (&whole call &environment env
1055                                    item sequence &rest keys)
1056  (if (constant-keywords-p keys)
1057    (destructuring-bind (&key from-end test test-not (start 0) end key) keys
1058      (if (and (eql start 0)
1059               (null end)
1060               (null from-end)
1061               (not (and test test-not)))
1062        (let ((find-test (or test test-not '#'eql))
1063              (loop-test (if test-not 'unless 'when))
1064              (loop-function (nx-form-sequence-iterator sequence env)))
1065          (if loop-function
1066            (let ((item-var (unless (or (constantp item)
1067                                        (and (equal find-test '#'funcall)
1068                                             (function-form-p item)))
1069                              (gensym)))
1070                  (elt-var (gensym)))
1071              `(let (,@(when item-var `((,item-var ,item))))
1072                 (,loop-function (,elt-var ,sequence)
1073                                 (,loop-test (funcall ,find-test ,(or item-var item)
1074                                                      (funcall ,(or key '#'identity) ,elt-var))
1075                                             (return ,elt-var)))))
1076            (let ((find-function (if test-not 'find-positional-test-not-key 'find-positional-test-key))
1077                  (item-var (gensym))
1078                  (sequence-var (gensym))
1079                  (test-var (gensym))
1080                  (key-var (gensym)))
1081              `(let ((,item-var ,item)
1082                     (,sequence-var ,sequence)
1083                     (,test-var ,(or test test-not))
1084                     (,key-var ,key))
1085                 (declare (dynamic-extent ,item-var ,sequence-var ,test-var ,key-var))
1086                 (,find-function ,item-var ,sequence-var ,test-var ,key-var)))))
1087        call))
1088      call))
1089
1090;;; expand position-if and position-if-not
1091
1092(define-compiler-macro position-if (&whole call &environment env
1093                                           test sequence &rest keys)
1094  `(position ,test ,sequence
1095             :test #'funcall
1096             ,@keys))
1097
1098(define-compiler-macro position-if-not (&whole call &environment env
1099                                               test sequence &rest keys)
1100  `(position ,test ,sequence
1101             :test-not #'funcall
1102             ,@keys))
1103
1104;;; inline some cases, and use positional functions for others
1105
1106(define-compiler-macro position (&whole call &environment env
1107                                        item sequence &rest keys)
1108  (if (constant-keywords-p keys)
1109    (destructuring-bind (&key from-end test test-not (start 0) end key) keys
1110      (if (and (eql start 0)
1111               (null end)
1112               (null from-end)
1113               (not (and test test-not)))
1114        (let ((position-test (or test test-not '#'eql))
1115              (loop-test (if test-not 'unless 'when))
1116              (sequence-value (if (constantp sequence)
1117                                (eval-constant sequence)
1118                                sequence)))
1119          (cond ((nx-form-typep sequence-value 'list env)
1120                 (let ((item-var (unless (or (constantp item)
1121                                             (and (equal position-test '#'funcall)
1122                                                  (function-form-p item)))
1123                                   (gensym)))
1124                       (elt-var (gensym))
1125                       (position-var (gensym)))
1126                   `(let (,@(when item-var `((,item-var ,item)))
1127                          (,position-var 0))
1128                      (dolist (,elt-var ,sequence)
1129                        (,loop-test (funcall ,position-test ,(or item-var item)
1130                                             (funcall ,(or key '#'identity) ,elt-var))
1131                                    (return ,position-var))
1132                        (incf ,position-var)))))
1133                ((nx-form-typep sequence-value 'vector env)
1134                 (let ((item-var (unless (or (constantp item)
1135                                             (and (equal position-test '#'funcall)
1136                                                  (function-form-p item)))
1137                                   (gensym)))
1138                       (sequence-var (gensym))
1139                       (position-var (gensym)))
1140                   `(let (,@(when item-var `((,item-var ,item)))
1141                          (,sequence-var ,sequence))
1142                      ,@(let ((type (nx-form-type sequence env)))
1143                          (unless (eq type t)
1144                            `((declare (type ,type ,sequence-var)))))
1145                      (dotimes (,position-var (length ,sequence-var))
1146                        (,loop-test (funcall ,position-test ,(or item-var item)
1147                                             (funcall ,(or key '#'identity)
1148                                                      (locally (declare (optimize (speed 3) (safety 0)))
1149                                                        (aref ,sequence ,position-var))))
1150                                    (return ,position-var))))))
1151                (t
1152                 (let ((position-function (if test-not
1153                                            'position-positional-test-not-key
1154                                            'position-positional-test-key))
1155                       (item-var (gensym))
1156                       (sequence-var (gensym))
1157                       (test-var (gensym))
1158                       (key-var (gensym)))
1159                   `(let ((,item-var ,item)
1160                          (,sequence-var ,sequence)
1161                          (,test-var ,(or test test-not))
1162                          (,key-var ,key))
1163                      (declare (dynamic-extent ,sequence-var ,test-var ,key-var))
1164                      (,position-function ,item-var ,sequence-var ,test-var ,key-var))))))
1165        call))
1166    call))
1167
1168;;; inline some cases of remove-if and remove-if-not
1169
1170(define-compiler-macro remove-if (&whole call &environment env &rest ignore)
1171  (declare (ignore ignore))
1172  (remove-if-transform call env))
1173
1174(define-compiler-macro remove-if-not (&whole call &environment env &rest ignore)
1175  (declare (ignore ignore))
1176  (remove-if-transform call env))
1177
1178(defun remove-if-transform (call env)
1179  (destructuring-bind (function test sequence &rest keys) call
1180    (if (constant-keywords-p keys)
1181      (destructuring-bind (&key from-end (start 0) end count (key '#'identity)) keys
1182        (if (and (eql start 0)
1183                 (null end)
1184                 (null from-end)
1185                 (null count)
1186                 (nx-form-typep sequence 'list env))
1187          ;; only do the list case, since it's hard to collect vector results
1188          (let ((temp-var (gensym))
1189                (result-var (gensym))
1190                (elt-var (gensym))
1191                (loop-test (ecase function (remove-if 'unless) (remove-if-not 'when))))
1192            `(the list
1193               (let* ((,temp-var (cons nil nil))
1194                      (,result-var ,temp-var))
1195                 (declare (dynamic-extent ,temp-var))
1196                 (dolist (,elt-var ,sequence (%cdr ,result-var))
1197                   (,loop-test (funcall ,test (funcall ,key ,elt-var))
1198                               (setq ,temp-var
1199                                     (%cdr
1200                                      (%rplacd ,temp-var (list ,elt-var)))))))))
1201          call))
1202      call)))
1203
1204
1205
1206(define-compiler-macro struct-set (&whole call &environment env struct offset new)
1207  (if (nx-inhibit-safety-checking env)
1208    `(%svset ,struct ,offset ,new)
1209    call))
1210
1211(define-compiler-macro zerop (arg &environment env)
1212  (let* ((z (if (nx-form-typep arg 'float env)
1213              (coerce 0 (nx-form-type arg env))
1214              0)))
1215    `(= ,arg ,z)))
1216
1217
1218(define-compiler-macro = (&whole w n0 &optional (n1 nil n1p) &rest more)
1219  (if (not n1p)
1220    `(require-type ,n0 'number)
1221    (if more
1222      w
1223      `(=-2 ,n0 ,n1))))
1224
1225(define-compiler-macro /= (&whole w n0 &optional (n1 nil n1p) &rest more)
1226  (if (not n1p)
1227    `(require-type ,n0 'number)
1228    (if more
1229      w
1230      `(/=-2 ,n0 ,n1))))
1231
1232(define-compiler-macro + (&whole w  &environment env &optional (n0 nil n0p) (n1 nil n1p) &rest more)
1233  (if more
1234    `(+ (+-2 ,n0 ,n1) ,@more)
1235    (if n1p
1236      `(+-2 ,n0 ,n1)
1237      (if n0p
1238        `(require-type ,n0 'number)
1239        0))))
1240
1241(define-compiler-macro - (&whole w &environment env n0 &optional (n1 nil n1p) &rest more)
1242  (if more
1243    `(- (--2 ,n0 ,n1) ,@more)
1244    (if n1p
1245      `(--2 ,n0 ,n1)
1246      `(%negate ,n0))))
1247
1248(define-compiler-macro * (&whole w &environment env &optional (n0 nil n0p) (n1 nil n1p) &rest more)
1249  (if more
1250    (let ((type (nx-form-type w env)))
1251      (if (and type (numeric-type-p type)) ; go pairwise if type known, else not
1252        `(*-2 ,n0 (* ,n1 ,@more))
1253        w))
1254    (if n1p
1255      `(*-2 ,n0 ,n1)
1256      (if n0p
1257        `(require-type ,n0 'number)
1258        1))))
1259
1260(define-compiler-macro / (&whole w n0 &optional (n1 nil n1p) &rest more)
1261  (if more
1262    w
1263    (if n1p
1264      `(/-2 ,n0 ,n1)
1265      `(%quo-1 ,n0))))
1266
1267;;; beware of limits - truncate of most-negative-fixnum & -1 ain't a
1268;;; fixnum - too bad
1269(define-compiler-macro truncate (&whole w &environment env n0 &optional (n1 nil n1p))
1270  (let ((*nx-form-type* t))
1271    (if (nx-form-typep n0 'fixnum env)
1272      (if (not n1p)
1273        n0
1274        (if (nx-form-typep n1 'fixnum env)
1275          `(%fixnum-truncate ,n0 ,n1)
1276          w))
1277      w)))
1278
1279(define-compiler-macro floor (&whole w &environment env n0 &optional (n1 nil n1p))
1280  (let ((*nx-form-type* t))
1281    (if (nx-form-typep n0 'fixnum env)
1282      (if (not n1p)
1283        n0
1284        (if (nx-form-typep n1 'fixnum env)
1285          `(%fixnum-floor ,n0 ,n1)
1286          w))
1287      w)))
1288
1289(define-compiler-macro round (&whole w &environment env n0 &optional (n1 nil n1p))
1290  (let ((*nx-form-type* t)) ; it doesn't matter what the result type is declared to be
1291    (if (nx-form-typep n0 'fixnum env)
1292      (if (not n1p)
1293        n0
1294        (if (nx-form-typep n1 'fixnum env)
1295          `(%fixnum-round ,n0 ,n1)
1296          w))
1297      w)))
1298
1299(define-compiler-macro ceiling (&whole w &environment env n0 &optional (n1 nil n1p))
1300  (let ((*nx-form-type* t))
1301    (if (nx-form-typep n0 'fixnum env)
1302      (if (not n1p)
1303        n0
1304        (if (nx-form-typep n1 'fixnum env)
1305          `(%fixnum-ceiling ,n0 ,n1)
1306          w))
1307      w)))
1308
1309(define-compiler-macro oddp (&whole w &environment env n0)
1310  (if (nx-form-typep n0 'fixnum env)
1311    `(logbitp 0 (the fixnum ,n0))
1312    w))
1313
1314(define-compiler-macro evenp (&whole w &environment env n0)
1315  (if (nx-form-typep n0 'fixnum env)
1316    `(not (logbitp 0 (the fixnum ,n0)))
1317    w))
1318
1319
1320(define-compiler-macro logandc2 (n0 n1)
1321  (let ((n1var (gensym))
1322        (n0var (gensym)))
1323    `(let ((,n0var ,n0)
1324           (,n1var ,n1))
1325       (logandc1 ,n1var ,n0var))))
1326
1327(define-compiler-macro logorc2 (n0 n1)
1328  (let ((n1var (gensym))
1329        (n0var (gensym)))
1330    `(let ((,n0var ,n0)
1331           (,n1var ,n1))
1332       (logorc1 ,n1var ,n0var))))
1333
1334(define-compiler-macro lognand (n0 n1)
1335  `(lognot (logand ,n0 ,n1)))
1336
1337(define-compiler-macro lognor (n0 n1)
1338  `(lognot (logior ,n0 ,n1)))
1339
1340
1341(defun transform-logop (whole identity binop &optional (transform-complement t))
1342  (destructuring-bind (op &optional (n0 nil n0p) (n1 nil n1p) &rest more) whole
1343    (if (and n1p (eql n0 identity))
1344      `(,op ,n1 ,@more)
1345      (if (and transform-complement n1p (eql n0 (lognot identity)))
1346        `(progn
1347           (,op ,n1 ,@more)
1348           ,(lognot identity))
1349        (if more
1350          (if (cdr more)
1351            whole
1352            `(,binop ,n0 (,binop ,n1 ,(car more))))
1353          (if n1p
1354            `(,binop ,n0 ,n1)
1355            (if n0p
1356              `(require-type ,n0 'integer)
1357              identity)))))))
1358
1359(define-compiler-macro logand (&whole w &rest all)
1360  (declare (ignore all))
1361  (transform-logop w -1 'logand-2))
1362
1363(define-compiler-macro logior (&whole w &rest all)
1364  (declare (ignore all))
1365  (transform-logop w 0 'logior-2))
1366
1367(define-compiler-macro logxor (&whole w &rest all)
1368  (declare (ignore all))
1369  (transform-logop w 0 'logxor-2 nil))
1370
1371(define-compiler-macro lognot (&whole w &environment env n1)
1372  (if (nx-form-typep n1 'fixnum env)
1373    `(%ilognot ,n1)
1374    w))
1375
1376(define-compiler-macro logtest (&whole w &environment env n1 n2)
1377  (if (and (nx-form-typep n1 'fixnum env)
1378           (nx-form-typep n2 'fixnum env))
1379    `(not (eql 0 (logand ,n1 ,n2)))
1380    w))
1381
1382
1383(defmacro defsynonym (from to)
1384  ;Should maybe check for circularities.
1385  `(progn
1386     (setf (compiler-macro-function ',from) nil)
1387     (let ((pair (assq ',from *nx-synonyms*)))
1388       (if pair (rplacd pair ',to)
1389           (push (cons ',from ',to)
1390                 *nx-synonyms*))
1391       ',to)))
1392
1393(defsynonym first car)
1394(defsynonym second cadr)
1395(defsynonym third caddr)
1396(defsynonym fourth cadddr)
1397(defsynonym rest cdr)
1398
1399
1400(defsynonym functionp lfunp)
1401(defsynonym null not)
1402(defsynonym char-int char-code)
1403
1404;;; Improvemets file by Bob Cassels
1405;;; Just what are "Improvemets", anyway ?
1406
1407;;; Optimize some CL sequence functions, mostly by inlining them in
1408;;; simple cases when the type of the sequence is known.  In some
1409;;; cases, dynamic-extent declarations are automatically inserted.
1410;;; For some sequence functions, if the type of the sequence is known
1411;;; at compile time, the function is inlined.  If the type isn't known
1412;;; but the call is "simple", a call to a faster (positional-arg)
1413;;; function is substituted.
1414
1415
1416(defun nx-form-sequence-iterator (sequence-form env)
1417  (cond ((nx-form-typep sequence-form 'vector env) 'dovector)
1418        ((nx-form-typep sequence-form 'list env) 'dolist)))
1419
1420(defun function-form-p (form)
1421   ;; c.f. quoted-form-p
1422   (and (consp form)
1423        (eq (%car form) 'function)
1424        (consp (%cdr form))
1425        (null (%cdr (%cdr form)))))
1426
1427
1428;; Return a form that checks to see if THING is if type CTYPE, or
1429;; NIL if we can't do that for some reason.
1430(defun optimize-ctypep (thing ctype)
1431  (when (eq *target-backend* *host-backend*)
1432    (typecase ctype
1433      (numeric-ctype
1434       (cond ((eq :real (numeric-ctype-complexp ctype))
1435              (let* ((low (numeric-ctype-low ctype))
1436                     (high (numeric-ctype-high ctype))
1437                     (class (numeric-ctype-class ctype))
1438                     (format (numeric-ctype-format ctype))
1439                     (type (if (eq class 'float)
1440                             (or format class)
1441                             (or class 'real))))
1442                (cond ((and low (eql low high) (or (not (eq class 'float))
1443                                                   format))
1444                       `(eql ,thing ,low))
1445                      ((and (eq type 'float)
1446                            (or low high)
1447                            (or (null low)
1448                                (typep low 'single-float)
1449                                (not (null (ignore-errors
1450                                             (coerce (if (atom low)
1451                                                       low
1452                                                       (car low))
1453                                                     'single-float)))))
1454                            (or (null high)
1455                                (typep high 'single-float)
1456                                (not (null (ignore-errors
1457                                             (coerce (if (atom high)
1458                                                       high
1459                                                       (car high))
1460                                                     'single-float))))))
1461                       (let* ((temp (gensym)))
1462                         (flet ((bounded-float (type low high)
1463                                  `(,type
1464                                    ,(if low
1465                                         (if (listp low)
1466                                           (list (coerce (car low) type))
1467                                           (coerce low type))
1468                                         '*)
1469                                    ,(if high
1470                                         (if (listp high)
1471                                           (list (coerce (car high) type))
1472                                           (coerce high type))
1473                                         '*))))
1474                         `(let* ((,temp ,thing))
1475                           (or (typep ,temp ',(bounded-float 'single-float low high))
1476                            (typep ,temp ',(bounded-float 'double-float low high)))))))
1477                      (t
1478                       (let* ((temp (gensym)))
1479                         (if (and (typep low 'fixnum) (typep high 'fixnum)
1480                                  (eq class 'integer))
1481                           (setq type 'fixnum))
1482                         (if (or low high)
1483                           `(let* ((,temp ,thing))
1484                             (and (typep ,temp ',type)
1485                              ,@(if low `((,(if (consp low) '> '>=) (the ,type ,temp) ,(if (consp low) (car low) low))))
1486                              ,@(if high `((,(if (consp high) '< '<=) (the ,type ,temp) ,(if (consp high) (car high) high))))))
1487                           `(typep ,thing ',type)))))))
1488             (t `(numeric-%%typep ,thing ,ctype))))
1489      (array-ctype
1490       (or
1491        (let* ((typecode (array-ctype-typecode ctype))
1492               (dims (array-ctype-dimensions ctype)))
1493          (cond ((and typecode (consp dims) (null (cdr dims)))
1494                 (case (array-ctype-complexp ctype)
1495                   ((nil)
1496                    (if (eq (car dims) '*)
1497                      `(eql (typecode ,thing) ,typecode)
1498                      (let* ((temp (gensym)))
1499                        `(let* ((,temp ,thing))
1500                          (and (eql (typecode ,temp) ,typecode)
1501                           (eq (uvsize ,temp) ,(car dims)))))))
1502                   ((* :maybe)
1503                    (let* ((temp (gensym))
1504                           (tempcode (gensym)))
1505                      `(let* ((,temp ,thing)
1506                              (,tempcode (typecode ,temp)))
1507                        (or (and (eql ,tempcode ,typecode)
1508                             ,@(unless (eq (car dims) '*)
1509                                       `((eq (uvsize ,temp) ,(car dims)))))
1510                         (and (eql ,tempcode target::subtag-vectorH)
1511                          (eql (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref ,temp target::arrayH.flags-cell))) ,typecode)
1512                          ,@(unless (eq (car dims) '*)
1513                                    `((eq (%svref ,temp target::vectorH.logsize-cell) ,(car dims)))))))))))))
1514        `(values (array-%%typep ,thing ,ctype)))))))
1515
1516
1517
1518(defun optimize-typep (thing type env)
1519  ;; returns a new form, or nil if it can't optimize
1520  (let* ((ctype (specifier-type-if-known type env)))
1521    (when ctype
1522      (let* ((type (type-specifier ctype))
1523             (predicate (if (typep type 'symbol) (type-predicate type))))
1524        (if (and predicate (symbolp predicate))
1525          `(,predicate ,thing)
1526          (or (optimize-ctypep thing ctype)
1527              (cond ((symbolp type)
1528                     (cond ((%deftype-expander type)
1529                            ;; recurse here, rather than returning the
1530                            ;; partially-expanded form mostly since it doesn't
1531                            ;; seem to further optimize the result otherwise
1532                            (let ((expanded-type (type-expand type)))
1533                              (or (optimize-typep thing expanded-type env)
1534                                  ;; at least do the first expansion
1535                                  `(typep ,thing ',expanded-type))))
1536                           ((structure-class-p type env)
1537                            `(structure-typep ,thing ',type))
1538                           ((find-class type nil env)
1539                            `(class-cell-typep ,thing (load-time-value (find-class-cell ',type t))))
1540                           ((info-type-builtin type) ; bootstrap troubles here?
1541                            `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type))))
1542                           (t nil)))
1543                    ((consp type)
1544                     (cond
1545                       ((info-type-builtin type) ; byte types
1546                        `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type))))
1547                       (t
1548                        (case (%car type)
1549                          (satisfies `(funcall ',(cadr type) ,thing))
1550                          (eql `(eql ,thing ',(cadr type)))
1551                          (member `(not (null (member ,thing ',(%cdr type)))))
1552                          (not `(not (typep ,thing ',(cadr type))))
1553                          ((or and)
1554                           (let ((thing-sym (gensym)))
1555                             `(let ((,thing-sym ,thing))
1556                               (,(%car type)
1557                                ,@(mapcar #'(lambda (type-spec)
1558                                              (or (optimize-typep thing-sym type-spec env)
1559                                                  `(typep ,thing-sym ',type-spec)))
1560                                          (%cdr type))))))
1561                          ((signed-byte unsigned-byte integer mod) ; more byte types
1562                           `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type))))
1563                          (t nil)))))
1564                    (t nil))))))))
1565
1566(define-compiler-macro typep  (&whole call &environment env thing type &optional e)
1567  (if (quoted-form-p type)
1568    (if (and (constantp thing) (specifier-type-if-known type env))
1569      (typep (if (quoted-form-p thing) (%cadr thing) thing) (%cadr type) env)
1570      (or (and (null e) (optimize-typep thing (%cadr type) env))
1571          call))
1572    (if (eq type t)
1573      `(progn ,thing t)
1574      call)))
1575
1576(define-compiler-macro true (&rest args)
1577  `(progn
1578    ,@args
1579    t))
1580
1581
1582(define-compiler-macro false (&rest args)
1583  `(progn
1584    ,@args
1585    nil))
1586
1587(define-compiler-macro find-class (&whole call type &optional (errorp t) env)
1588  (if (and (quoted-form-p type)(not *dont-find-class-optimize*)(not env))
1589      `(class-cell-find-class (load-time-value (find-class-cell ,type t)) ,errorp)
1590    call))
1591
1592
1593(define-compiler-macro gcd (&whole call &optional (n0 nil n0-p) (n1 nil n1-p) &rest rest)
1594  (if rest
1595    call
1596    (if n1-p
1597      `(gcd-2 ,n0 ,n1)
1598      (if n0-p
1599        `(%integer-abs ,n0)
1600        0))))
1601
1602(define-compiler-macro lcm (&whole call &optional (n0 nil n0-p) (n1 nil n1-p) &rest rest)
1603  (if rest
1604    call
1605    (if n1-p
1606      `(lcm-2 ,n0 ,n1)
1607      (if n0-p
1608        `(%integer-abs ,n0)
1609        1))))
1610
1611(define-compiler-macro max (&whole call &environment env n0 &optional (n1 nil n1-p) &rest rest)
1612  (if rest
1613    call
1614    (if n1-p
1615      (if (and (nx-form-typep n0 'fixnum env)(nx-form-typep n1 'fixnum env))
1616        `(imax-2 ,n0 ,n1)
1617        `(max-2 ,n0 ,n1))
1618      `(require-type ,n0 'real))))
1619
1620(define-compiler-macro max-2 (n0 n1)
1621  (let* ((g0 (gensym))
1622         (g1 (gensym)))
1623   `(let* ((,g0 ,n0)
1624           (,g1 ,n1))
1625      (if (> ,g0 ,g1) ,g0 ,g1))))
1626
1627(define-compiler-macro imax-2 (n0 n1)
1628  (let* ((g0 (gensym))
1629         (g1 (gensym)))
1630   `(let* ((,g0 ,n0)
1631           (,g1 ,n1))
1632      (if (%i> ,g0 ,g1) ,g0 ,g1))))
1633
1634
1635
1636
1637(define-compiler-macro min (&whole call &environment env n0 &optional (n1 nil n1-p) &rest rest)
1638  (if rest
1639    call
1640    (if n1-p
1641      (if (and (nx-form-typep n0 'fixnum env)(nx-form-typep n1 'fixnum env))
1642        `(imin-2 ,n0 ,n1)
1643        `(min-2 ,n0 ,n1))
1644      `(require-type ,n0 'real))))
1645
1646(define-compiler-macro min-2 (n0 n1)
1647  (let* ((g0 (gensym))
1648         (g1 (gensym)))
1649   `(let* ((,g0 ,n0)
1650           (,g1 ,n1))
1651      (if (< ,g0 ,g1) ,g0 ,g1))))
1652
1653(define-compiler-macro imin-2 (n0 n1)
1654  (let* ((g0 (gensym))
1655         (g1 (gensym)))
1656   `(let* ((,g0 ,n0)
1657           (,g1 ,n1))
1658      (if (%i< ,g0 ,g1) ,g0 ,g1))))
1659
1660
1661(defun eq-test-p (test)
1662  (or (equal test ''eq) (equal test '#'eq)))
1663
1664(defun eql-test-p (test)
1665  (or (equal test ''eql) (equal test '#'eql)))
1666
1667(define-compiler-macro adjoin (&whole whole elt list &rest keys)
1668  (if (constant-keywords-p keys)
1669    (destructuring-bind (&key (test ''eql) test-not key) keys
1670      (or (and (null test-not)
1671               (null key)
1672               (cond ((eq-test-p test)
1673                      `(adjoin-eq ,elt ,list))
1674                     ((eql-test-p test)
1675                      `(adjoin-eql ,elt ,list))
1676                     (t nil)))
1677          whole))
1678    whole))
1679
1680(define-compiler-macro union (&whole whole list1 list2 &rest keys)
1681  (if (constant-keywords-p keys)
1682    (destructuring-bind (&key (test ''eql) test-not key) keys
1683      (or (and (null test-not)
1684               (null key)
1685               (cond ((eq-test-p test)
1686                      `(union-eq ,list1 ,list2))
1687                     ((eql-test-p test)
1688                      `(union-eql ,list1 ,list2))
1689                     (t nil)))
1690          whole))
1691    whole))
1692
1693(define-compiler-macro slot-value (&whole whole &environment env
1694                                          instance slot-name-form)
1695  (declare (ignore env))
1696  (let* ((name (and (quoted-form-p slot-name-form)
1697                    (typep (cadr slot-name-form) 'symbol)
1698                    (cadr slot-name-form))))
1699    (if name
1700      `(slot-id-value ,instance (load-time-value (ensure-slot-id ',name)))
1701      whole)))
1702
1703
1704(define-compiler-macro set-slot-value (&whole whole &environment env
1705                                          instance slot-name-form value-form)
1706  (declare (ignore env))
1707  (let* ((name (and (quoted-form-p slot-name-form)
1708                    (typep (cadr slot-name-form) 'symbol)
1709                    (cadr slot-name-form))))
1710    (if name
1711      `(set-slot-id-value
1712        ,instance
1713        (load-time-value (ensure-slot-id ',name))
1714        ,value-form)
1715      whole)))
1716
1717
1718
1719
1720(defsynonym %get-unsigned-byte %get-byte)
1721(defsynonym %get-unsigned-word %get-word)
1722(defsynonym %get-signed-long %get-long)
1723
1724
1725
1726
1727(define-compiler-macro arrayp (arg)
1728  `(>= (the fixnum (typecode ,arg))
1729    ,(nx-lookup-target-uvector-subtag :array-header)))
1730
1731(define-compiler-macro vectorp (arg)
1732  `(>= (the fixnum (typecode ,arg))
1733    ,(nx-lookup-target-uvector-subtag :vector-header)))
1734
1735
1736
1737(define-compiler-macro fixnump (arg)
1738  (let* ((fixnum-tag
1739          (arch::target-fixnum-tag (backend-target-arch *target-backend*))))
1740    `(eql (lisptag ,arg) ,fixnum-tag)))
1741
1742
1743
1744(define-compiler-macro double-float-p (n)
1745  (let* ((tag (arch::target-double-float-tag (backend-target-arch *target-backend*))))
1746    `(eql (typecode ,n) ,tag)))
1747
1748
1749(define-compiler-macro short-float-p (n)
1750  (let* ((arch (backend-target-arch *target-backend*))
1751         (tag (arch::target-single-float-tag arch))
1752         (op (if (arch::target-single-float-tag-is-subtag arch)
1753               'typecode
1754               'fulltag)))
1755    `(eql (,op ,n) ,tag)))
1756
1757
1758(define-compiler-macro floatp (n)
1759  (let* ((typecode (make-symbol "TYPECODE"))
1760         (arch (backend-target-arch *target-backend*))
1761         (single (arch::target-single-float-tag arch))
1762         (double (arch::target-double-float-tag arch)))
1763    `(let* ((,typecode (typecode ,n)))
1764       (declare (fixnum ,typecode))
1765       (or (= ,typecode ,single)
1766           (= ,typecode ,double)))))
1767
1768(define-compiler-macro functionp (n)
1769  (let* ((arch (backend-target-arch *target-backend*))
1770         (tag (arch::target-function-tag arch))
1771         (op (if (arch::target-function-tag-is-subtag arch)
1772               'typecode
1773               'fulltag)))
1774    `(eql (,op  ,n) ,tag)))
1775
1776(define-compiler-macro symbolp (s)
1777  (let* ((arch (backend-target-arch *target-backend*))
1778         (symtag (arch::target-symbol-tag arch))
1779         (op (if (arch::target-symbol-tag-is-subtag arch)
1780               'typecode
1781               'fulltag))
1782         (niltag (arch::target-null-tag arch)))
1783    (if (eql niltag symtag)
1784      `(eql (,op ,s) ,symtag)
1785      (let* ((sym (gensym)))
1786        `(let* ((,sym ,s))
1787          (if ,sym (eql (,op ,sym) ,symtag) t))))))
1788
1789;;; If NIL isn't tagged as a symbol, assume that LISPTAG only looks
1790;;; at bits that NIL shares with a cons.
1791(define-compiler-macro listp (n)
1792  (let* ((arch (backend-target-arch *target-backend*))
1793         (cons-tag (arch::target-cons-tag arch))
1794         (nil-tag  (arch::target-null-tag arch))
1795         (symbol-tag (arch::target-symbol-tag arch)))
1796    (if (= nil-tag symbol-tag)
1797      (let* ((nvar (gensym)))
1798        `(let* ((,nvar ,n))
1799          (if ,nvar (consp ,nvar) t)))
1800      `(eql (lisptag ,n) ,cons-tag))))
1801
1802(define-compiler-macro consp (&whole call n)
1803  (let* ((arch (backend-target-arch *target-backend*))
1804         (cons-tag (arch::target-cons-tag arch))
1805         (nil-tag (arch::target-null-tag arch)))
1806    (if (= nil-tag cons-tag)
1807      call
1808      `(eql (fulltag ,n) ,cons-tag))))
1809
1810(define-compiler-macro bignump (n)
1811  `(eql (typecode ,n) ,(nx-lookup-target-uvector-subtag :bignum)))
1812
1813(define-compiler-macro ratiop (n)
1814  `(eql (typecode ,n) ,(nx-lookup-target-uvector-subtag :ratio)))
1815
1816(define-compiler-macro complexp (n)
1817  `(eql (typecode ,n) ,(nx-lookup-target-uvector-subtag :complex)))
1818
1819(define-compiler-macro macptrp (n)
1820  `(eql (typecode ,n) ,(nx-lookup-target-uvector-subtag :macptr)))
1821
1822(define-compiler-macro basic-stream-p (n)
1823  `(eql (typecode ,n) ,(nx-lookup-target-uvector-subtag :basic-stream)))
1824
1825(define-compiler-macro aref (&whole call a &rest subscripts &environment env)
1826  (let* ((ctype (if (nx-form-typep a 'array env)
1827                  (specifier-type (nx-form-type a env) env)))
1828         (type (if ctype (type-specifier (array-ctype-specialized-element-type ctype))))
1829         (useful (unless (or (eq type *) (eq type t))
1830                   type)))
1831    (if (= 2 (length subscripts))
1832      (setq call `(%aref2 ,a ,@subscripts))
1833      (if (= 3 (length subscripts))
1834        (setq call `(%aref3 ,a ,@subscripts))))
1835    (if useful
1836      `(the ,useful ,call)
1837      call)))
1838
1839
1840(define-compiler-macro aset (&whole call a &rest subs&val)
1841  (if (= 3 (length subs&val))
1842    `(%aset2 ,a ,@subs&val)
1843    (if (= 4 (length subs&val))
1844      `(%aset3 ,a ,@subs&val)
1845      call)))
1846
1847
1848(define-compiler-macro make-sequence (&whole call &environment env typespec len &rest keys &key initial-element)
1849  (declare (ignore typespec len keys initial-element))
1850  call)
1851
1852(define-compiler-macro make-string (&whole call size &rest keys)
1853  (if (constant-keywords-p keys)
1854    (destructuring-bind (&key (element-type () element-type-p)
1855                              (initial-element () initial-element-p))
1856                        keys
1857      (if (and element-type-p
1858               (quoted-form-p element-type))
1859        (let* ((element-type (cadr element-type)))
1860          (if (subtypep element-type 'base-char)
1861            `(allocate-typed-vector :simple-string ,size ,@(if initial-element-p `(,initial-element)))
1862            call))
1863        (if (not element-type-p)
1864          `(allocate-typed-vector :simple-string ,size ,@(if initial-element-p `(,initial-element)))
1865          call)))
1866    call))
1867
1868(define-compiler-macro make-string-output-stream (&whole whole &rest keys)
1869  (if (null keys)
1870    '(make-simple-string-output-stream)
1871    whole))
1872
1873
1874(define-compiler-macro sbit (&environment env &whole call v &optional sub0 &rest others)
1875  (if (and sub0 (null others))
1876    `(aref (the simple-bit-vector ,v) ,sub0)
1877    call))
1878
1879(define-compiler-macro %sbitset (&environment env &whole call v sub0 &optional (newval nil newval-p) &rest newval-was-really-sub1)
1880  (if (and newval-p (not newval-was-really-sub1) )
1881    `(setf (aref (the simple-bit-vector ,v) ,sub0) ,newval)
1882    call))
1883
1884(define-compiler-macro simple-base-string-p (thing)
1885  `(= (the fixnum (typecode ,thing)) ,(nx-lookup-target-uvector-subtag :simple-string)))
1886
1887(define-compiler-macro simple-string-p (thing)
1888  `(simple-base-string-p ,thing))
1889
1890(define-compiler-macro stringp (thing)
1891  `(base-string-p  ,thing))
1892
1893(define-compiler-macro base-string-p (thing)
1894  (let* ((gthing (gensym))
1895         (gtype (gensym)))
1896    `(let* ((,gthing ,thing)
1897            (,gtype (typecode ,gthing)))
1898      (declare (type (unsigned-byte 8) ,gtype))
1899      (if (= ,gtype ,(nx-lookup-target-uvector-subtag :vector-header))
1900        (= (the (unsigned-byte 8)
1901             (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref ,gthing target::arrayH.flags-cell))))
1902           ,(nx-lookup-target-uvector-subtag :simple-string))
1903        (= ,gtype ,(nx-lookup-target-uvector-subtag :simple-string))))))
1904
1905
1906
1907(defsetf %misc-ref %misc-set)
1908
1909(define-compiler-macro lockp (lock)
1910  (let* ((tag (nx-lookup-target-uvector-subtag :lock)))
1911    `(eq ,tag (typecode ,lock))))
1912
1913(define-compiler-macro integerp (thing)
1914  (let* ((typecode (gensym))
1915         (fixnum-tag (arch::target-fixnum-tag (backend-target-arch *target-backend*)))
1916         (bignum-tag (nx-lookup-target-uvector-subtag :bignum)))
1917    `(let* ((,typecode (typecode ,thing)))
1918      (declare (fixnum ,typecode))
1919      (if (= ,typecode ,fixnum-tag)
1920        t
1921        (= ,typecode ,bignum-tag)))))
1922
1923(define-compiler-macro %composite-pointer-ref (size pointer offset)
1924  (if (constantp size)
1925    `(%inc-ptr ,pointer ,offset)
1926    `(progn
1927      ,size
1928      (%inc-ptr ,pointer ,offset))))
1929
1930
1931(define-compiler-macro char= (&whole call ch &optional (other nil other-p) &rest others)
1932  (if (null others)
1933    (if other-p
1934      `(eq (char-code ,ch) (char-code ,other))
1935      `(progn (char-code ,ch) t))
1936    (if (null (cdr others))
1937      (let* ((third (car others))
1938             (code (gensym)))
1939        `(let* ((,code (char-code ,ch)))
1940          (and (eq ,code (setq ,code (char-code ,other)))
1941           (eq ,code (char-code ,third)))))
1942      call)))
1943
1944(define-compiler-macro char-equal (&whole call ch &optional (other nil other-p) &rest others)
1945  (if (null others)
1946    (if other-p
1947      `(eq (%char-code (char-upcase ,ch)) (%char-code (char-upcase ,other)))
1948      `(progn (char-code ,ch) t))
1949    (if (null (cdr others))
1950      (let* ((third (car others))
1951             (code (gensym))
1952             (code2 (gensym))
1953             (code3 (gensym)))
1954        `(let* ((,code (%char-code (char-upcase ,ch)))
1955                (,code2 (%char-code (char-upcase ,other)))
1956                (,code3 (%char-code (char-upcase ,third))))
1957          (and (eq ,code ,code2)
1958           (eq ,code2 ,code3))))
1959      call)))
1960
1961(define-compiler-macro char/= (&whole call ch &optional (other nil other-p) &rest others)
1962  (if (null others)
1963    (if other-p
1964      `(not (eq (char-code ,ch) (char-code ,other)))
1965      `(progn (char-code ,ch) t))
1966    call))
1967
1968
1969(define-compiler-macro char< (&whole call ch &optional (other nil other-p) &rest others)
1970  (if (null others)
1971    (if other-p
1972      `(< (the fixnum (char-code ,ch)) (the fixnum (char-code ,other)))
1973      `(progn (char-code ,ch) t))
1974    (if (null (cdr others))
1975      (let* ((third (car others))
1976             (code (gensym))
1977             (code2 (gensym))
1978             (code3 (gensym)))
1979        `(let* ((,code (char-code ,ch))
1980                (,code2 (char-code ,other))
1981                (,code3 (char-code ,third)))
1982          (declare (fixnum ,code ,code2 ,code3))
1983          (and (< ,code ,code2)
1984           (< ,code2 ,code3))))
1985      call)))
1986
1987(define-compiler-macro char<= (&whole call ch &optional (other nil other-p) &rest others)
1988  (if (null others)
1989    (if other-p
1990      `(<= (the fixnum (char-code ,ch)) (the fixnum (char-code ,other)))
1991      `(progn (char-code ,ch) t))
1992    (if (null (cdr others))
1993      (let* ((third (car others))
1994             (code (gensym))
1995             (code2 (gensym))
1996             (code3 (gensym)))
1997        `(let* ((,code (char-code ,ch))
1998                (,code2 (char-code ,other))
1999                (,code3 (char-code ,third)))
2000          (declare (fixnum ,code ,code2 ,code3))
2001          (and (<= ,code ,code2)
2002           (<= ,code2 ,code3))))
2003      call)))
2004
2005(define-compiler-macro char> (&whole call ch &optional (other nil other-p) &rest others)
2006  (if (null others)
2007    (if other-p
2008      `(> (the fixnum (char-code ,ch)) (the fixnum (char-code ,other)))
2009      `(progn (char-code ,ch) t))
2010    (if (null (cdr others))
2011      (let* ((third (car others))
2012             (code (gensym))
2013             (code2 (gensym))
2014             (code3 (gensym)))
2015        `(let* ((,code (char-code ,ch))
2016                (,code2 (char-code ,other))
2017                (,code3 (char-code ,third)))
2018          (declare (fixnum ,code ,code2 ,code3))
2019          (and (> ,code ,code2)
2020           (> ,code2 ,code3))))
2021      call)))
2022
2023(define-compiler-macro char>= (&whole call ch &optional (other nil other-p) &rest others)
2024  (if (null others)
2025    (if other-p
2026      `(>= (the fixnum (char-code ,ch)) (the fixnum (char-code ,other)))
2027      `(progn (char-code ,ch) t))
2028    (if (null (cdr others))
2029      (let* ((third (car others))
2030             (code (gensym))
2031             (code2 (gensym))
2032             (code3 (gensym)))
2033        `(let* ((,code (char-code ,ch))
2034                (,code2 (char-code ,other))
2035                (,code3 (char-code ,third)))
2036          (declare (fixnum ,code ,code2 ,code3))
2037          (and (>= ,code ,code2)
2038           (>= ,code2 ,code3))))
2039      call)))
2040
2041(define-compiler-macro float (&whole call number &optional (other 0.0f0 other-p) &environment env)
2042
2043  (cond ((and (typep other 'single-float)
2044              (nx-form-typep number 'double-float env))
2045         `(the single-float (%double-to-single ,number)))
2046        ((and (typep other 'double-float)
2047              (nx-form-typep number 'single-float env))
2048         `(the double-float (%single-to-double ,number)))
2049        ((and other-p (typep other 'single-float))
2050         `(the single-float (%short-float ,number)))
2051        ((typep other 'double-float)
2052         `(the double-float (%double-float ,number)))
2053        ((null other-p)
2054         (let* ((temp (gensym)))
2055           `(let* ((,temp ,number))
2056             (if (typep ,temp 'double-float)
2057               ,temp
2058               (the single-float (%short-float ,temp))))))
2059        (t call)))
2060
2061(define-compiler-macro coerce (&whole call thing type)
2062  (if (quoted-form-p type)
2063    (setq type (cadr type)))
2064  (if (ignore-errors (subtypep type 'single-float))
2065    `(float ,thing 0.0f0)
2066    (if (ignore-errors (subtypep type 'double-float))
2067      `(float ,thing 0.0d0)
2068      call)))
2069
2070(define-compiler-macro equal (&whole call x y &environment env)
2071  (if (or (equal-iff-eql-p x env)
2072          (equal-iff-eql-p y env))
2073    `(eql ,x ,y)
2074    call))
2075
2076(define-compiler-macro instance-slots (&whole w instance)
2077  (if (and (constantp instance)
2078           (eql (typecode instance) (nx-lookup-target-uvector-subtag :instance)))
2079    `(instance.slots ,instance)
2080    w))
2081
2082(define-compiler-macro unsigned-byte-p (x)
2083  (if (typep (nx-unquote x) 'unsigned-byte)
2084    t
2085    (let* ((val (gensym)))
2086      `(let* ((,val ,x))
2087        (and (integerp ,val) (not (< ,val 0)))))))
2088
2089(define-compiler-macro register-istruct-cell (&whole w arg)
2090  (if (and (quoted-form-p arg)
2091           (cadr arg)
2092           (typep (cadr arg) 'symbol))
2093    `',(register-istruct-cell (cadr arg))
2094    w))
2095
2096
2097
2098(provide "OPTIMIZERS")
2099
Note: See TracBrowser for help on using the repository browser.