source: trunk/ccl/compiler/optimizers.lisp @ 6473

Last change on this file since 6473 was 6473, checked in by gb, 13 years ago

FLOAT with no protototype argument.

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