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

Last change on this file since 9486 was 9486, checked in by gz, 12 years ago

Propagate r9464 to here so doesn't get lost in back-merge

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