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

Last change on this file since 9357 was 9357, checked in by mb, 11 years ago

Rollback r9356

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