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

Last change on this file since 15575 was 15575, checked in by gb, 7 years ago

Now with fewer stray random characters!

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