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

Last change on this file since 590 was 590, checked in by gb, 17 years ago

Bryan O'Connor's fix to COMP-MAKE-DISPLACED-ARRAY (make displacement explicit.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 56.7 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; Optimizers.lisp - compiler optimizers
17
18(eval-when (eval compile)
19  (require'backquote)
20  (require'lispequ)
21  (require "ARCH"))
22
23(declaim (special *nx-can-constant-fold* *nx-synonyms*))
24
25(defvar *dont-find-class-optimize* nil) ; t means dont
26
27#|
28;;; can-constant-fold had a bug in the way it called #'proclaim-inline
29|#
30
31;;; There seems to be some confusion about what #'proclaim-inline does.
32;;; The value of the alist entry in *nx-proclaimed-inline* indicates
33;;; whether or not the compiler is allowed to use any special knowledge
34;;; about the symbol in question.  That's a necessary but not sufficient
35;;; condition to enable inline expansion; that's governed by declarations
36;;; in the compile-time environment.
37;;; If someone observed a symptom whereby calling CAN-CONSTANT-FOLD
38;;; caused unintended inline-expansion, the bug's elsewhere ...
39;;; The bug is that nx-declared-inline-p calls proclaimed-inline-p
40;;;  which looks at what proclaim-inline sets.  Presumably, that
41;;;  means that someone fixed it because it showed evidence of
42;;;  being broken.
43;;; The two concepts (the compiler should/should not make assumptions about
44;;;  the signature of known functions, the compiler should/should not arrange
45;;;  to keep the lambda expression around) need to be sorted out.
46
47(defun can-constant-fold (names &aux handler inlines)
48  (dolist (name names)
49    (if (atom name)
50      (setq handler nil)
51      (setq handler (cdr name) name (car name)))
52    (when (and handler (not (eq handler 'fold-constant-subforms)))
53      (warn "Unknown constant-fold handler : ~s" handler)
54      (setq handler nil))
55    (let* ((bits (%symbol-bits name)))
56      (declare (fixnum bits))
57      (%symbol-bits name (logior 
58                          (if handler (logior (ash 1 $sym_fbit_fold_subforms) (ash 1 $sym_fbit_constant_fold))
59                              (ash 1 $sym_fbit_constant_fold))
60                          bits)))
61     (push name inlines))
62  '(apply #'proclaim-inline t inlines)
63)
64
65; There's a bit somewhere.
66;This is very partial.  Should be a bit somewhere, there are too many of these
67;to keep on a list.
68(can-constant-fold '(specfier-type %ilsl %ilsr 1- 1+
69                     byte make-point - / (+ . fold-constant-subforms) (* . fold-constant-subforms) ash character
70                     char-code code-char lsh
71                     (logior . fold-constant-subforms) (logand . fold-constant-subforms)
72                     (logxor . fold-constant-subforms) logcount logorc2 listp consp expt
73                     logorc1 logtest lognand logeqv lognor lognot logandc2 logandc1
74                     numerator denominator ldb-test byte-position byte-size isqrt gcd
75                     floor mod truncate rem round boole max min ldb dpb mask-field deposit-field
76                     length aref svref char schar bit sbit getf identity list-length
77                     car cdr cadr cddr nth nthcdr last load-byte deposit-byte byte-mask
78                     member search count position assoc rassoc integer-length
79                         float not null char-int expt abs))
80
81(defun %binop-cassoc (call)
82  (unless (and (cddr call) (null (cdr (%cddr call))))
83    (return-from %binop-cassoc call))
84  (let ((func (%car call))
85        (arg1 (%cadr call))
86        (arg2 (%caddr call))
87        (val))
88    (cond ((and (fixnump arg1) (fixnump arg2))
89           (funcall func arg1 arg2))
90          ((or (fixnump arg1) (fixnump arg2))
91           (if (fixnump arg2) (psetq arg1 arg2 arg2 arg1))
92           (if (and (consp arg2)
93                    (eq (%car arg2) func)
94                    (cddr arg2)
95                    (null (cdr (%cddr arg2)))
96                    (or (fixnump (setq val (%cadr arg2)))
97                        (fixnump (setq val (%caddr arg2)))))
98             (list func
99                   (funcall func arg1 val)
100                   (if (eq val (%cadr arg2)) (%caddr arg2) (%cadr arg2)))
101             call))
102          (t call))))
103
104(defun fixnumify (args op &aux (len (length args)))
105  (if (eq len 2)
106    (cons op args)
107    (list op (%car args) (fixnumify (%cdr args) op))))
108
109(defun generic-to-fixnum-n (call env op &aux (args (%cdr call)) targs)
110  (block nil
111    (if (and (%i> (length args) 1)
112             (and (nx-trust-declarations env)
113                  (or (neq op '%i+) (subtypep *nx-form-type* 'fixnum))))
114      (if (dolist (arg args t)
115            (if (nx-form-typep arg 'fixnum env)
116              (push arg targs)
117              (return)))
118        (return 
119         (fixnumify (nreverse targs) op))))
120    call))
121
122;True if arg is an alternating list of keywords and args,
123; only recognizes keywords in keyword package.
124; Historical note: this used to try to ensure that the
125; keyword appeared at most once.  Why ? (Even before
126; destructuring, pl-search/getf would have dtrt.)
127(defun constant-keywords-p (keys)
128  (when (plistp keys)
129    (while keys
130      (unless (keywordp (%car keys))
131        (return-from constant-keywords-p nil))
132      (setq keys (%cddr keys)))
133    t))
134
135; return new form if no keys (or if keys constant and specify :TEST {#'eq, #'eql} only.)
136(defun eq-eql-call (x l keys eq-fn  eql-fn env)
137  (flet ((eql-to-eq ()
138           (or (eql-iff-eq-p x env)
139               (and (or (quoted-form-p l) (null l))
140                    (dolist (elt (%cadr l) t)
141                      (when (eq eq-fn 'assq) (setq elt (car elt)))
142                      (when (and (numberp elt) (not (fixnump elt)))
143                        (return nil)))))))
144    (if (null keys)
145      (list (if (eql-to-eq) eq-fn eql-fn) x l)
146      (if (constant-keywords-p keys)
147        (destructuring-bind (&key (test nil test-p)
148                                  (test-not nil test-not-p)
149                                  (key nil key-p))
150                            keys
151          (declare (ignore test-not key))
152          (if (and test-p 
153                   (not test-not-p) 
154                   (not key-p) 
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              (if (or (eq testname 'eq)
162                      (and (eq testname 'eql)
163                           (eql-to-eq)))
164                (list eq-fn x l)
165                (if (and eql-fn (eq testname 'eql))
166                  (list eql-fn x l))))))))))
167
168(defun eql-iff-eq-p (thing env)
169  (if (quoted-form-p thing) (setq thing (%cadr thing))
170      (if (not (self-evaluating-p thing))
171        (return-from eql-iff-eq-p
172                     (nx-form-typep thing
173                                     '(or fixnum
174                                       character symbol 
175                                       (and (not number) (not macptr))) env))))
176  (or (fixnump thing) (and (not (numberp thing)) (not (macptrp thing)))))
177
178(defun fold-constant-subforms (call env)
179    (let* ((constants nil)
180           (forms nil))
181      (declare (list constants forms))
182      (dolist (form (cdr call))
183        (setq form (nx-transform form env))
184        (if (numberp form)
185          (setq constants (%temp-cons form constants))
186          (setq forms (%temp-cons form forms))))
187      (if constants
188        (let* ((op (car call))
189               (constant (if (cdr constants) (handler-case (apply op constants)
190                                               (error (c) (declare (ignore c)) 
191                                                      (return-from fold-constant-subforms (values call t))))
192                             (car constants))))
193          (values (if forms (cons op (cons constant (reverse forms))) constant) t))
194        (values call nil))))
195
196;;; inline some, etc. in some cases
197;;; in all cases, add dynamic-extent declarations
198(defun some-xx-transform (call env)
199  (destructuring-bind (func predicate sequence &rest args) call
200    (multiple-value-bind (func-constant end-value loop-test)
201                         (case func
202                           (some (values $some nil 'when))
203                           (notany (values $notany t 'when))
204                           (every (values $every t 'unless))
205                           (notevery (values $notevery nil 'unless)))
206      (if args
207        (let ((func-sym (gensym))
208              (seq-sym (gensym))
209              (list-sym (gensym)))
210          `(let ((,func-sym ,predicate)
211                 (,seq-sym ,sequence)
212                 (,list-sym (list ,@args)))
213             (declare (dynamic-extent ,func-sym ,list-sym ,seq-sym))
214             (some-xx-multi ,func-constant ,end-value ,func-sym ,seq-sym ,list-sym)))
215        (let ((loop-function (nx-form-sequence-iterator sequence env)))
216          ;; inline if we know the type of the sequence and if
217          ;; the predicate is a lambda expression
218          ;; otherwise, it blows up the code for not much gain
219          (if (and loop-function
220                   (function-form-p predicate)
221                   (lambda-expression-p (second predicate)))
222            (let ((elt-var (gensym)))
223              (case func
224                (some
225                 `(,loop-function (,elt-var ,sequence ,end-value)
226                                  (let ((result (funcall ,predicate ,elt-var)))
227                                    (when result (return result)))))
228                ((every notevery notany)
229                 `(,loop-function (,elt-var ,sequence ,end-value)
230                                  (,loop-test (funcall ,predicate ,elt-var)
231                                              (return ,(not end-value)))))))
232            (let ((func-sym (gensym))
233                  (seq-sym (gensym)))
234              `(let ((,func-sym ,predicate)
235                     (,seq-sym ,sequence))
236                 (declare (dynamic-extent ,func-sym ,seq-sym))
237                 (some-xx-one ,func-constant ,end-value ,func-sym ,seq-sym)))))))))
238
239
240;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
241;
242; The new (roughly alphabetical) order.
243;
244;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
245
246; Compiler macros on functions can assume that their arguments have already been transformed.
247
248
249#| ; two of these too - damn
250(define-compiler-macro * (&whole call &environment env
251                                 &optional (num1 nil num1-p) (num2 nil num2-p)
252                                 &rest more-nums)
253  (if num1-p
254    (if num2-p
255      (if (and (typep num1 'real)
256               (let* ((type (type-of num1)))
257                 (and (nx-form-typep num2 type)
258                      (every #'(lambda (x) (nx-form-typep x type env)) more-nums))))
259        (if (zerop num1)
260          num1
261          (if (= num1 1)
262            (if more-nums
263              `(* ,num2 ,@more-nums)
264              num2)
265            (if (and (fixnump num1)
266                     (typep num1 'unsigned-byte)
267                     (eq (logcount num1) 1)
268                     (null more-nums)
269                     (nx-form-typep num2 'fixnum))
270              `(ash ,num2 ,(1- (integer-length num1)))
271              call)))
272        call)
273      `(require-type ,num1 'number))
274    1))
275|#
276
277
278
279(defun transform-real-n-ary-comparision (whole binary-name)
280  (destructuring-bind (n0 &optional (n1 0 n1-p) &rest more) (cdr whole)
281    (if more
282      whole
283      (if (not n1-p)
284        `(require-type ,n0 'real)
285        `(,binary-name ,n0 ,n1)))))
286
287
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(define-compiler-macro <= (&whole whole &rest ignore)
298  (declare (ignore ignore))
299  (transform-real-n-ary-comparision whole '<=-2))
300
301(define-compiler-macro >= (&whole whole &rest ignore)
302  (declare (ignore ignore))
303  (transform-real-n-ary-comparision whole '>=-2))
304
305
306(define-compiler-macro 1- (x)
307  `(- ,x 1))
308
309(define-compiler-macro 1+ (x)
310  `(+ ,x 1))
311
312(define-compiler-macro append  (&whole call 
313                                       &optional arg0 
314                                       &rest 
315                                       (&whole tail 
316                                               &optional (junk nil arg1-p) 
317                                               &rest more))
318  ;(append (list x y z) A) -> (list* x y z A)
319  (if (and arg1-p
320           (null more)
321           (consp arg0)
322           (eq (%car arg0) 'list))
323    (cons 'list* (append (%cdr arg0) tail))
324    (if (and arg1-p (null more))
325      `(append-2 ,arg0 ,junk)
326      call)))
327
328(define-compiler-macro apply  (&whole call &environment env fn arg0 &rest args)
329  (let ((original-fn fn))
330    (if (and arg0 
331             (null args)
332             (consp fn)
333             (eq (%car fn) 'function)
334             (null (cdr (%cdr fn)))
335             (consp (setq fn (%cadr fn)))
336             (eq (%car fn) 'lambda))
337      (destructuring-bind (lambda-list &body body) (%cdr fn)
338        `(destructuring-bind ,lambda-list ,arg0 ,@body))
339      (let ((last (%car (last (push arg0 args)))))
340        (if (and (consp last) (memq (%car last) '(cons list* list)))
341          (cons (if (eq (%car last) 'list) 'funcall 'apply)
342                (cons
343                 original-fn
344                 (nreconc (cdr (reverse args)) (%cdr last))))
345          call)))))
346
347(define-compiler-macro ash (&whole call &environment env num amt)
348  (cond ((eq amt 0) num)
349        ((and (fixnump amt)
350              (< amt 0)
351              (nx-form-typep num 'fixnum env))
352         `(%iasr ,(- amt) ,num))
353        ((and (fixnump amt)
354              (<= 0 amt 27)
355              (or (nx-form-typep num `(signed-byte ,(- 28 amt)) env)
356                  (and (nx-form-typep num 'fixnum env)
357                       (nx-trust-declarations env)
358                       (subtypep *nx-form-type* 'fixnum))))
359         `(%ilsl ,amt ,num))
360        (t call)))
361
362(define-compiler-macro lsh (&whole call &environment env num amt)
363  (cond ((eq amt 0) num)
364        ((and (fixnump amt)
365              (< amt 0)
366              (nx-form-typep num 'fixnum env))
367         `(%ilsr ,(- amt) ,num))
368        ((and (fixnump amt)
369              (<= 0 amt 27)
370              (or (nx-form-typep num `(unsigned-byte ,(- 28 amt)) env)
371                  (and (nx-form-typep num 'fixnum env)
372                       (nx-trust-declarations env)
373                       (subtypep *nx-form-type* 'fixnum))))
374         `(%ilsl ,amt ,num))
375        (t call)))
376
377(define-compiler-macro assoc (&whole call &environment env item list &rest keys)
378  (or (eq-eql-call item list keys 'assq 'asseql env)
379      call))
380
381(define-compiler-macro caaar (form)
382  `(car (caar ,form)))
383
384(define-compiler-macro caadr (form)
385  `(car (cadr ,form)))
386
387(define-compiler-macro cadar (form)
388  `(car (cdar ,form)))
389
390(define-compiler-macro caddr (form)
391  `(car (cddr ,form)))
392
393(define-compiler-macro cdaar (form)
394  `(cdr (caar ,form)))
395
396(define-compiler-macro cdadr (form)
397  `(cdr (cadr ,form)))
398
399(define-compiler-macro cddar (form)
400  `(cdr (cdar ,form)))
401
402(define-compiler-macro cdddr (form)
403  `(cdr (cddr ,form)))
404
405
406
407
408(define-compiler-macro cons (&whole call &environment env x y &aux dcall ddcall)
409   (if (consp (setq dcall y))
410     (cond
411      ((or (eq (%car dcall) 'list) (eq (%car dcall) 'list*))
412       ;(CONS A (LIST[*] . args)) -> (LIST[*] A . args)
413       (list* (%car dcall) x (%cdr dcall)))
414      ((or (neq (%car dcall) 'cons) (null (cddr dcall)) (cdddr dcall))
415       call)
416      ((null (setq ddcall (%caddr dcall)))
417       ;(CONS A (CONS B NIL)) -> (LIST A B)
418       `(list ,x ,(%cadr dcall)))
419      ((and (consp ddcall)
420            (eq (%car ddcall) 'cons)
421            (eq (list-length ddcall) 3))
422       ;(CONS A (CONS B (CONS C D))) -> (LIST* A B C D)
423       (list* 'list* x (%cadr dcall) (%cdr ddcall)))
424      (t call))
425     call))
426
427(define-compiler-macro dotimes (&whole call (i n &optional result) 
428                                       &body body
429                                       &environment env)
430  (multiple-value-bind (body decls) (parse-body body env)
431    (if (nx-form-typep (setq n (nx-transform n env)) 'fixnum env)
432        (let* ((limit (gensym))
433               (upper (if (constantp n) n most-positive-fixnum))
434               (top (gensym))
435               (test (gensym)))
436          `(let* ((,limit ,n) (,i 0))
437             ,@decls
438             (declare (fixnum ,limit)
439                      (type (integer 0 ,(if (<= upper 0) 0 `(,upper))) ,i)
440                      (unsettable ,i))
441             (block nil
442               (tagbody
443                 (go ,test)
444                 ,top
445                 ,@body
446                 (locally
447                   (declare (settable ,i))
448                   (setq ,i (1+ ,i)))
449                 ,test
450                 (when (< ,i ,limit) (go ,top)))
451               ,result)))
452        call)))
453
454(define-compiler-macro dpb (&whole call &environment env value byte integer)
455  (cond ((and (integerp byte) (> byte 0))
456         (if (integerp value)
457           `(logior ,(dpb value byte 0) (logand ,(lognot byte) ,integer))
458           `(deposit-field (ash ,value ,(byte-position byte)) ,byte ,integer)))
459        ((and (consp byte)
460              (eq (%car byte) 'byte)
461              (eq (list-length (%cdr byte)) 2))
462         `(deposit-byte ,value ,(%cadr byte) ,(%caddr byte) ,integer))
463        (t call)))
464
465(define-compiler-macro eql (&whole call &environment env v1 v2)
466  (if (or (eql-iff-eq-p v1 env) (eql-iff-eq-p v2 env))
467    `(eq ,v1 ,v2)
468    call))
469
470(define-compiler-macro every (&whole call &environment env &rest ignore)
471  (declare (ignore ignore))
472  (some-xx-transform call env))
473
474
475(define-compiler-macro identity (form) form)
476
477(define-compiler-macro if (&whole call test true &optional false &environment env)
478  (multiple-value-bind (test test-win) (nx-transform test env)
479    (multiple-value-bind (true true-win) (nx-transform true env)
480      (multiple-value-bind (false false-win) (nx-transform false env)
481        (if (or (quoted-form-p test) (self-evaluating-p test))
482          (if (eval test) 
483            true
484            false)
485          (if (or test-win true-win false-win)
486            `(if ,test ,true ,false)
487            call))))))
488
489(define-compiler-macro %ilsr (&whole call &environment env shift value)
490  (if (eql shift 0)
491    value
492    (if (eql value 0)
493      `(progn ,shift 0)
494      call)))
495
496
497(define-compiler-macro ldb (&whole call &environment env byte integer)
498   (cond ((and (integerp byte) (> byte 0))
499          (let ((size (byte-size byte))
500                (position (byte-position byte)))
501            (cond ((nx-form-typep integer 'fixnum env)
502                   `(logand ,(byte-mask size)
503                            (ash ,integer ,(- position))))
504                  (t `(load-byte ,size ,position ,integer)))))
505         ((and (consp byte)
506               (eq (%car byte) 'byte)
507               (eq (list-length (%cdr byte)) 2))
508          (let ((size (%cadr byte))
509                (position (%caddr byte)))
510            (if (and (nx-form-typep integer 'fixnum env) (fixnump position))
511              ; I'm not sure this is worth doing
512              `(logand (byte-mask ,size) (ash ,integer ,(- position)))
513              ; this IS worth doing
514              `(load-byte ,size ,position ,integer))))
515         (t call)))
516
517(define-compiler-macro length (&whole call &environment env seq)
518  (if (nx-form-typep seq '(simple-array * (*)) env)
519    `(uvsize ,seq)
520    call))
521
522(define-compiler-macro let (&whole call (&optional (first nil first-p) &rest rest) &body body)
523  (if first-p
524    (if rest
525      call
526      `(let* (,first) ,@body))
527    `(locally ,@body)))
528
529(define-compiler-macro let* (&whole call (&rest bindings) &body body)
530  (if bindings
531    call
532    `(locally ,@body)))
533
534(define-compiler-macro list* (&whole call &environment env &rest rest  &aux (n (list-length rest)) last)
535  (cond ((%izerop n) nil)
536        ((null (setq last (%car (last call))))
537         (cons 'list (nreverse (cdr (reverse (cdr call))))))
538        ((and (consp last) (memq (%car last) '(list* list cons)))
539         (cons (if (eq (%car last) 'cons) 'list* (%car last))
540                                 (nreconc (cdr (reverse (cdr call))) (%cdr last))))
541        ((eq n 1) (list 'values last))
542        ((eq n 2) (cons 'cons (%cdr call)))
543        (t call)))
544
545
546
547;(CONS X NIL) is same size as (LIST X) and faster.
548(define-compiler-macro list  (&whole call &optional (first nil first-p) &rest more)
549  (if more
550    call
551    (if first-p
552      `(cons ,first nil))))
553
554
555(define-compiler-macro locally (&whole call &body body &environment env)
556  (multiple-value-bind (body decls) (parse-body body env nil)
557    (if decls
558      call
559      `(progn ,@body))))
560
561
562(defun target-element-type-subtype (typespec)
563  (let* ((ctype (ignore-errors (specifier-type typespec))))
564    (if (or (null ctype) (typep ctype 'unknown-ctype))
565      (progn
566        (nx1-whine :unknown-type-declaration typespec)
567        nil)
568      (ctype-subtype ctype))))
569
570(define-compiler-macro make-array (&whole call &environment env dims &rest keys)
571  (if (constant-keywords-p keys)
572    (destructuring-bind (&key (element-type t element-type-p)
573                              (displaced-to () displaced-to-p)
574                              (displaced-index-offset () displaced-index-offset-p)
575                              (adjustable () adjustable-p)
576                              (fill-pointer () fill-pointer-p)
577                              (initial-element () initial-element-p)
578                              (initial-contents () initial-contents-p)) 
579                        keys
580      (declare (ignore-if-unused element-type element-type-p
581                                 displaced-to displaced-to-p
582                                 displaced-index-offset displaced-index-offset-p
583                                 adjustable adjustable-p
584                                 fill-pointer fill-pointer-p
585                                 initial-element initial-element-p
586                                 initial-contents initial-contents-p))
587      (cond ((and initial-element-p initial-contents-p)
588             (nx1-whine 'illegal-arguments call)
589             call)
590            (displaced-to-p
591             (if (or initial-element-p initial-contents-p element-type-p)
592               (comp-make-array-1 dims keys)
593               (comp-make-displaced-array dims keys)))
594            ((or displaced-index-offset-p 
595                 (not (constantp element-type))
596                 (null (setq element-type (target-element-type-subtype (eval element-type)))))
597             (comp-make-array-1 dims keys))
598            ((and (typep element-type 'fixnum) 
599                  (nx-form-typep dims 'fixnum env) 
600                  (null (or adjustable fill-pointer initial-contents 
601                            initial-contents-p))) 
602             (if 
603               (or (null initial-element-p) 
604                   (cond ((eql element-type ppc32::subtag-double-float-vector) 
605                          (eql initial-element 0.0d0)) 
606                         ((eql element-type ppc32::subtag-single-float-vector) 
607                          (eql initial-element 0.0s0)) 
608                         ((or (eql element-type ppc32::subtag-simple-base-string) 
609                              (eql element-type ppc32::subtag-simple-general-string)) 
610                          (eql initial-element #\Null))
611                         (t (eql initial-element 0))))
612               `(%alloc-misc ,dims ,element-type) 
613               `(%alloc-misc ,dims ,element-type ,initial-element))) 
614             (t ;Should do more here
615             (comp-make-uarray dims keys element-type))))
616    call))
617
618(defun comp-make-displaced-array (dims keys)
619  (let* ((call-list (make-list 4 :initial-element nil))
620         (dims-var (make-symbol "DIMS"))
621         (let-list (comp-nuke-keys keys
622                                   '((:displaced-to 0)
623                                     (:fill-pointer 1)
624                                     (:adjustable 2)
625                                     (:displaced-index-offset 3))
626                                   call-list
627                                   `((,dims-var ,dims)))))
628
629    `(let ,let-list
630       (%make-displaced-array ,dims-var ,@call-list) t)))
631
632(defun comp-make-uarray (dims keys subtype)
633  (let* ((call-list (make-list 6))
634         (dims-var (make-symbol "DIMS"))
635         (let-list (comp-nuke-keys keys
636                                   '((:adjustable 0)
637                                     (:fill-pointer 1)
638                                     (:initial-element 2 3)
639                                     (:initial-contents 4 5))
640                                   call-list
641                                   `((,dims-var ,dims)))))
642    `(let ,let-list
643       (make-uarray-1 ,subtype ,dims-var ,@call-list nil nil))))
644
645(defun comp-make-array-1 (dims keys)
646  (let* ((call-list (make-list 10 :initial-element nil))
647         (dims-var (make-symbol "DIMS"))
648         (let-list (comp-nuke-keys keys                                   
649                                   '((:element-type 0 1)
650                                     (:displaced-to 2)
651                                     (:displaced-index-offset 3)
652                                     (:adjustable 4)
653                                     (:fill-pointer 5)
654                                     (:initial-element 6 7)
655                                     (:initial-contents 8 9))
656                                   call-list
657                                   `((,dims-var ,dims)))))
658    `(let ,let-list
659       (make-array-1 ,dims-var ,@call-list nil))))
660
661(defun comp-nuke-keys (keys key-list call-list &optional required-bindings)
662  ; side effects call list, returns a let-list
663  (let ((let-list (reverse required-bindings)))
664    (do ((lst keys (cddr lst)))
665        ((null lst) nil)
666      (let* ((key (car lst))
667             (val (cadr lst))
668             (ass (assq key key-list))
669             (vpos (cadr ass))
670             (ppos (caddr ass)))
671        (when ass
672          (when (not (constantp val))
673            (let ((gen (gensym)))
674              (setq let-list (cons (list gen val) let-list)) ; reverse him
675              (setq val gen)))
676          (rplaca (nthcdr vpos call-list) val)
677          (if ppos (rplaca (nthcdr ppos call-list) t)))))
678    (nreverse let-list)))
679
680(define-compiler-macro make-instance (&whole call class &rest initargs)
681  (if (and (listp class)
682           (eq (car class) 'quote)
683           (symbolp (cadr class))
684           (null (cddr class)))
685    `(%make-instance (load-time-value (find-class-cell ,class t))
686                     ,@initargs)
687    call))
688
689
690
691
692
693                                 
694
695(define-compiler-macro mapc  (&whole call fn lst &rest more)
696  (if more
697    call
698    (let* ((temp-var (gensym))
699           (elt-var (gensym))
700           (fn-var (gensym)))
701       `(let* ((,fn-var ,fn)
702               (,temp-var ,lst))
703          (dolist (,elt-var ,temp-var ,temp-var)
704            (funcall ,fn-var ,elt-var))
705          ))))
706
707(define-compiler-macro mapcar (&whole call fn lst &rest more)
708  (if more
709    call
710    (let* ((temp-var (gensym))
711           (result-var (gensym))
712           (elt-var (gensym))
713           (fn-var (gensym)))
714      `(let* ((,temp-var (cons nil nil))
715              (,result-var ,temp-var)
716              (,fn-var ,fn))
717         (declare (dynamic-extent ,temp-var)
718                  (type cons ,temp-var ,result-var))
719         (dolist (,elt-var ,lst (cdr ,result-var))
720           (setq ,temp-var (setf (cdr ,temp-var) (list (funcall ,fn-var ,elt-var)))))))))
721
722(define-compiler-macro member (&whole call &environment env item list &rest keys)
723  (or (eq-eql-call item list keys 'memq 'memeql env)
724      call))
725
726(define-compiler-macro memq (&whole call &environment env item list)
727   ;(memq x '(y)) => (if (eq x 'y) '(y))
728   ;Would it be worth making a two elt list into an OR?  Maybe if
729   ;optimizing for speed...
730   (if (and (or (quoted-form-p list)
731                (null list))
732            (null (cdr (%cadr list))))
733     (if list `(if (eq ,item ',(%caadr list)) ,list))
734     call))
735
736(define-compiler-macro minusp (x)
737  `(< ,x 0))
738
739(define-compiler-macro notany (&whole call &environment env &rest ignore)
740  (declare (ignore ignore))
741  (some-xx-transform call env))
742
743(define-compiler-macro notevery (&whole call &environment env &rest ignore)
744  (declare (ignore ignore))
745  (some-xx-transform call env))
746
747(define-compiler-macro nth  (&whole call &environment env count list)
748   (if (and (fixnump count)
749            (%i>= count 0)
750            (%i< count 3))
751     `(,(svref '#(car cadr caddr) count) ,list)
752     call))
753
754(define-compiler-macro nthcdr (&whole call &environment env count list)
755  (if (and (fixnump count)
756           (%i>= count 0)
757           (%i< count 4)) 
758     (if (%izerop count)
759       list
760       `(,(svref '#(cdr cddr cdddr) (%i- count 1)) ,list))
761     call))
762
763(define-compiler-macro plusp (x)
764  `(> ,x 0))
765
766(define-compiler-macro progn (&whole call &optional (first nil first-p) &rest rest)
767  (if first-p
768    (if rest call first)))
769
770;This isn't quite right... The idea is that (car (require-type foo 'list))
771;can become just (<typechecking-car> foo) [regardless of optimize settings],
772;but I don't think this can be done just with optimizers... For now, at least
773;try to get it to become (%car (<typecheck> foo)).
774(define-compiler-macro require-type (&whole call &environment env arg type)
775  (cond ((and (quoted-form-p type)
776              (setq type (%cadr type))
777              (not (typep (specifier-type type) 'unknown-ctype)))       
778         (cond ((nx-form-typep arg type env) arg)
779               ((eq type 'simple-vector)
780                `(the simple-vector (require-simple-vector ,arg)))
781               ((eq type 'simple-string)
782                `(the simple-string (require-simple-string ,arg)))
783               ((eq type 'integer)
784                `(the integer (require-integer ,arg)))
785               ((eq type 'fixnum)
786                `(the fixnum (require-fixnum ,arg)))
787               ((eq type 'real)
788                `(the real (require-real ,arg)))
789               ((eq type 'list)
790                `(the list (require-list ,arg)))
791               ((eq type 'character)
792                `(the character (require-character ,arg)))
793               ((eq type 'number)
794                `(the number (require-number ,arg)))
795               ((eq type 'symbol)
796                `(the symbol (require-symbol ,arg)))
797               ((and (consp type)(memq (car type) '(signed-byte unsigned-byte integer)))
798                `(the ,type (%require-type-builtin ,arg 
799                                                   (load-time-value (find-builtin-cell ',type)))))
800               ((and (symbolp type)
801                     (let ((simpler (type-predicate type)))
802                       (if simpler `(the ,type (%require-type ,arg ',simpler))))))
803               ((and (symbolp type)(find-class type nil env))
804                  `(%require-type-class-cell ,arg (load-time-value (find-class-cell ',type t))))
805               (t call)))
806        (t call)))
807
808(define-compiler-macro proclaim (&whole call decl)
809   (if (and (quoted-form-p decl)
810            (eq (car (setq decl (%cadr decl))) 'special))
811       (do ((vars (%cdr decl) (%cdr vars)) (decls ()))
812           ((null vars)
813            (cons 'progn (nreverse decls)))
814         (unless (and (car vars)
815                      (neq (%car vars) t)
816                      (symbolp (%car vars)))
817            (return call))
818         (push (list '%proclaim-special (list 'quote (%car vars))) decls))
819       call))
820
821
822(define-compiler-macro some (&whole call &environment env &rest ignore)
823  (declare (ignore ignore))
824  (some-xx-transform call env))
825
826(define-compiler-macro struct-ref (&whole call &environment env struct offset)
827   (if (nx-inhibit-safety-checking env)
828    `(%svref ,struct ,offset)
829    call))
830
831;;; expand find-if and find-if-not
832
833(define-compiler-macro find-if (&whole call &environment env
834                                       test sequence &rest keys)
835  `(find ,test ,sequence
836        :test #'funcall
837        ,@keys))
838
839(define-compiler-macro find-if-not (&whole call &environment env
840                                           test sequence &rest keys)
841  `(find ,test ,sequence
842        :test-not #'funcall
843        ,@keys))
844
845;;; inline some cases, and use a positional function in others
846
847(define-compiler-macro find (&whole call &environment env
848                                    item sequence &rest keys)
849  (if (constant-keywords-p keys)
850    (destructuring-bind (&key from-end test test-not (start 0) end key) keys
851      (if (and (eql start 0)
852               (null end)
853               (null from-end)
854               (not (and test test-not)))
855        (let ((find-test (or test test-not '#'eql))
856              (loop-test (if test-not 'unless 'when))
857              (loop-function (nx-form-sequence-iterator sequence env)))
858          (if loop-function
859            (let ((item-var (unless (or (constantp item)
860                                        (and (equal find-test '#'funcall)
861                                             (function-form-p item)))
862                              (gensym)))
863                  (elt-var (gensym)))
864              `(let (,@(when item-var `((,item-var ,item))))
865                 (,loop-function (,elt-var ,sequence)
866                                 (,loop-test (funcall ,find-test ,(or item-var item)
867                                                      (funcall ,(or key '#'identity) ,elt-var))
868                                             (return ,elt-var)))))
869            (let ((find-function (if test-not 'find-positional-test-not-key 'find-positional-test-key))
870                  (item-var (gensym))
871                  (sequence-var (gensym))
872                  (test-var (gensym))
873                  (key-var (gensym)))
874              `(let ((,item-var ,item)
875                     (,sequence-var ,sequence)
876                     (,test-var ,(or test test-not))
877                     (,key-var ,key))
878                 (declare (dynamic-extent ,item-var ,sequence-var ,test-var ,key-var))
879                 (,find-function ,item-var ,sequence-var ,test-var ,key-var)))))
880        call))
881      call))
882
883;;; expand position-if and position-if-not
884
885(define-compiler-macro position-if (&whole call &environment env
886                                           test sequence &rest keys)
887  `(position ,test ,sequence
888             :test #'funcall
889             ,@keys))
890
891(define-compiler-macro position-if-not (&whole call &environment env
892                                               test sequence &rest keys)
893  `(position ,test ,sequence
894             :test-not #'funcall
895             ,@keys))
896
897;;; inline some cases, and use positional functions for others
898
899(define-compiler-macro position (&whole call &environment env
900                                        item sequence &rest keys)
901  (if (constant-keywords-p keys)
902    (destructuring-bind (&key from-end test test-not (start 0) end key) keys
903      (if (and (eql start 0)
904               (null end)
905               (null from-end)
906               (not (and test test-not)))
907        (let ((position-test (or test test-not '#'eql))
908              (loop-test (if test-not 'unless 'when))
909              (sequence-value (if (constantp sequence)
910                                (eval-constant sequence)
911                                sequence)))
912          (cond ((nx-form-typep sequence-value 'list env)
913                 (let ((item-var (unless (or (constantp item)
914                                             (and (equal position-test '#'funcall)
915                                                  (function-form-p item)))
916                                   (gensym)))
917                       (elt-var (gensym))
918                       (position-var (gensym)))
919                   `(let (,@(when item-var `((,item-var ,item)))
920                          (,position-var 0))
921                      (dolist (,elt-var ,sequence)
922                        (,loop-test (funcall ,position-test ,(or item-var item)
923                                             (funcall ,(or key '#'identity) ,elt-var))
924                                    (return ,position-var))
925                        (incf ,position-var)))))
926                ((nx-form-typep sequence-value 'vector env)
927                 (let ((item-var (unless (or (constantp item)
928                                             (and (equal position-test '#'funcall)
929                                                  (function-form-p item)))
930                                   (gensym)))
931                       (sequence-var (gensym))
932                       (position-var (gensym)))
933                   `(let (,@(when item-var `((,item-var ,item)))
934                          (,sequence-var ,sequence))
935                      ,@(let ((type (nx-form-type sequence env)))
936                          (unless (eq type t)
937                            `((declare (type ,type ,sequence-var)))))
938                      (dotimes (,position-var (length ,sequence-var))
939                        (,loop-test (funcall ,position-test ,(or item-var item)
940                                             (funcall ,(or key '#'identity)
941                                                      (locally (declare (optimize (speed 3) (safety 0)))
942                                                        (aref ,sequence ,position-var))))
943                                    (return ,position-var))))))
944                (t
945                 (let ((position-function (if test-not
946                                            'position-positional-test-not-key
947                                            'position-positional-test-key))
948                       (item-var (gensym))
949                       (sequence-var (gensym))
950                       (test-var (gensym))
951                       (key-var (gensym)))
952                   `(let ((,item-var ,item)
953                          (,sequence-var ,sequence)
954                          (,test-var ,(or test test-not))
955                          (,key-var ,key))
956                      (declare (dynamic-extent ,sequence-var ,test-var ,key-var))
957                      (,position-function ,item-var ,sequence-var ,test-var ,key-var))))))
958        call))
959    call))
960
961;;; inline some cases of remove-if and remove-if-not
962
963(define-compiler-macro remove-if (&whole call &environment env &rest ignore)
964  (declare (ignore ignore))
965  (remove-if-transform call env))
966
967(define-compiler-macro remove-if-not (&whole call &environment env &rest ignore)
968  (declare (ignore ignore))
969  (remove-if-transform call env))
970
971(defun remove-if-transform (call env)
972  (destructuring-bind (function test sequence &rest keys) call
973    (if (constant-keywords-p keys)
974      (destructuring-bind (&key from-end (start 0) end count (key '#'identity)) keys
975        (if (and (eql start 0)
976                 (null end)
977                 (null from-end)
978                 (null count)
979                 (nx-form-typep sequence 'list env))
980          ;; only do the list case, since it's hard to collect vector results
981          (let ((temp-var (gensym))
982                (result-var (gensym))
983                (elt-var (gensym))
984                (loop-test (ecase function (remove-if 'unless) (remove-if-not 'when))))
985            `(the list
986               (let* ((,temp-var (cons nil nil))
987                      (,result-var ,temp-var))
988                 (declare (dynamic-extent ,temp-var))
989                 (dolist (,elt-var ,sequence (%cdr ,result-var))
990                   (,loop-test (funcall ,test (funcall ,key ,elt-var))
991                               (setq ,temp-var 
992                                     (%cdr 
993                                      (%rplacd ,temp-var (list ,elt-var)))))))))
994          call))
995      call)))
996
997
998
999(define-compiler-macro struct-set (&whole call &environment env struct offset new)
1000  (if (nx-inhibit-safety-checking env)
1001    `(%svset ,struct ,offset ,new)
1002    call))
1003
1004(define-compiler-macro zerop (arg &environment env)
1005  (let* ((z (if (nx-form-typep arg 'float env)
1006              (coerce 0 (nx-form-type arg env))
1007              0)))
1008    `(= ,arg ,z)))
1009
1010
1011(define-compiler-macro = (&whole w n0 &optional (n1 nil n1p) &rest more)
1012  (if (not n1p)
1013    `(require-type ,n0 'number)
1014    (if more
1015      w
1016      `(=-2 ,n0 ,n1))))
1017
1018(define-compiler-macro /= (&whole w n0 &optional (n1 nil n1p) &rest more)
1019  (if (not n1p)
1020    `(require-type ,n0 'number)
1021    (if more
1022      w
1023      `(/=-2 ,n0 ,n1))))
1024
1025(define-compiler-macro + (&whole w  &environment env &optional (n0 nil n0p) (n1 nil n1p) &rest more)
1026 
1027  (if more
1028    (if (and (subtypep *nx-form-type* 'fixnum)
1029             (nx-trust-declarations env)
1030             (nx-form-typep n0 'fixnum env)
1031             (nx-form-typep n1 'fixnum env)
1032             (dolist (x more t)
1033               (if (not (nx-form-typep x 'fixnum env))(return nil))))
1034      `(%i+ ,n0 ,n1 ,@more)
1035      (let ((type (nx-form-type w env)))
1036        (if (and type (numeric-type-p type))
1037          `(+-2 ,n0 (+ ,n1 ,@more))
1038          w)))
1039    (if n1p
1040      `(+-2 ,n0 ,n1)
1041      (if n0p
1042        `(require-type ,n0 'number)
1043        0))))
1044
1045(define-compiler-macro - (&whole w &environment env n0 &optional (n1 nil n1p) &rest more)
1046  (if more
1047    (if (and (subtypep *nx-form-type* 'fixnum)
1048             (nx-trust-declarations env)
1049             (nx-form-typep n0 'fixnum env)
1050             (nx-form-typep n1 'fixnum env)
1051             (dolist (x more t)
1052               (if (not (nx-form-typep x 'fixnum env))(return nil))))
1053      `(%i- ,n0 (%i+ ,n1 ,@more))
1054      (let ((type (nx-form-type w env)))
1055        (if (and type (numeric-type-p type)) ; go pairwise if type known, else not
1056          `(--2 ,n0 (+ ,n1 ,@more))
1057          w)))
1058    (if n1p
1059      `(--2 ,n0 ,n1)
1060      `(%negate ,n0))))
1061
1062(define-compiler-macro * (&whole w &environment env &optional (n0 nil n0p) (n1 nil n1p) &rest more)
1063  (if more
1064    (let ((type (nx-form-type w env)))
1065      (if (and type (numeric-type-p type)) ; go pairwise if type known, else not
1066        `(*-2 ,n0 (* ,n1 ,@more))
1067        w))
1068    (if n1p
1069      `(*-2 ,n0 ,n1)
1070      (if n0p
1071        `(require-type ,n0 'number)
1072        1))))
1073
1074(define-compiler-macro / (&whole w n0 &optional (n1 nil n1p) &rest more)
1075  (if more
1076    w
1077    (if n1p
1078      `(/-2 ,n0 ,n1)
1079      `(%quo-1 ,n0))))
1080
1081; beware of limits - truncate of most-negative-fixnum & -1 ain't a fixnum - too bad
1082(define-compiler-macro truncate (&whole w &environment env n0 &optional (n1 nil n1p))
1083  (let ((*nx-form-type* t))
1084    (if (nx-form-typep n0 'fixnum env)
1085      (if (not n1p)
1086        n0
1087        (if (nx-form-typep n1 'fixnum env)
1088          `(%fixnum-truncate ,n0 ,n1)
1089          w))
1090      w)))
1091
1092(define-compiler-macro floor (&whole w &environment env n0 &optional (n1 nil n1p))
1093  (let ((*nx-form-type* t))
1094    (if (nx-form-typep n0 'fixnum env)
1095      (if (not n1p)
1096        n0
1097        (if (nx-form-typep n1 'fixnum env)
1098          `(%fixnum-floor ,n0 ,n1)
1099          w))
1100      w)))
1101
1102(define-compiler-macro round (&whole w &environment env n0 &optional (n1 nil n1p))
1103  (let ((*nx-form-type* t)) ; it doesn't matter what the result type is declared to be
1104    (if (nx-form-typep n0 'fixnum env)
1105      (if (not n1p)
1106        n0
1107        (if (nx-form-typep n1 'fixnum env)
1108          `(%fixnum-round ,n0 ,n1)
1109          w))
1110      w)))
1111
1112(define-compiler-macro ceiling (&whole w &environment env n0 &optional (n1 nil n1p))
1113  (let ((*nx-form-type* t))
1114    (if (nx-form-typep n0 'fixnum env)
1115      (if (not n1p)
1116        n0
1117        (if (nx-form-typep n1 'fixnum env)
1118          `(%fixnum-ceiling ,n0 ,n1)
1119          w))
1120      w)))
1121
1122(define-compiler-macro oddp (&whole w &environment env n0)
1123  (if (nx-form-typep n0 'fixnum env)
1124    `(logbitp 0 (the fixnum ,n0))
1125    w))
1126
1127(define-compiler-macro evenp (&whole w &environment env n0)
1128  (if (nx-form-typep n0 'fixnum env)
1129    `(not (logbitp 0 (the fixnum ,n0)))
1130    w))
1131 
1132
1133(define-compiler-macro logandc2 (n0 n1)
1134  (let ((n1var (gensym))
1135        (n0var (gensym)))
1136    `(let ((,n0var ,n0)
1137           (,n1var ,n1))
1138       (logandc1 ,n1var ,n0var))))
1139
1140(define-compiler-macro logorc2 (n0 n1)
1141  (let ((n1var (gensym))
1142        (n0var (gensym)))
1143    `(let ((,n0var ,n0)
1144           (,n1var ,n1))
1145       (logorc1 ,n1var ,n0var))))
1146
1147(define-compiler-macro lognand (n0 n1)
1148  `(lognot (logand ,n0 ,n1)))
1149
1150(define-compiler-macro lognor (n0 n1)
1151  `(lognot (logior ,n0 ,n1)))
1152
1153
1154(defun transform-logop (whole identity binop)
1155  (destructuring-bind (op &optional (n0 nil n0p) (n1 nil n1p) &rest more) whole
1156    (if (and n1p (eql n0 identity))
1157      `(,op ,n1 ,@more)
1158      (if (and n1p (eql n0 (lognot identity)))
1159        `(progn
1160           (,op ,n1 ,@more)
1161           ,(lognot identity))
1162        (if more
1163          (if (cdr more)
1164            whole
1165            `(,binop ,n0 (,binop ,n1 ,(car more))))
1166          (if n1p
1167            `(,binop ,n0 ,n1)
1168            (if n0p
1169              `(require-type ,n0 'integer)
1170              identity)))))))
1171         
1172(define-compiler-macro logand (&whole w &rest all)
1173  (declare (ignore all))
1174  (transform-logop w -1 'logand-2))
1175
1176(define-compiler-macro logior (&whole w &rest all)
1177  (declare (ignore all))
1178  (transform-logop w 0 'logior-2))
1179
1180(define-compiler-macro logxor (&whole w &rest all)
1181  (declare (ignore all))
1182  (transform-logop w 0 'logxor-2))
1183
1184(define-compiler-macro lognot (&whole w &environment env n1)
1185  (if (nx-form-typep n1 'fixnum env)
1186    `(%ilognot ,n1)
1187    w))
1188
1189(define-compiler-macro logtest (&whole w &environment env n1 n2)
1190  (if (and (nx-form-typep n1 'fixnum env)
1191           (nx-form-typep n2 'fixnum env))
1192    `(not (eql 0 (logand ,n1 ,n2)))
1193    w))
1194 
1195
1196(defmacro defsynonym (from to)
1197  ;Should maybe check for circularities.
1198  `(progn
1199     (setf (compiler-macro-function ',from) nil)
1200     (let ((pair (assq ',from *nx-synonyms*)))
1201       (if pair (rplacd pair ',to) 
1202           (push (cons ',from ',to) 
1203                 *nx-synonyms*))
1204       ',to)))
1205
1206(defsynonym first car)
1207(defsynonym second cadr)
1208(defsynonym third caddr)
1209(defsynonym fourth cadddr)
1210(defsynonym rest cdr)
1211
1212
1213(defsynonym functionp lfunp)
1214(defsynonym null not)
1215(defsynonym char-int char-code)
1216
1217;;; Improvemets file by Bob Cassels
1218;;; Just what are "Improvemets", anyway ?
1219
1220;;; Optimize some CL sequence functions, mostly by inlining them in simple cases
1221;;; when the type of the sequence is known.  In some cases, dynamic-extent declarations are
1222;;; automatically inserted.  For some sequence functions, if the type of the
1223;;; sequence is known at compile time, the function is inlined.  If the type
1224;;; isn't known but the call is "simple", a call to a faster (positional-arg)
1225;;; function is substituted.
1226
1227
1228(defun nx-form-sequence-iterator (sequence-form env)
1229  (cond ((nx-form-typep sequence-form 'vector env) 'dovector)
1230        ((nx-form-typep sequence-form 'list env) 'dolist)))
1231
1232(defun function-form-p (form)
1233   ;; c.f. quoted-form-p
1234   (and (consp form)
1235        (eq (%car form) 'function)
1236        (consp (%cdr form))
1237        (null (%cdr (%cdr form)))))
1238
1239(defun optimize-typep (thing type env)
1240  ;; returns a new form, or nil if it can't optimize
1241  (cond ((symbolp type)
1242         (let ((typep (type-predicate type)))
1243           (cond ((and typep
1244                       (symbolp typep))
1245                  `(,typep ,thing))
1246                 ((%deftype-expander type)
1247                  ;; recurse here, rather than returning the partially-expanded form
1248                  ;; mostly since it doesn't seem to further optimize the result otherwise
1249                  (let ((expanded-type (type-expand type)))
1250                    (or (optimize-typep thing expanded-type env)
1251                        ;; at least do the first expansion
1252                        `(typep ,thing ',expanded-type))))
1253                 ((structure-class-p type env)
1254                  `(structure-typep ,thing ',type))
1255                 ((find-class type nil env)
1256                  `(class-cell-typep ,thing (load-time-value (find-class-cell ',type t))))
1257                 ((info-type-builtin type) ; bootstrap troubles here?
1258                  `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type))))
1259                 (t nil))))
1260        ((consp type)
1261         (cond 
1262          ((info-type-builtin type)  ; byte types
1263           `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type))))
1264          (t 
1265           (case (%car type)
1266             (satisfies `(funcall ',(cadr type) ,thing))
1267             (eql `(eql ,thing ',(cadr type)))
1268             (member `(not (null (member ,thing ',(%cdr type)))))
1269             (not `(not (typep ,thing ',(cadr type))))
1270             ((or and)
1271              (let ((thing-sym (gensym)))
1272                `(let ((,thing-sym ,thing))
1273                   (,(%car type)
1274                    ,@(mapcar #'(lambda (type-spec)
1275                                  (or (optimize-typep thing-sym type-spec env)
1276                                      `(typep ,thing-sym ',type-spec)))
1277                              (%cdr type))))))
1278             ((signed-byte unsigned-byte integer mod)  ; more byte types
1279              `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type))))
1280             (t nil)))))
1281        (t nil)))
1282
1283(define-compiler-macro typep  (&whole call &environment env thing type &optional e)
1284  (declare (ignore e))
1285  (if (quoted-form-p type)
1286    (or (optimize-typep thing (%cadr type) env)
1287        call)
1288    call))
1289
1290
1291
1292(define-compiler-macro find-class (&whole call type &optional (errorp t) env)
1293  ;(declare (ignore env))
1294  (if (and (quoted-form-p type)(not *dont-find-class-optimize*)(not env))
1295      `(class-cell-find-class (load-time-value (find-class-cell ,type t)) ,errorp)
1296    call))
1297
1298
1299(define-compiler-macro gcd (&whole call &optional (n0 nil n0-p) (n1 nil n1-p) &rest rest)
1300  (if rest
1301    call
1302    (if n1-p
1303      `(gcd-2 ,n0 ,n1)
1304      (if n0-p
1305        `(%integer-abs ,n0)
1306        0))))
1307
1308(define-compiler-macro lcm (&whole call &optional (n0 nil n0-p) (n1 nil n1-p) &rest rest)
1309  (if rest
1310    call
1311    (if n1-p
1312      `(lcm-2 ,n0 ,n1)
1313      (if n0-p
1314        `(%integer-abs ,n0)
1315        1))))
1316
1317(define-compiler-macro max (&whole call &environment env n0 &optional (n1 nil n1-p) &rest rest)
1318  (if rest
1319    call
1320    (if n1-p
1321      (if (and (nx-form-typep n0 'fixnum env)(nx-form-typep n1 'fixnum env))
1322        `(imax-2 ,n0 ,n1)
1323        `(max-2 ,n0 ,n1))
1324      `(require-type ,n0 'real))))
1325
1326(define-compiler-macro max-2 (n0 n1)
1327  (let* ((g0 (gensym))
1328         (g1 (gensym)))
1329   `(let* ((,g0 ,n0)
1330           (,g1 ,n1))
1331      (if (> ,g0 ,g1) ,g0 ,g1))))
1332
1333(define-compiler-macro imax-2 (n0 n1)
1334  (let* ((g0 (gensym))
1335         (g1 (gensym)))
1336   `(let* ((,g0 ,n0)
1337           (,g1 ,n1))
1338      (if (%i> ,g0 ,g1) ,g0 ,g1))))
1339
1340
1341
1342
1343(define-compiler-macro min (&whole call &environment env n0 &optional (n1 nil n1-p) &rest rest)
1344  (if rest
1345    call
1346    (if n1-p
1347      (if (and (nx-form-typep n0 'fixnum env)(nx-form-typep n1 'fixnum env))
1348        `(imin-2 ,n0 ,n1)
1349        `(min-2 ,n0 ,n1))
1350      `(require-type ,n0 'real))))
1351
1352(define-compiler-macro min-2 (n0 n1)
1353  (let* ((g0 (gensym))
1354         (g1 (gensym)))
1355   `(let* ((,g0 ,n0)
1356           (,g1 ,n1))
1357      (if (< ,g0 ,g1) ,g0 ,g1))))
1358
1359(define-compiler-macro imin-2 (n0 n1)
1360  (let* ((g0 (gensym))
1361         (g1 (gensym)))
1362   `(let* ((,g0 ,n0)
1363           (,g1 ,n1))
1364      (if (%i< ,g0 ,g1) ,g0 ,g1))))
1365
1366
1367(defun eq-test-p (test)
1368  (or (equal test ''eq) (equal test '#'eq)))
1369
1370(defun eql-test-p (test)
1371  (or (equal test ''eql) (equal test '#'eql)))
1372
1373(define-compiler-macro adjoin (&whole whole elt list &rest keys)
1374  (if (constant-keywords-p keys)
1375    (destructuring-bind (&key (test ''eql) test-not key) keys
1376      (or (and (null test-not)
1377               (null key)
1378               (cond ((eq-test-p test)
1379                      `(adjoin-eq ,elt ,list))
1380                     ((eql-test-p test)
1381                      `(adjoin-eql ,elt ,list))
1382                     (t nil)))
1383          whole))
1384    whole))
1385
1386(define-compiler-macro union (&whole whole list1 list2 &rest keys)
1387  (if (constant-keywords-p keys)
1388    (destructuring-bind (&key (test ''eql) test-not key) keys
1389      (or (and (null test-not)
1390               (null key)
1391               (cond ((eq-test-p test)
1392                      `(union-eq ,list1 ,list2))
1393                     ((eql-test-p test)
1394                      `(union-eql ,list1 ,list2))
1395                     (t nil)))
1396          whole))
1397    whole))
1398
1399(define-compiler-macro slot-value (&whole whole &environment env
1400                                          instance slot-name-form)
1401  (declare (ignore env))
1402  (let* ((name (and (quoted-form-p slot-name-form)
1403                    (typep (cadr slot-name-form) 'symbol)
1404                    (cadr slot-name-form))))
1405    (if name
1406      `(slot-id-value ,instance (load-time-value (ensure-slot-id ',name)))
1407      whole)))
1408
1409
1410(define-compiler-macro set-slot-value (&whole whole &environment env
1411                                          instance slot-name-form value-form)
1412  (declare (ignore env))
1413  (let* ((name (and (quoted-form-p slot-name-form)
1414                    (typep (cadr slot-name-form) 'symbol)
1415                    (cadr slot-name-form))))
1416    (if name
1417      `(set-slot-id-value
1418        ,instance
1419        (load-time-value (ensure-slot-id ',name))
1420        ,value-form)
1421      whole)))
1422
1423
1424
1425                       
1426(defsynonym %get-unsigned-byte %get-byte)
1427(defsynonym %get-unsigned-word %get-word)
1428(defsynonym %get-signed-long %get-long)
1429
1430
1431
1432
1433(define-compiler-macro arrayp (arg)
1434  `(>= (the fixnum (typecode ,arg)) #.ppc32::subtag-arrayH))
1435
1436(define-compiler-macro vectorp (arg)
1437  `(>= (the fixnum (typecode ,arg)) #.ppc32::subtag-vectorH))
1438
1439
1440(define-compiler-macro fixnump (arg)
1441  `(eql (lisptag ,arg) #.ppc32::tag-fixnum))
1442
1443(define-compiler-macro float (&whole w number &optional other)
1444  (declare (ignore number other))
1445  w)
1446
1447(define-compiler-macro double-float-p (n)
1448  `(eql (typecode ,n) #.ppc32::subtag-double-float))
1449
1450
1451(define-compiler-macro short-float-p (n)
1452  `(eql (typecode ,n) #.ppc32::subtag-single-float))
1453
1454
1455(define-compiler-macro floatp (n)
1456  (let* ((typecode (make-symbol "TYPECODE")))
1457    `(let* ((,typecode (typecode ,n)))
1458       (declare (fixnum ,typecode))
1459       (or (= ,typecode #.ppc32::subtag-double-float)
1460           (= ,typecode #.ppc32::subtag-single-float)))))
1461
1462(define-compiler-macro functionp (n)
1463  `(eql (typecode ,n) #.ppc32::subtag-function))
1464
1465(define-compiler-macro listp (n)
1466  `(eql (lisptag ,n) #.ppc32::tag-list))
1467
1468(define-compiler-macro consp (n)
1469  `(eql (fulltag ,n) #.ppc32::fulltag-cons))
1470
1471(define-compiler-macro bignump (n)
1472  `(eql (typecode ,n) #.ppc32::subtag-bignum))
1473
1474(define-compiler-macro ratiop (n)
1475  `(eql (typecode ,n) #.ppc32::subtag-ratio))
1476
1477(define-compiler-macro complexp (n)
1478  `(eql (typecode ,n) #.ppc32::subtag-complex))
1479
1480
1481(define-compiler-macro aref (&whole call a &rest subscripts &environment env)
1482    (let* ((ctype (if (nx-form-typep a 'array env)
1483                      (specifier-type (nx-form-type a env))))
1484           (type (if ctype (type-specifier (array-ctype-specialized-element-type ctype))))
1485           (useful (unless (or (eq type *) (eq type t))
1486                     type))) 
1487  (if (= 2 (length subscripts))
1488    (setq call `(%aref2 ,a ,(car subscripts) ,(cadr subscripts))))
1489  (if useful
1490    `(the ,useful ,call)
1491    call)))
1492
1493
1494(define-compiler-macro aset (&whole call a &rest subs&val)
1495  (if (= 3 (length subs&val))
1496    `(%aset2 ,a ,(car subs&val) ,(cadr subs&val) ,(caddr subs&val))
1497    call))
1498
1499
1500(define-compiler-macro make-sequence (&whole call &environment env typespec len &rest keys &key initial-element)
1501  (declare (ignore typespec len keys initial-element))
1502  call)
1503
1504(define-compiler-macro make-string (&whole call size &rest keys)
1505  (if (constant-keywords-p keys)
1506    (destructuring-bind (&key (element-type () element-type-p)
1507                              (initial-element () initial-element-p))
1508                        keys
1509      (if (and element-type-p
1510               (quoted-form-p element-type))
1511        (let* ((element-type (cadr element-type)))
1512          (if (subtypep element-type 'base-char)
1513            `(%alloc-misc ,size #.ppc32::subtag-simple-base-string ,@(if initial-element-p `(,initial-element)))
1514            call))
1515        (if (not element-type-p)
1516          `(%alloc-misc ,size #.ppc32::subtag-simple-base-string ,@(if initial-element-p `(,initial-element)))
1517          call)))
1518    call))
1519
1520(define-compiler-macro sbit (&environment env &whole call v &optional sub0 &rest others)
1521  (if (and sub0 (null others))
1522    `(%typed-miscref #.ppc32::subtag-bit-vector ,v ,sub0)
1523    call))
1524
1525(define-compiler-macro %sbitset (&environment env &whole call v sub0 &optional (newval nil newval-p) &rest newval-was-really-sub1)
1526  (if (and newval-p (not newval-was-really-sub1) )
1527    `(%typed-miscset #.ppc32::subtag-bit-vector ,v ,sub0 ,newval)
1528    call))
1529
1530(define-compiler-macro simple-base-string-p (thing)
1531  `(= (the fixnum (typecode ,thing)) #.ppc32::subtag-simple-base-string))
1532
1533(define-compiler-macro simple-string-p (thing)
1534  `(simple-base-string-p ,thing))
1535
1536
1537(defsetf %misc-ref %misc-set)
1538
1539
1540(define-compiler-macro lockp (lock)
1541  `(eq ppc32::subtag-lock (typecode ,lock)))
1542
1543(define-compiler-macro integerp (thing)
1544  (let* ((typecode (gensym)))
1545    `(let* ((,typecode (typecode ,thing)))
1546      (declare (fixnum ,typecode))
1547      (or (= ,typecode ppc32::tag-fixnum)
1548          (= ,typecode ppc32::subtag-bignum)))))
1549       
1550(define-compiler-macro %composite-pointer-ref (size pointer offset)
1551  (if (constantp size)
1552    `(%inc-ptr ,pointer ,offset)
1553    `(progn
1554      ,size
1555      (%inc-ptr ,pointer ,offset))))
1556
1557(provide "OPTIMIZERS")
1558
Note: See TracBrowser for help on using the repository browser.