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

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

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