source: branches/working-0711/ccl/compiler/nx0.lisp @ 11164

Last change on this file since 11164 was 11164, checked in by gz, 13 years ago

Another batch of changes from the trunk, some bug fixes, optimizations, as well as formatting unification

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 110.8 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
18
19(in-package "CCL")
20
21;; :compiler:nx0.lisp - part of the compiler
22
23
24(defstruct pending-declarations
25  vdecls
26  fdecls
27  mdecls)
28
29; Phony AFUNC "defstruct":
30(defun make-afunc (&aux (v (%make-afunc)))
31  (setf (afunc-fn-refcount v) 0)
32  (setf (afunc-fn-downward-refcount v) 0)
33  (setf (afunc-bits v) 0)
34  v)
35
36(defvar *nx-blocks* nil)
37(defvar *nx-tags* nil)
38(defvar *nx-parent-function* nil)
39(defvar *nx-current-function* nil)
40(defvar *nx-lexical-environment* nil)
41(defvar *nx-symbol-macros* nil)
42(defvar *nx-inner-functions* nil)
43(defvar *nx-cur-func-name* nil)
44(defvar *nx-form-type* t)
45;(defvar *nx-proclaimed-inline* nil)
46;(defvar *nx-proclaimed-inline* (make-hash-table :size 400 :test #'eq))
47(defvar *nx-proclaimed-ignore* nil)
48(defvar *nx-parsing-lambda-decls* nil) ; el grosso.
49(defparameter *nx-standard-declaration-handlers* nil)
50(defparameter *nx-hoist-declarations* t)
51(defparameter *nx-loop-nesting-level* 0)
52(defvar *nx-break-on-program-errors* t)
53
54(defvar *nx1-vcells* nil)
55(defvar *nx1-fcells* nil)
56
57(defvar *nx1-operators* (make-hash-table :size 300 :test #'eq))
58
59                                         
60
61; The compiler can (generally) use temporary vectors for VARs.
62(defun nx-cons-var (name &optional (bits 0))
63  (%istruct 'var name bits nil nil nil nil))
64
65
66
67
68(defvar *nx-lambdalist* (make-symbol "lambdalist"))
69(defvar *nx-nil* (list (make-symbol "nil")))
70(defvar *nx-t* (list (make-symbol "t")))
71
72(defparameter *nx-current-compiler-policy* (%default-compiler-policy))
73
74(defvar *nx-next-method-var* nil)
75(defvar *nx-call-next-method-function* nil)
76
77(defvar *nx-sfname* nil)
78(defvar *nx-operators* ())
79(defvar *nx-warnings* nil)
80(defvar *nx-current-code-note* nil)
81
82(defvar *nx1-compiler-special-forms* nil "Real special forms")
83
84(defmacro without-compiling-code-coverage (&body body)
85  "Disable code coverage in the lexical scope of the form"
86  `(compiler-let ((*nx-current-code-note* nil))
87     ,@body))
88
89(defparameter *nx-never-tail-call*
90  '(error cerror break warn type-error file-error
91    signal-program-error signal-simple-program-error
92    print-call-history
93    #-bccl %get-frame-pointer
94    #-bccl break-loop)
95  "List of functions which never return multiple values and
96   should never be tail-called.")
97
98(defvar *cross-compiling* nil "bootstrapping")
99
100
101(defvar *compile-code-coverage* nil "True to instrument for code coverage")
102(defvar *record-pc-mapping* nil "True to record pc -> source mapping")
103
104(defparameter *nx-operator-result-types*
105  '((#.(%nx1-operator list) . list)
106    (#.(%nx1-operator memq) . list)
107    (#.(%nx1-operator %temp-list) . list)
108    (#.(%nx1-operator assq) . list)
109    (#.(%nx1-operator cons) . cons)
110    (#.(%nx1-operator rplaca) . cons)
111    (#.(%nx1-operator %rplaca) . cons)
112    (#.(%nx1-operator rplacd) . cons)
113    (#.(%nx1-operator %rplacd) . cons)
114    (#.(%nx1-operator %temp-cons) . cons)
115    (#.(%nx1-operator %i+) . fixnum)
116    (#.(%nx1-operator %i-) . fixnum)
117    (#.(%nx1-operator %i*) . fixnum)
118    (#.(%nx1-operator %ilsl) . fixnum)
119    (#.(%nx1-operator %ilsr) . fixnum)
120    (#.(%nx1-operator %iasr) . fixnum)
121    (#.(%nx1-operator %ilogior2) . fixnum)
122    (#.(%nx1-operator %ilogand2) . fixnum)
123    (#.(%nx1-operator %ilogxor2) . fixnum)
124    (#.(%nx1-operator %code-char) . character)
125    (#.(%nx1-operator schar) . character)
126    (#.(%nx1-operator length) . fixnum)
127    (#.(%nx1-operator uvsize) . fixnum)
128    (#.(%nx1-operator %double-float/-2) . double-float)
129    (#.(%nx1-operator %double-float/-2!) . double-float) ; no such operator
130    (#.(%nx1-operator %double-float+-2) . double-float)
131    (#.(%nx1-operator %double-float+-2!) . double-float)
132    (#.(%nx1-operator %double-float--2) . double-float)
133    (#.(%nx1-operator %double-float--2!) . double-float)
134    (#.(%nx1-operator %double-float*-2) . double-float)
135    (#.(%nx1-operator %double-float*-2!) . double-float)
136    (#.(%nx1-operator %short-float/-2) . double-float)
137    (#.(%nx1-operator %short-float+-2) . double-float)
138    (#.(%nx1-operator %short-float--2) . double-float)
139    (#.(%nx1-operator %short-float*-2) . double-float)
140    (#.(%nx1-operator %double-to-single) . single-float)
141    (#.(%nx1-operator %single-to-double) . double-float)
142    (#.(%nx1-operator %fixnum-to-single) . single-float)
143    (#.(%nx1-operator %fixnum-to-double) . double-float)
144    (#.(%nx1-operator char-code) . #.`(integer 0 (,char-code-limit)))
145   ))
146
147(defparameter *nx-operator-result-types-by-name*
148  '((%ilognot . fixnum)
149    (%ilogxor . fixnum)
150    (%ilogand . fixnum)
151    (%ilogior . fixnum)
152    (char-code . #. `(integer 0 (,char-code-limit)))))
153
154(setq *nx-known-declarations*
155  '(special inline notinline type ftype function ignore optimize dynamic-extent ignorable
156    ignore-if-unused settable unsettable
157     notspecial global-function-name debugging-function-name resident))
158
159(defun find-optimize-quantity (name env)
160  (let ((pair ()))
161    (loop
162      (when (listp env) (return))
163      (when (setq pair (assq name (lexenv.mdecls env)))
164        (return (%cdr pair)))
165      (setq env (lexenv.parent-env env)))))
166   
167(defun debug-optimize-quantity (env)
168  (or (find-optimize-quantity 'debug env)
169      *nx-debug*))
170
171(defun space-optimize-quantity (env)
172  (or (find-optimize-quantity 'space env)
173      *nx-space*))
174
175(defun safety-optimize-quantity (env)
176  (or (find-optimize-quantity 'safety env)
177      *nx-safety*))
178
179(defun speed-optimize-quantity (env)
180  (or (find-optimize-quantity 'speed env)
181      *nx-speed*))
182
183(defun compilation-speed-optimize-quantity (env)
184  (or (find-optimize-quantity 'compilation-speed env)
185      *nx-cspeed*))
186
187(defvar *nx-ignore-if-unused* ())
188(defvar *nx-new-p2decls* ())
189(defvar *nx-inlined-self* t)
190(defvar *nx-all-vars* nil)
191(defvar *nx-bound-vars* nil)
192(defvar *nx-punted-vars* nil)
193(defvar *nx-inline-expansions* nil)
194(defparameter *nx-compile-time-compiler-macros* nil)
195(defvar *nx-global-function-name* nil)
196(defvar *nx-can-constant-fold* ())
197(defvar *nx-synonyms* ())
198(defvar *nx-load-time-eval-token* ())
199
200(define-condition compiler-function-overflow (condition) ())
201
202(defun compiler-function-overflow ()
203  (signal 'compiler-function-overflow)
204  (error "Function size exceeds compiler limitation."))
205
206(defvar *compiler-macros* (make-hash-table :size 100 :test #'eq))
207
208;;; Just who was responsible for the "FUNCALL" nonsense ?
209;;; Whoever it is deserves a slow and painful death ...
210
211(defmacro define-compiler-macro  (name arglist &body body &environment env)
212  "Define a compiler-macro for NAME."
213  (let* ((block-name name)
214         (def-name (validate-function-name name)))
215    (unless (eq def-name block-name)
216      (setq block-name (cadr block-name)))
217    (let ((body (parse-macro-1 block-name arglist body env)))
218      `(eval-when (:compile-toplevel :load-toplevel :execute)
219         (eval-when (:load-toplevel :execute)
220           (record-source-file ',name 'compiler-macro))
221         (setf (compiler-macro-function ',name)
222               (nfunction (compiler-macro-function ,name)  ,body))
223         ',name))))
224
225;;; This is silly (as may be the whole idea of actually -using-
226;;; compiler-macros).  Compiler-macroexpand-1 will return a second
227;;; value of NIL if the value returned by the expansion function is EQ
228;;; to the original form.  This differs from the behavior of
229;;; macroexpand-1, but users are not encouraged to write macros which
230;;; return their &whole args (as the DEFINE-COMPILER-MACRO issue
231;;; encourages them to do ...)  Cheer up! Neither of these things have
232;;; to exist!
233(defun compiler-macroexpand-1 (form &optional env)
234  (let ((expander nil)
235        (newdef nil))
236    (if (and (consp form)
237             (symbolp (car form))
238             (setq expander (compiler-macro-function (car form) env)))
239      (values (setq newdef (funcall *macroexpand-hook* expander form env)) (neq newdef form))
240      (values form nil))))
241
242; ... If this exists, it should probably be exported.
243(defun compiler-macroexpand (form &optional env)
244  (multiple-value-bind (new win) (compiler-macroexpand-1 form env)
245    (do* ((won-at-least-once win))
246         ((null win) (values new won-at-least-once))
247      (multiple-value-setq (new win) (compiler-macroexpand-1 new env)))))
248
249
250
251
252(defun compiler-macro-function (name &optional env)
253  "If NAME names a compiler-macro in ENV, return the expansion function, else
254   return NIL. Can be set with SETF when ENV is NIL."
255  (setq name (validate-function-name name))
256  (unless (nx-lexical-finfo name env)
257    (or (cdr (assq name *nx-compile-time-compiler-macros*))
258        (values (gethash name *compiler-macros*)))))
259
260(defun set-compiler-macro-function (name def)
261  (setq name (validate-function-name name))
262  (if def
263    (setf (gethash name *compiler-macros*) def)
264    (remhash name *compiler-macros*))
265  def)
266
267(defsetf compiler-macro-function set-compiler-macro-function)
268
269(defparameter *nx-add-xref-entry-hook* nil
270  "When non-NIL, assumed to be a function of 3 arguments
271which asserts that the specied relation from the current
272function to the indicated name is true.")
273
274;; Cross-referencing
275(defun nx-record-xref-info (relation name)
276  (when (fboundp '%add-xref-entry)
277    (funcall '%add-xref-entry relation *nx-cur-func-name* name)))
278
279
280
281(defun nx-apply-env-hook (hook env &rest args)
282  (declare (dynamic-extent args))
283  (when (fixnump hook) (setq hook (uvref *nx-current-compiler-policy* hook)))
284  (if hook
285    (if (functionp hook)
286      (apply hook env args)
287      t)))
288
289(defun nx-self-calls-inlineable (env)
290  (nx-apply-env-hook policy.inline-self-calls env))
291
292(defun nx-allow-register-allocation (env)
293  (not (nx-apply-env-hook policy.inhibit-register-allocation env)))
294
295(defun nx-trust-declarations (env)
296  (unless (eq (safety-optimize-quantity env) 3)
297    (nx-apply-env-hook policy.trust-declarations env)))
298
299(defun nx-open-code-in-line (env)
300  (nx-apply-env-hook policy.open-code-inline env))
301
302(defun nx-inline-car-cdr (env)
303  (unless (eq (safety-optimize-quantity env) 3)
304    (nx-apply-env-hook policy.inhibit-safety-checking env)))
305
306(defun nx-inhibit-safety-checking (env)
307  (unless (eq (safety-optimize-quantity env) 3)
308    (nx-apply-env-hook policy.inhibit-safety-checking env)))
309
310(defun nx-tailcalls (env)
311  (nx-apply-env-hook policy.allow-tail-recursion-elimination env))
312
313(defun nx-allow-transforms (env)
314  (nx-apply-env-hook policy.allow-transforms env))
315
316(defun nx-force-boundp-checks (var env)
317  (or (eq (safety-optimize-quantity env) 3)
318      (nx-apply-env-hook policy.force-boundp-checks var env)))
319
320(defun nx-substititute-constant-value (symbol value env)
321  (nx-apply-env-hook policy.allow-constant-substitution symbol value env))
322
323(defun nx-the-typechecks (env)
324  (nx-apply-env-hook policy.the-typechecks env))
325
326#-bccl
327(defun nx1-default-operator ()
328 (or (gethash *nx-sfname* *nx1-operators*)
329     (error "Bug - operator not found for  ~S" *nx-sfname*)))
330
331(defun nx-new-temp-var (pending &optional (pname "COMPILER-VAR"))
332  (let ((var (nx-new-var pending (make-symbol pname))))
333    (nx-set-var-bits var (%ilogior (%ilsl $vbitignoreunused 1)
334                                   (%ilsl $vbittemporary 1)
335                                   (nx-var-bits var)))
336    var))
337
338(defun nx-new-vdecl (pending name class &optional info)
339  (push (cons name (cons class info)) (pending-declarations-vdecls pending)))
340
341(defun nx-new-fdecl (pending name class &optional info)
342  (push (cons name (cons class info)) (pending-declarations-fdecls pending)))
343
344(defun nx-new-var (pending sym &optional (check t))
345  (nx-init-var pending (nx-cons-var (nx-need-var sym check) 0)))
346                   
347(defun nx-proclaimed-special-p (sym)
348  (setq sym (nx-need-sym sym))
349  (let* ((defenv (definition-environment *nx-lexical-environment*))
350         (specials (if defenv (defenv.specials defenv))))
351    (or (assq sym specials)
352        (proclaimed-special-p sym))))
353
354(defun nx-proclaimed-parameter-p (sym)
355  (or (constantp sym)
356      (multiple-value-bind (special-p info) (nx-lex-info sym t)
357        (or 
358         (and (eq special-p :special) info)
359         (let* ((defenv (definition-environment *nx-lexical-environment*)))
360           (if defenv 
361             (or (%cdr (assq sym (defenv.specials defenv)))
362                 (assq sym (defenv.constants defenv)))))))))
363
364(defun nx-process-declarations (pending decls &optional (env *nx-lexical-environment*) &aux s f)
365  (dolist (decl decls pending)
366    (dolist (spec (%cdr decl))
367      (if (memq (setq s (car spec)) *nx-known-declarations*)
368        (if (setq f (getf *nx-standard-declaration-handlers* s))
369          (funcall f pending spec env))
370        ; Any type name is now (ANSI CL) a valid declaration.
371        ; We should probably do something to distinguish "type names" from "typo names",
372        ; so that (declare (inliMe foo)) warns unless the compiler has some reason to
373        ; believe that 'inliMe' (inlemon) has been DEFTYPEd.
374        (dolist (var (%cdr spec))
375          (if (symbolp var)
376            (nx-new-vdecl pending var 'type s)))))))
377
378; Put all variable decls for the symbol VAR into effect in environment ENV.  Now.
379; Returns list of all new vdecls pertaining to VAR.
380(defun nx-effect-vdecls (pending var env)
381  (let ((vdecls (lexenv.vdecls env))
382        (own nil))
383    (dolist (decl (pending-declarations-vdecls pending) (setf (lexenv.vdecls env) vdecls))
384      (when (eq (car decl) var) 
385        (when (eq (cadr decl) 'type)
386          (let* ((newtype (cddr decl))
387                 (merged-type (nx1-type-intersect var newtype (nx-declared-type var env))))
388             (unless (eq merged-type newtype)
389              (rplacd (cdr decl) merged-type))))
390        (push decl vdecls)
391        (push (cdr decl) own)))
392    own))
393
394
395(defun nx1-typed-var-initform (pending sym form &optional (env *nx-lexical-environment*))
396  (let* ((type t)
397         (*nx-form-type* (if (nx-trust-declarations env)
398                           (dolist (decl (pending-declarations-vdecls pending)  type)
399                            (when (and (eq (car decl) sym) (eq (cadr decl) 'type))
400                              (setq type (nx1-type-intersect sym (nx-target-type type) (cddr decl)))))
401                           t)))
402    (nx1-typed-form form env)))
403
404; Guess.
405(defun nx-effect-fdecls (pending var env)
406  (let ((fdecls (lexenv.fdecls env))
407        (own nil))
408    (dolist (decl (pending-declarations-fdecls pending) (setf (lexenv.fdecls env) fdecls))
409      (when (eq (car decl) var) 
410        (push decl fdecls)
411        (push (cdr decl) own)))
412    own))
413
414
415
416
417(defun nx-acode-form-typep (form type env)
418  (acode-form-typep form type  (nx-trust-declarations env)))
419
420(defun acode-form-typep (form type trust-decls)
421  (if (acode-p form)
422    (let* ((op (acode-operator form))
423           (opval-p (or (eq op (%nx1-operator fixnum)) (eq op (%nx1-operator immediate))))
424           (optype (acode-form-type form trust-decls)))
425      (values
426       (if optype 
427         (subtypep optype (nx-target-type type))
428         (if opval-p (typep (%cadr form) (nx-target-type type))))))))
429
430(defun nx-acode-form-type (form env)
431  (acode-form-type form (nx-trust-declarations env)))
432
433(defparameter *numeric-acode-ops*
434  (list (%nx1-operator add2)
435        (%nx1-operator sub2)
436        (%nx1-operator mul2)))
437
438
439(defun acode-form-type (form trust-decls)
440  (nx-target-type 
441   (if (acode-p form)
442     (let* ((op (acode-operator form)))
443       (if (eq op (%nx1-operator fixnum))
444         'fixnum
445         (if (eq op (%nx1-operator immediate))
446           (type-of (%cadr form))
447           (and trust-decls
448                (if (eq op (%nx1-operator typed-form))
449                  (if (eq (%cadr form) 'number)
450                    (or (acode-form-type (nx-untyped-form form) trust-decls)
451                        'number)
452                    (%cadr form))
453                  (if (eq op (%nx1-operator lexical-reference))
454                    (let* ((var (cadr form))
455                           (bits (nx-var-bits var))
456                           (punted (logbitp $vbitpunted bits)))
457                      (if (or punted
458                              (eql 0 (%ilogand $vsetqmask bits)))
459                        (var-inittype var)))
460                    (if (or (eq op (%nx1-operator %aref1))
461                            (eq op (%nx1-operator simple-typed-aref2))
462                            (eq op (%nx1-operator general-aref2))
463                            (eq op (%nx1-operator simple-typed-aref3))
464                            (eq op (%nx1-operator general-aref3)))
465                      (let* ((atype (acode-form-type (cadr form) t))
466                             (actype (if atype (specifier-type atype))))
467                        (if (typep actype 'array-ctype)
468                          (type-specifier (array-ctype-specialized-element-type
469                                           actype))))
470                      (if (member op *numeric-acode-ops*)
471                        (multiple-value-bind (f1 f2)
472                            (nx-binop-numeric-contagion (cadr form)
473                                                        (caddr form)
474                                                        trust-decls)
475                          (if (and (acode-form-typep f1 'float trust-decls)
476                                   (acode-form-typep f2 'float trust-decls))
477
478                            (if (or (acode-form-typep f1 'double-float trust-decls)
479                                    (acode-form-typep f2 'double-float trust-decls))
480                            'double-float
481                            'single-float)))
482                        (cdr (assq op *nx-operator-result-types*)))))))))))))
483
484(defun nx-binop-numeric-contagion (form1 form2 trust-decls)
485  (cond ((acode-form-typep form1 'double-float trust-decls)
486         (if (acode-form-typep form2 'double-float trust-decls)
487           (values form1 form2)
488           (let* ((c2 (acode-real-constant-p form2)))
489             (if c2
490               (values form1 (make-acode (%nx1-operator immediate)
491                                         (float c2 0.0d0)))
492               (if (acode-form-typep form2 'fixnum trust-decls)
493                 (values form1 (make-acode (%nx1-operator %fixnum-to-double)
494                                           form2))
495                 (values form1 form2))))))
496        ((acode-form-typep form2 'double-float trust-decls)
497         (let* ((c1 (acode-real-constant-p form1)))
498           (if c1
499             (values (make-acode (%nx1-operator immediate)
500                                 (float c1 0.0d0)) form2)
501             (if (acode-form-typep form1 'fixnum trust-decls)
502               (values (make-acode (%nx1-operator %fixnum-to-double)
503                                   form1) form2)
504               (values form1 form2)))))
505        ((acode-form-typep form1 'single-float trust-decls)
506         (if (acode-form-typep form2 'single-float trust-decls)
507           (values form1 form2)
508           (let* ((c2 (acode-real-constant-p form2)))
509             (if c2
510               (values form1 (make-acode (%nx1-operator immediate)
511                                         (float c2 0.0f0)))
512               (if (acode-form-typep form2 'fixnum trust-decls)
513                 (values form1 (make-acode (%nx1-operator %fixnum-to-single)
514                                           form2))
515                 (values form1 form2))))))
516        ((acode-form-typep form2 'single-float trust-decls)
517         (let* ((c1 (acode-real-constant-p form1)))
518           (if c1
519             (values (make-acode (%nx1-operator immediate)
520                                 (float c1 0.0f0)) form2)
521             (if (acode-form-typep form1 'fixnum trust-decls)
522               (values (make-acode (%nx1-operator %fixnum-to-single)
523                                   form1) form2)
524               (values form1 form2)))))
525        (t
526         (values form1 form2))))
527
528(defun acode-punted-var-p (var)
529  (let ((bits (nx-var-bits var)))
530    (and (%ilogbitp $vbitpunted bits)
531         (not (%ilogbitp $vbitspecial bits)))))
532
533; Strip off any type info or "punted" lexical references.
534; ??? Is it true that the "value" of the punted reference is unwrapped ? ???
535(defun acode-unwrapped-form (form) 
536  (while (and (consp (setq form (nx-untyped-form form)))
537           (eq (%car form) (%nx1-operator lexical-reference))
538           (acode-punted-var-p (cadr form)))
539    (setq form (var-ea (cadr form))))
540  form)
541
542;; Use this only to reason about the value of a form at compile time.   To actually
543;; generate code, use acode-unwrapped-form, because we want to include the code note code.
544(defun acode-unwrapped-form-value (form)
545  (setq form (acode-unwrapped-form form))
546  (when (and (acode-p form)
547             (eq (acode-operator form) (%nx1-operator with-code-note)))
548    (setq form (acode-unwrapped-form-value (caddr form))))
549  form)
550
551(defun acode-fixnum-form-p (x)
552  (setq x (acode-unwrapped-form-value x))
553  (if (acode-p x)
554    (if (eq (acode-operator x) (%nx1-operator fixnum)) 
555      (cadr x))))
556
557(defun acode-integer-constant-p (x bits)
558  (let* ((int (or (acode-fixnum-form-p x)
559                  (progn
560                    (setq x (acode-unwrapped-form x))
561                    (if (acode-p x)
562                      (if (and (eq (acode-operator x) (%nx1-operator immediate))
563                               (typep (cadr x) 'fixnum))
564                        (cadr x)))))))
565    (and int
566         (or
567           (typep int `(signed-byte ,bits))
568           (typep int `(unsigned-byte ,bits)))
569         int)))
570
571(defun acode-real-constant-p (x)
572  (or (acode-fixnum-form-p x)
573      (progn
574        (setq x (acode-unwrapped-form x))
575        (if (acode-p x)
576          (if (and (eq (acode-operator x) (%nx1-operator immediate))
577                   (typep (cadr x) 'real))
578            (cadr x))))))
579
580
581
582(defun nx-lookup-target-uvector-subtag (name)
583  (or (cdr (assoc name (arch::target-uvector-subtags (backend-target-arch *target-backend*))))
584      (nx-error "Type ~s not supported on target ~s"
585                name (backend-target-arch-name *target-backend*))))
586
587(defun nx-target-uvector-subtag-name (subtag)
588  (or (car (rassoc subtag (arch::target-uvector-subtags (backend-target-arch *target-backend*))))
589      (nx-error "Subtag ~s not native on target ~s"
590                subtag (backend-target-arch-name *target-backend*))))
591
592(defun nx-error-for-simple-2d-array-type (type-keyword)
593  (ecase type-keyword
594    (:simple-vector arch::error-object-not-simple-array-t-2d)
595    (:simple-string arch::error-object-not-simple-array-char-2d)
596    (:bit-vector arch::error-object-not-simple-array-bit-2d)
597    (:unsigned-8-bit-vector arch::error-object-not-simple-array-u8-2d)
598    (:signed-8-bit-vector arch::error-object-not-simple-array-s8-2d)
599    (:unsigned-16-bit-vector arch::error-object-not-simple-array-u16-2d)
600    (:signed-16-bit-vector arch::error-object-not-simple-array-s16-2d)
601    (:unsigned-32-bit-vector arch::error-object-not-simple-array-u32-2d)
602    (:signed-32-bit-vector arch::error-object-not-simple-array-s32-2d)
603    (:unsigned-64-bit-vector arch::error-object-not-simple-array-u64-2d)
604    (:signed-64-bit-vector arch::error-object-not-simple-array-s64-2d)
605    (:double-float-vector arch::error-object-not-simple-array-double-float-2d)
606    (:single-float-vector arch::error-object-not-simple-array-double-float-2d)
607    (:fixnum-vector arch::error-object-not-simple-array-fixnum-2d)))
608
609(defun nx-error-for-simple-3d-array-type (type-keyword)
610  (ecase type-keyword
611    (:simple-vector arch::error-object-not-simple-array-t-3d)
612    (:simple-string arch::error-object-not-simple-array-char-3d)
613    (:bit-vector arch::error-object-not-simple-array-bit-3d)
614    (:unsigned-8-bit-vector arch::error-object-not-simple-array-u8-3d)
615    (:signed-8-bit-vector arch::error-object-not-simple-array-s8-3d)
616    (:unsigned-16-bit-vector arch::error-object-not-simple-array-u16-3d)
617    (:signed-16-bit-vector arch::error-object-not-simple-array-s16-3d)
618    (:unsigned-32-bit-vector arch::error-object-not-simple-array-u32-3d)
619    (:signed-32-bit-vector arch::error-object-not-simple-array-s32-3d)
620    (:unsigned-64-bit-vector arch::error-object-not-simple-array-u64-3d)
621    (:signed-64-bit-vector arch::error-object-not-simple-array-s64-3d)
622    (:double-float-vector arch::error-object-not-simple-array-double-float-3d)
623    (:single-float-vector arch::error-object-not-simple-array-double-float-3d)
624    (:fixnum-vector arch::error-object-not-simple-array-fixnum-3d)))
625
626(defun acode-s16-constant-p (x)
627  (setq x (acode-unwrapped-form x))
628  (if (acode-p x)
629    (let* ((op (acode-operator x)))
630      (if (eql op (%nx1-operator fixnum))
631        (let* ((val (cadr x)))
632          (if (target-word-size-case
633               (32 (typep val '(signed-byte #.(- 16 2))))
634               (64 (typep val '(signed-byte #.(- 16 3)))))
635            (ash val (target-word-size-case
636                      (32 2)
637                      (64 3)))))
638        (if (eql op (%nx1-operator %unbound-marker))
639          (arch::target-unbound-marker-value
640           (backend-target-arch *target-backend*))
641          (if (eql op (%nx1-operator %slot-unbound-marker))
642            (arch::target-slot-unbound-marker-value
643             (backend-target-arch *target-backend*))))))))
644
645(defun acode-s32-constant-p (x)
646  (setq x (acode-unwrapped-form x))
647  (if (acode-p x)
648    (let* ((op (acode-operator x)))
649      (if (eql op (%nx1-operator fixnum))
650        (let* ((val (cadr x)))
651          (if (target-word-size-case
652               (32 (typep val '(signed-byte #.(- 32 2))))
653               (64 (typep val '(signed-byte #.(- 32 3)))))
654            (ash val (target-word-size-case
655                      (32 2)
656                      (64 3)))))
657        (if (eql op (%nx1-operator %unbound-marker))
658          (arch::target-unbound-marker-value
659           (backend-target-arch *target-backend*))
660          (if (eql op (%nx1-operator %slot-unbound-marker))
661            (arch::target-slot-unbound-marker-value
662             (backend-target-arch *target-backend*))))))))
663
664(defun acode-fixnum-type-p (form trust-decls)
665  (or (acode-fixnum-form-p form)
666      (and trust-decls
667           (acode-p form)
668           (eq (acode-operator form) (%nx1-operator typed-form))
669           (subtypep (cadr form) 'fixnum))))
670
671
672(defun nx-acode-fixnum-type-p (form env)
673    (acode-fixnum-type-p form (nx-trust-declarations env)))
674
675; Is acode-expression the result of alphatizing (%int-to-ptr <integer>) ?
676(defun acode-absolute-ptr-p (acode-expression &optional skip)
677  (and (acode-p acode-expression)
678       (or skip (prog1 (eq (acode-operator acode-expression) (%nx1-operator %macptrptr%))
679                  (setq acode-expression (%cadr acode-expression))))
680       (eq (acode-operator acode-expression) (%nx1-operator %consmacptr%))
681       (eq (acode-operator (setq acode-expression (%cadr acode-expression))) 
682           (%nx1-operator %immediate-int-to-ptr))
683       (let ((op (acode-operator (setq acode-expression (%cadr acode-expression)))))
684         (if (or (eq op (%nx1-operator fixnum))
685                 (and (eq op (%nx1-operator immediate))
686                      (integerp (%cadr acode-expression))))
687           (%cadr acode-expression)))))
688
689(defun nx-check-vdecl-var-ref (decl)
690  (unless (eq (cadr decl) 'special)
691    (let* ((sym (car decl))
692           (info (nx-lex-info sym)))
693      (when (or (eq info :symbol-macro)
694                (and (null info) (not (nx-proclaimed-special-p sym))))
695        (nx1-whine :unknown-declaration-variable (cadr decl) sym)))))
696
697
698(defun nx-effect-other-decls (pending env)
699  (flet ((merge-decls (new old)
700                      (dolist (decl new old) (pushnew decl old :test #'eq))))
701    (let ((vdecls (pending-declarations-vdecls pending))
702          (fdecls (pending-declarations-fdecls pending))
703          (mdecls (pending-declarations-mdecls pending)))
704      (when vdecls
705        (let ((env-vdecls (lexenv.vdecls env)))
706          (dolist (decl vdecls (setf (lexenv.vdecls env) env-vdecls))
707            (unless (memq decl env-vdecls)
708              (nx-check-vdecl-var-ref decl)
709              (when (eq (cadr decl) 'type)
710                (let* ((var (car decl))
711                       (newtype (cddr decl))
712                       (merged-type (nx1-type-intersect var newtype (nx-declared-type var env))))
713                  (unless (eq merged-type newtype)
714                    (rplacd (cdr decl) merged-type))))
715              (push decl env-vdecls)))))
716      (when fdecls (setf (lexenv.fdecls env) (merge-decls fdecls (lexenv.vdecls env))))
717      (when mdecls (setf (lexenv.mdecls env) (merge-decls mdecls (lexenv.mdecls env))))
718      (setq *nx-inlined-self* (and (nx-self-calls-inlineable env) 
719                                   (let ((name *nx-global-function-name*)) 
720                                     (and name (not (nx-declared-notinline-p name env))))))
721      (unless (nx-allow-register-allocation env)
722        (nx-inhibit-register-allocation))
723      (setq *nx-new-p2decls*
724            (if (eql (safety-optimize-quantity env) 3)
725              (logior $decl_full_safety
726                      (if (nx-tailcalls env) $decl_tailcalls 0))
727              (%ilogior
728                (if (nx-tailcalls env) $decl_tailcalls 0)
729                (if (nx-open-code-in-line env) $decl_opencodeinline 0)
730                (if (nx-inhibit-safety-checking env) $decl_unsafe 0)
731                (if (nx-trust-declarations env) $decl_trustdecls 0)))))))
732
733#|     
734(defun nx-find-misc-decl (declname env)
735  (loop
736    (unless (and env (eq (uvref env 0) 'lexical-environment)) (return))
737    (dolist (mdecl (lexenv.mdecls env))
738      (if (atom mdecl)
739        (if (eq mdecl declname)
740          (return-from nx-find-misc-decl t))
741        (if (eq (%car mdecl) declname)
742          (return-from nx-find-misc-decl (%cdr mdecl)))))
743    (setq env (lexenv.parent-env env))))
744|#
745
746
747(defun nx-bad-decls (decls)
748  (nx1-whine :unknown-declaration decls))
749
750
751
752(defnxdecl special (pending decl env)
753  (declare (ignore env))
754  (dolist (s (%cdr decl))
755    (if (symbolp s) 
756      (nx-new-vdecl pending s 'special)
757      (nx-bad-decls decl))))
758
759(defnxdecl dynamic-extent (pending decl env)
760  (declare (ignore env))
761  (dolist (s (%cdr decl))
762    (if (symbolp s) 
763      (nx-new-vdecl pending s 'dynamic-extent t)
764      (if (and (consp s)
765               (eq (%car s) 'function)
766               (consp (%cdr s))
767               (valid-function-name-p (cadr s))
768               (setq s (validate-function-name (cadr s))))
769        (nx-new-fdecl pending s 'dynamic-extent t)
770        (nx-bad-decls decl)))))
771
772(defnxdecl ignorable (pending decl env)
773  (declare (ignore env))
774  (dolist (s (%cdr decl))
775    (if (symbolp s) 
776      (nx-new-vdecl pending s 'ignore-if-unused t)
777      (if (and (consp s)
778               (eq (%car s) 'function)
779               (consp (%cdr s))
780               (valid-function-name-p (cadr s))
781               (setq s (validate-function-name (cadr s))))
782        (nx-new-fdecl pending s 'ignore-if-unused t)
783        (nx-bad-decls decl)))))
784
785(defnxdecl ftype (pending decl env)
786  (declare (ignore env))
787  (destructuring-bind (type &rest fnames) (%cdr decl)
788    (dolist (s fnames)
789      (nx-new-fdecl pending s 'ftype type))))
790
791(defnxdecl settable (pending decl env)
792  (nx-settable-decls pending decl env t))
793
794(defnxdecl unsettable (pending decl env)
795  (nx-settable-decls pending decl env nil))
796
797(defun nx-settable-decls (pending decl env val)
798  (declare (ignore env))
799  (dolist (s (%cdr decl))
800    (if (symbolp s)
801      (nx-new-vdecl pending s 'settable val)
802      (nx-bad-decls decl))))
803
804(defnxdecl type (pending decl env)
805  (declare (ignore env))
806  (labels ((kludge (type) ; 0 => known, 1 => unknown, 2=> illegal
807             (cond ((type-specifier-p type)
808                    0)
809                   ((and (consp type)
810                         (member (car type) '(and or))
811                         (not (null (list-length type))))
812                    (do ((result 0 (max result (kludge (car tail))))
813                         (tail (cdr type) (cdr tail)))
814                        ((null tail)
815                         result)))
816                   ((not (symbolp type))
817                    ;;>>>> nx-bad-decls shouldn't signal a fatal error!!!!
818                    ;;>>>> Most callers of nx-bad-decls should just ignore the
819                    ;;>>>> losing decl element and proceed with the rest
820                    ;;>>>>  (ie (declare (ignore foo (bar) baz)) should
821                    ;;>>>>   have the effect of ignoring foo and baz as well
822                    ;;>>>>   as WARNING about the mal-formed declaration.)
823                    (nx-bad-decls decl)
824                    2)
825                   (t 1))))
826    (let* ((spec (%cdr decl))
827           (type (car spec)))
828      (case (kludge type)
829        ((0)
830         (dolist (sym (cdr spec))
831           (if (symbolp sym)
832             (nx-new-vdecl pending sym 'type type)
833             (nx-bad-decls decl))))
834        ((1)
835         (dolist (sym (cdr spec))
836           (unless (symbolp sym)
837             (nx-bad-decls decl))))
838        ((2)
839         (nx-bad-decls decl))))))
840
841
842
843(defnxdecl global-function-name (pending decl env)
844  (declare (ignore pending))
845  (when *nx-parsing-lambda-decls*
846    (let ((name (cadr decl)))
847      (setq *nx-global-function-name* (setf (afunc-name *nx-current-function*) name))
848      (setq *nx-inlined-self* (not (nx-declared-notinline-p name env))))))
849
850(defnxdecl debugging-function-name (pending decl env)
851  (declare (ignore pending env))
852  (when *nx-parsing-lambda-decls*
853    (setf (afunc-name *nx-current-function*) (cadr decl))))
854
855(defnxdecl resident (pending decl env)
856  (declare (ignore env pending))
857  (declare (ignore decl))
858  (nx-decl-set-fbit $fbitresident))
859
860
861(defun nx-inline-decl (pending decl val &aux valid-name)
862  (dolist (s (%cdr decl))
863    (multiple-value-setq (valid-name s) (valid-function-name-p s))
864    (if valid-name
865      (progn
866        (if (nx-self-call-p s nil t)
867          (setq *nx-inlined-self* val))
868        (nx-new-fdecl pending s 'inline (if val 'inline 'notinline)))
869      (nx-bad-decls decl))))
870
871(defnxdecl inline (pending decl env)
872  (declare (ignore env))
873  (nx-inline-decl pending decl t))
874
875(defnxdecl notinline (pending decl env)
876  (declare (ignore env))
877  (nx-inline-decl pending decl nil))
878
879(defnxdecl ignore (pending decl env)
880  (declare (ignore env))
881  (dolist (s (%cdr decl))
882    (if (symbolp s)     
883      (nx-new-vdecl pending s 'ignore t)
884      (if (and (consp s)
885               (eq (%car s) 'function)
886               (consp (%cdr s))
887               (valid-function-name-p (cadr s))
888               (setq s (validate-function-name (cadr s))))
889        (nx-new-fdecl pending s 'ignore t)
890        (nx-bad-decls decl)))))
891
892(defnxdecl ignore-if-unused (pending decl env)
893  (declare (ignore env))
894  (dolist (s (%cdr decl))
895    (if (symbolp s) 
896      (nx-new-vdecl pending s 'ignore-if-unused)
897      (nx-bad-decls decl))))
898
899(defun nx-self-call-p (name &optional ignore-lexical (allow *nx-inlined-self*))
900  (when (and name (symbolp name))
901    (let ((current-afunc *nx-current-function*)
902          (target-afunc (unless ignore-lexical (nth-value 1 (nx-lexical-finfo name)))))
903      (or (eq current-afunc target-afunc)
904          (and allow
905               (eq name *nx-global-function-name*)
906               (null target-afunc)
907               (null (afunc-parent current-afunc)))))))
908
909(defun nx-check-var-usage (var)
910  (let* ((sym (var-name var))
911         (bits (nx-var-bits var))
912         (expansion (var-ea var))
913         (setqed (%ilogbitp $vbitsetq bits))
914         (reffed (%ilogbitp $vbitreffed bits))
915         (closed (%ilogbitp $vbitclosed bits))
916         (special (%ilogbitp $vbitspecial bits))
917         (ignored (%ilogbitp $vbitignore bits))
918         (ignoreunused (%ilogbitp $vbitignoreunused bits)))
919    (if (or special reffed closed)
920      (progn
921        (if ignored (nx1-whine :ignore sym))
922        (nx-set-var-bits var (%ilogand (nx-check-downward-vcell var bits) (%ilognot (%ilsl $vbitignore 1)))))
923      (progn
924        (if (and setqed ignored) (nx1-whine :ignore sym))
925        (or ignored ignoreunused 
926            (progn (and (consp expansion) (eq (car expansion) :symbol-macro) (setq sym (list :symbol-macro sym))) (nx1-whine :unused sym)))
927        (when (%izerop (%ilogand bits (%ilogior $vrefmask $vsetqmask)))
928          (nx-set-var-bits var (%ilogior (%ilsl $vbitignore 1) bits)))))))
929
930; if an inherited var isn't setqed, it gets no vcell.  If it -is- setqed, but
931; all inheritors are downward, the vcell can be stack-consed.  Set a bit so that
932; the right thing happens when the var is bound.
933; Set the bit for the next-method var even if it is not setqed.
934(defun nx-check-downward-vcell (v bits)
935  (if (and (%ilogbitp $vbitclosed bits)
936           (or (%ilogbitp $vbitsetq bits)
937               (eq v *nx-next-method-var*))
938           (nx-afuncs-downward-p v (afunc-inner-functions *nx-current-function*)))
939    (%ilogior (%ilsl $vbitcloseddownward 1) bits)
940    bits))
941
942; afunc is "downward wrt v" if it doesn't inherit v or if all refs to afunc
943; are "downward" and no inner function of afunc is not downward with respect to v.
944(defun nx-afunc-downward-p (v afunc)
945  (or (dolist (i (afunc-inherited-vars afunc) t)
946        (when (eq (nx-root-var i) v) (return nil)))
947      (if (nx-afuncs-downward-p v (afunc-inner-functions afunc))
948        (eq (afunc-fn-refcount afunc)
949            (afunc-fn-downward-refcount afunc)))))
950
951(defun nx-afuncs-downward-p (v afuncs)
952  (dolist (afunc afuncs t)
953    (unless (nx-afunc-downward-p v afunc) (return nil))))
954
955(defun nx1-punt-bindings (vars initforms)
956  (dolist (v vars)
957    (nx1-punt-var v (pop initforms))))
958
959;;; at the beginning of a binding construct, note which lexical
960;;; variables are bound to other variables and the number of setqs
961;;; done so far on the initform.  After executing the body, if neither
962;;; variable has been closed over, the new variable hasn't been
963;;; setq'ed, and the old guy wasn't setq'ed in the body, the binding
964;;; can be punted.
965(defun nx1-note-var-binding (var initform)
966  (let* ((init (nx-untyped-form initform))
967         (inittype (nx-acode-form-type initform *nx-lexical-environment*))
968         (bits (nx-var-bits var)))
969    (when (%ilogbitp $vbitspecial bits) (nx-record-xref-info :binds (var-name var)))
970    (when inittype (setf (var-inittype var) inittype))
971    (when (and (not (%ilogbitp $vbitspecial bits))
972               (consp init))
973      (let* ((op (acode-operator init)))
974        (if (eq op (%nx1-operator lexical-reference))
975          (let* ((target (%cadr init))
976                 (setq-count (%ilsr 8 (%ilogand $vsetqmask (nx-var-bits target)))))
977            (unless (eq setq-count (%ilsr 8 $vsetqmask))
978              (cons var (cons setq-count target))))
979          (if (and (%ilogbitp $vbitdynamicextent bits)
980                   (or (eq op (%nx1-operator closed-function))
981                       (eq op (%nx1-operator simple-function))))
982            (let* ((afunc (%cadr init)))
983              (setf (afunc-fn-downward-refcount afunc)
984                    (afunc-fn-refcount afunc)
985                    (afunc-bits afunc) (logior (ash 1 $fbitdownward) (ash 1 $fbitbounddownward)
986                                               (the fixnum (afunc-bits afunc))))
987              nil)))))))
988
989
990;;; Process entries involving variables bound to other variables at
991;;; the end of a binding construct.  Each entry is of the form
992;;; (source-var setq-count . target-var), where setq-count is the
993;;; assignment count of TARGET-VAR at the time that the binding's
994;;; initform was evaluated (not, in the case of LET, at the time that
995;;; the bindinw was established.).  If the target isn't closed-over
996;;; and SETQed (somewhere), and wasn't setqed in the body (e.g.,
997;;; still has the same assignment-count as it had when the initform
998;;; was executed), then we can "punt" the source (and replace references
999;;; to it with references to the target.)
1000;;; It obviously makes no sense to do this if the source is SPECIAL;
1001;;; in some cases (LET), we create the source variable and add it to
1002;;; this alist before it's known whether or not the source variable
1003;;; is SPECIAL. so we have to ignore that case here.
1004(defun nx1-check-var-bindings (alist)
1005  (dolist (pair alist)
1006    (let* ((var (car pair))
1007           (target (cddr pair))
1008           (vbits (nx-var-bits var))
1009           (target-bits (nx-var-bits target)))
1010      (unless (or
1011               ;; var can't be special, setq'ed or closed; target can't be
1012               ;; setq'ed AND closed.
1013               (neq (%ilogand vbits (%ilogior (%ilsl $vbitsetq 1)
1014                                              (%ilsl $vbitclosed 1)
1015                                              (%ilsl $vbitspecial 1))) 0)
1016               (eq (%ilogior (%ilsl $vbitsetq 1) (%ilsl $vbitclosed 1)) 
1017                   (%ilogand
1018                     (%ilogior (%ilsl $vbitsetq 1) (%ilsl $vbitclosed 1))
1019                     target-bits))
1020               (neq (%ilsr 8 (%ilogand $vsetqmask target-bits)) (cadr pair)))
1021             (push (cons var target) *nx-punted-vars*)))))
1022
1023(defun nx1-punt-var (var initform)
1024  (let* ((bits (nx-var-bits var))
1025         (mask (%ilogior (%ilsl $vbitsetq 1) (ash -1 $vbitspecial) (%ilsl $vbitclosed 1)))
1026         (nrefs (%ilogand $vrefmask bits))
1027         (val (nx-untyped-form initform))
1028         (op (if (acode-p val) (acode-operator val))))
1029    (when (%izerop (%ilogand mask bits))
1030      (if
1031        (or 
1032         (nx-t val)
1033         (nx-null val)
1034         (and (eql nrefs 1) (not (logbitp $vbitdynamicextent bits)) ( acode-absolute-ptr-p val t))
1035         (eq op (%nx1-operator fixnum))
1036         (eq op (%nx1-operator immediate)))
1037        (progn
1038          (nx-set-var-bits var (%ilogior (%ilsl $vbitpuntable 1) bits)))))
1039    (when (and (%ilogbitp $vbitdynamicextent bits)
1040               (or (eq op (%nx1-operator closed-function))
1041                   (eq op (%nx1-operator simple-function))))
1042      (let* ((afunc (cadr val)))
1043        (setf (afunc-bits afunc) (%ilogior (%ilsl $fbitbounddownward 1) (afunc-bits afunc))
1044              (afunc-fn-downward-refcount afunc) 1))) 
1045    nil))
1046           
1047(defnxdecl optimize (pending specs env)
1048  (declare (ignore env))
1049  (let* ((q nil)
1050         (v nil)
1051         (mdecls (pending-declarations-mdecls pending)))
1052    (dolist (spec (%cdr specs) (setf (pending-declarations-mdecls pending) mdecls))
1053      (if (atom spec)
1054        (setq q spec v 3)
1055        (setq q (%car spec) v (cadr spec)))
1056      (if (and (fixnump v) (<= 0 v 3) (memq q '(speed space compilation-speed safety debug)))
1057        (push (cons q v) mdecls)
1058        (nx-bad-decls specs)))))
1059
1060(defun %proclaim-optimize (specs &aux q v)
1061 (dolist (spec specs)
1062  (if (atom spec)
1063   (setq q spec v 3)
1064   (setq q (%car spec) v (cadr spec)))
1065  (when (and (fixnump v) (<= 0 v 3))
1066   (if (eq q 'speed)
1067    (setq *nx-speed* v)
1068    (if (eq q 'space)
1069     (setq *nx-space* v)
1070     (if (eq q 'compilation-speed)
1071      (setq *nx-cspeed* v)
1072      (if (eq q 'safety)
1073       (setq *nx-safety* v)
1074       (if (eq q 'debug)
1075         (setq *nx-debug* v)))))))))
1076
1077(defun nx-lexical-finfo (sym &optional (env *nx-lexical-environment*))
1078  (let* ((info nil)
1079         (barrier-crossed nil))
1080    (if env
1081      (loop
1082        (when (eq 'barrier (lexenv.variables env))
1083          (setq barrier-crossed t))
1084        (when (setq info (%cdr (assq sym (lexenv.functions env))))
1085          (return (values info (if (and (eq (car info) 'function)
1086                                        (consp (%cdr info)))
1087                                 (progn
1088                                   (when barrier-crossed
1089                                     (nx-error "Illegal reference to lexically-defined function ~S." sym))
1090                                   (%cadr info))))))
1091        (if (listp (setq env (lexenv.parent-env env)))
1092          (return (values nil nil))))
1093      (values nil nil))))
1094
1095(defun nx-inline-expansion (sym &optional (env *nx-lexical-environment*) global-only)
1096  (let* ((lambda-form nil)
1097         (containing-env nil)
1098         (token nil))
1099    (if (and (nx-declared-inline-p sym env)
1100             (not (gethash sym *nx1-alphatizers*))
1101             (not *nx-current-code-note*))
1102      (multiple-value-bind (info afunc) (unless global-only (nx-lexical-finfo sym env))
1103        (if info (setq token afunc 
1104                       containing-env (afunc-environment afunc)
1105                       lambda-form (afunc-lambdaform afunc)))
1106        (setq info (cdr (retrieve-environment-function-info sym env)))
1107        (if (def-info.lambda info)
1108            (setq lambda-form (def-info.lambda info)
1109                  token sym
1110                  containing-env (new-lexical-environment (definition-environment env)))
1111            (unless info
1112              (if (cdr (setq info (assq sym *nx-globally-inline*)))
1113                (setq lambda-form (%cdr info)
1114                      token sym
1115                      containing-env (new-lexical-environment (new-definition-environment nil))))))))
1116    (values lambda-form (nx-closed-environment env containing-env) token)))
1117
1118(defun nx-closed-environment (current-env target)
1119  (when target
1120    (let* ((intervening-functions nil))
1121      (do* ((env current-env (lexenv.parent-env env)))
1122           ((or (eq env target) (null env) (istruct-typep env 'definition-environment)))
1123        (let* ((fn (lexenv.lambda env)))
1124          (when fn (push fn intervening-functions))))
1125      (let* ((result target))
1126        (dolist (fn intervening-functions result)
1127          (setf (lexenv.lambda (setq result (new-lexical-environment result))) fn))))))
1128
1129(defun nx-root-var (v)
1130  (do* ((v v bits)
1131        (bits (var-bits v) (var-bits v)))
1132       ((fixnump bits) v)))
1133
1134(defun nx-reconcile-inherited-vars (more)
1135  (let ((last nil)) ; Bop 'til ya drop.
1136    (loop
1137      (setq last more more nil)
1138      (dolist (callee last)
1139        (dolist (caller (afunc-callers callee))
1140          (unless (or (eq caller callee)
1141                      (eq caller (afunc-parent callee)))
1142            (dolist (v (afunc-inherited-vars callee))
1143              (let ((root-v (nx-root-var v)))
1144                (unless (dolist (caller-v (afunc-inherited-vars caller))
1145                          (when (eq root-v (nx-root-var caller-v))
1146                            (return t)))
1147                  ; caller must inherit root-v in order to call callee without using closure.
1148                  ; can't just bind afunc & call nx-lex-info here, 'cause caller may have
1149                  ; already shadowed another var with same name.  So:
1150                  ; 1) find the ancestor of callee which bound v; this afunc is also an ancestor
1151                  ;    of caller
1152                  ; 2) ensure that each afunc on the inheritance path from caller to this common
1153                  ;    ancestor inherits root-v.
1154                  (let ((ancestor (afunc-parent callee))
1155                        (inheritors (list caller)))
1156                    (until (eq (setq v (var-bits v)) root-v)
1157                      (setq ancestor (afunc-parent ancestor)))
1158                    (do* ((p (afunc-parent caller) (afunc-parent p)))
1159                         ((eq p ancestor))
1160                      (push p inheritors))
1161                    (dolist (f inheritors)
1162                      (setq v (nx-cons-var (var-name v) v))
1163                      (unless (dolist (i (afunc-inherited-vars f))
1164                                (when (eq root-v (nx-root-var i))
1165                                  (return (setq v i))))
1166                        (pushnew f more)
1167                        (push v (afunc-inherited-vars f))
1168                        ; change shared structure of all refs in acode with one swell foop.
1169                        (nx1-afunc-ref f))))))))))   
1170      (unless more (return)))))
1171
1172(defun nx-inherit-var (var binder current)
1173  (if (eq binder current)
1174    (progn
1175      (nx-set-var-bits var (%ilogior2 (%ilsl $vbitclosed 1) (nx-var-bits var)))
1176      var)
1177    (let ((sym (var-name var)))
1178      (or (dolist (already (afunc-inherited-vars current))
1179            (when (eq sym (var-name already)) (return already)))
1180          (progn
1181            (setq var (nx-cons-var sym (nx-inherit-var var binder (afunc-parent current))))
1182            (push var (afunc-inherited-vars current))
1183            var)))))
1184
1185(defun nx-lex-info (sym &optional current-only)
1186  (let* ((current-function *nx-current-function*)
1187         (catch nil)
1188         (barrier-crossed nil))
1189    (multiple-value-bind 
1190      (info afunc)
1191      (do* ((env *nx-lexical-environment* (lexenv.parent-env env))
1192            (continue env (and env (not (istruct-typep env 'definition-environment))))
1193            (binder current-function (or (if continue (lexenv.lambda env)) binder)))
1194           ((or (not continue) (and (neq binder current-function) current-only)) 
1195            (values nil nil))
1196        (let ((vars (lexenv.variables env)))
1197          (if (eq vars 'catch) 
1198            (setq catch t)
1199            (if (eq vars 'barrier)
1200              (setq barrier-crossed t)
1201              (let ((v (dolist (var vars)
1202                         (when (eq (var-name var) sym) (return var)))))
1203                (when v (return (values v binder)))
1204                (dolist (decl (lexenv.vdecls env))
1205                  (when (and (eq (car decl) sym)
1206                             (eq (cadr decl) 'special))
1207                    (return-from nx-lex-info (values :special nil nil)))))))))
1208      (if info
1209        (if (var-expansion info)
1210          (values :symbol-macro (cdr (var-expansion info)) info)
1211          (if (%ilogbitp $vbitspecial (nx-var-bits info))
1212            (values :special info nil)
1213            (if barrier-crossed
1214              (nx-error "Illegal reference to lexically defined variable ~S." sym)
1215              (if (eq afunc current-function)
1216                (values info nil catch)
1217                (values (nx-inherit-var info afunc current-function) t catch)))))
1218        (values nil nil nil)))))
1219
1220
1221(defun nx-block-info (blockname &optional (afunc *nx-current-function*) &aux
1222  blocks
1223  parent
1224  (toplevel (eq afunc *nx-current-function*))
1225  blockinfo)
1226 (when afunc
1227  (setq
1228   blocks (if toplevel *nx-blocks* (afunc-blocks afunc))
1229   blockinfo (assq blockname blocks)
1230   parent (afunc-parent afunc))
1231  (if blockinfo
1232   (values blockinfo nil)
1233   (when parent
1234    (when (setq blockinfo (nx-block-info blockname parent))
1235     (values blockinfo t))))))
1236
1237(defun nx-tag-info (tagname &optional (afunc *nx-current-function*) &aux
1238                            tags
1239                            parent
1240                            index
1241                            counter
1242                            (toplevel (eq afunc *nx-current-function*))
1243                            taginfo)
1244  (when afunc
1245    (setq
1246     tags (if toplevel *nx-tags* (afunc-tags afunc))
1247     taginfo (assoc tagname tags)
1248     parent (afunc-parent afunc))
1249    (if taginfo
1250      (values taginfo nil)
1251      (when (and parent (setq taginfo (nx-tag-info tagname parent)))
1252        (unless (setq index (cadr taginfo))
1253          (setq counter (caddr taginfo))
1254          (%rplaca counter (%i+ (%car counter) 1))
1255          (setq index (%car counter))
1256          (%rplaca (%cdr taginfo) index))
1257        (values taginfo index)))))
1258
1259(defun nx1-transitively-punt-bindings (pairs) 
1260  (dolist (pair (nreverse pairs))
1261    (let* ((var         (%car pair))
1262           (boundto     (%cdr pair))
1263           (varbits     (nx-var-bits var))
1264           (boundtobits (nx-var-bits boundto)))
1265      (declare (fixnum varbits boundtobits))
1266      (unless (eq (%ilogior
1267                    (%ilsl $vbitsetq 1)
1268                    (%ilsl $vbitclosed 1))
1269                  (%ilogand
1270                    (%ilogior
1271                      (%ilsl $vbitsetq 1)
1272                      (%ilsl $vbitclosed 1))
1273                    boundtobits))
1274        ;; Can't happen -
1275        (unless (%izerop (%ilogand (%ilogior
1276                                     (%ilsl $vbitsetq 1) 
1277                                     (ash -1 $vbitspecial)
1278                                     (%ilsl $vbitclosed 1)) varbits))
1279          (error "Bug-o-rama - \"punted\" var had bogus bits. ~
1280Or something. Right? ~s ~s" var varbits))
1281        (let* ((varcount     (%ilogand $vrefmask varbits)) 
1282               (boundtocount (%ilogand $vrefmask boundtobits)))
1283          (nx-set-var-bits var (%ilogior
1284                                 (%ilsl $vbitpuntable 1)
1285                                 (%i- varbits varcount)))
1286              (nx-set-var-bits
1287               boundto
1288                 (%i+ (%i- boundtobits boundtocount)
1289                      (%ilogand $vrefmask
1290                                (%i+ (%i- boundtocount 1) varcount)))))))))
1291
1292(defvar *nx1-source-note-map* nil
1293  "Mapping between nx1-forms source locations.")
1294
1295;; Home-baked handler-case replacement.  About 10 times as fast as full handler-case.
1296;;(LET ((S 0)) (DOTIMES (I 1000000) (INCF S))) took 45,678 microseconds
1297;;(LET ((S 0)) (DOTIMES (I 1000000) (BLOCK X (ERROR (CATCH 'X (RETURN-FROM X (INCF S))))))) took 57,485
1298;;(LET ((S 0)) (DOTIMES (I 1000000) (HANDLER-CASE (INCF S) (ERROR (C) C)))) took 168,947
1299(defmacro with-program-error-handler (handler &body body)
1300  (let ((tag (gensym)))
1301    `(block ,tag
1302       (,handler (catch 'program-error-handler (return-from ,tag (progn ,@body)))))))
1303
1304(defun runtime-program-error-form (c)
1305  `(signal-program-error "Invalid program: ~a" ,(princ-to-string c)))
1306
1307(defun nx1-compile-lambda (name lambda-form &optional
1308                                 (p (make-afunc))
1309                                 q
1310                                 parent-env
1311                                 (policy *default-compiler-policy*)
1312                                 load-time-eval-token)
1313  (if q
1314     (setf (afunc-parent p) q))
1315
1316  ;; In the case of a method function, the name will get reset at load time to the
1317  ;; method object.  However, during compilation, we want any inner functions to use
1318  ;; the fully qualified method name, so store that.
1319  (when (method-lambda-p lambda-form)
1320    (setq name (or *nx-method-warning-name* name)))
1321
1322  (setf (afunc-name p)
1323        (let ((parent-name (and (afunc-parent p) (afunc-name (afunc-parent p)))))
1324          (if parent-name
1325            (if (and (consp parent-name) (eq (%car parent-name) :internal))
1326              (if name
1327                `(:internal ,name ,@(cdr parent-name))
1328                parent-name)
1329              (if name
1330                `(:internal ,name ,parent-name)
1331                `(:internal ,parent-name)))
1332            name)))
1333
1334  (when *definition-source-note*
1335    (setf (afunc-lfun-info p)
1336          (list* 'function-source-note
1337                 (source-note-for-%lfun-info *definition-source-note*)
1338                 (afunc-lfun-info p))))
1339  (unless (lambda-expression-p lambda-form)
1340    (nx-error "~S is not a valid lambda expression." lambda-form))
1341  (let* ((*nx-current-function* p)
1342         (*nx-parent-function* q)
1343         (*nx-lexical-environment* (new-lexical-environment parent-env))
1344         (*nx-load-time-eval-token* load-time-eval-token)
1345         (*nx-all-vars* nil)
1346         (*nx-bound-vars* nil)
1347         (*nx-punted-vars* nil)
1348         (*nx-current-compiler-policy* policy)
1349         (*nx-blocks* nil)
1350         (*nx-tags* nil)
1351         (*nx-loop-nesting-level* 0)
1352         (*nx-inner-functions* nil)
1353         (*nx-global-function-name* nil)
1354         (*nx-warnings* nil)
1355         (*nx1-fcells* nil)
1356         (*nx1-vcells* nil)
1357         (*nx-inline-expansions* nil)
1358         (*nx-parsing-lambda-decls* nil)
1359         (*nx-next-method-var* (if q *nx-next-method-var*))
1360         (*nx-call-next-method-function* (if q *nx-call-next-method-function*))
1361         (*nx-cur-func-name* name))
1362    (if (%non-empty-environment-p *nx-lexical-environment*)
1363      (setf (afunc-bits p) (logior (ash 1 $fbitnonnullenv) (the fixnum (afunc-bits p)))))
1364
1365    (setf (afunc-lambdaform p) lambda-form)
1366    (with-program-error-handler
1367        (lambda (c)
1368          (setf (afunc-acode p) (nx1-lambda '(&rest args) `(args ,(runtime-program-error-form c)) nil)))
1369      (handler-bind ((warning (lambda (c)
1370                                (nx1-whine :program-error c)
1371                                (muffle-warning c)))
1372                     (program-error (lambda (c)
1373                                      (when *nx-break-on-program-errors*
1374                                        (cerror "continue compilation ignoring this form" c))
1375                                      (when (typep c 'compile-time-program-error)
1376                                        (setq c (make-condition 'simple-program-error
1377                                                                :format-control (simple-condition-format-control c)
1378                                                                :format-arguments (simple-condition-format-arguments c))))
1379                                      (unless *nx-break-on-program-errors*
1380                                        (nx1-whine :program-error c))
1381                                      (throw 'program-error-handler c))))
1382        (multiple-value-bind (body decls)
1383            (with-program-error-handler (lambda (c) (runtime-program-error-form c))
1384              (parse-body (%cddr lambda-form) *nx-lexical-environment* t))
1385          (setf (afunc-acode p) (nx1-lambda (%cadr lambda-form) body decls)))))
1386
1387    (nx1-transitively-punt-bindings *nx-punted-vars*)
1388    (setf (afunc-blocks p) *nx-blocks*)
1389    (setf (afunc-tags p) *nx-tags*)
1390    (setf (afunc-inner-functions p) *nx-inner-functions*)
1391    (setf (afunc-all-vars p) *nx-all-vars*)
1392    (setf (afunc-vcells p) *nx1-vcells*)
1393    (setf (afunc-fcells p) *nx1-fcells*)
1394    (let* ((warnings (merge-compiler-warnings *nx-warnings*))
1395           (name *nx-cur-func-name*))       
1396      (dolist (inner *nx-inner-functions*)
1397        (dolist (w (afunc-warnings inner))
1398          (push name (compiler-warning-function-name w))
1399          (push w warnings)))
1400      (setf (afunc-warnings p) warnings))
1401    p))
1402
1403(defun method-lambda-p (form)
1404  (and (consp form)
1405       (consp (setq form (%cdr form)))       
1406       (eq (caar form) '&method)))
1407
1408
1409(defun nx1-lambda (ll body decls &aux (l ll) methvar)
1410  (let* ((old-env *nx-lexical-environment*)
1411         (*nx-bound-vars* *nx-bound-vars*))
1412    (with-nx-declarations (pending)
1413      (let* ((*nx-parsing-lambda-decls* t))
1414        (nx-process-declarations pending decls))
1415      (when (eq (car l) '&lap)
1416        (let ((bits nil))
1417          (unless (and (eq (length (%cdr l)) 1) (fixnump (setq bits (%cadr l))))
1418            (unless (setq bits (encode-lambda-list (%cdr l)))
1419              (nx-error "invalid lambda-list  - ~s" l)))
1420          (return-from nx1-lambda
1421                       (make-acode
1422                        (%nx1-operator lambda-list)
1423                        (list (cons '&lap bits))
1424                        nil
1425                        nil
1426                        nil
1427                        nil
1428                        (nx1-env-body body old-env)
1429                        *nx-new-p2decls*))))
1430      (when (eq (car l) '&method)
1431        (setf (afunc-bits *nx-current-function*)
1432              (%ilogior (%ilsl $fbitmethodp 1)
1433                        (afunc-bits *nx-current-function*)))
1434        (setq *nx-inlined-self* nil)
1435        (setq *nx-next-method-var* (setq methvar (let ((var (nx-new-var
1436                                                             pending
1437                                                             (%cadr ll))))
1438                                                   (nx-set-var-bits var (%ilogior 
1439                                                                          (%ilsl $vbitignoreunused 1) 
1440                                                                          ;(%ilsl $vbitnoreg 1)
1441                                                                          (nx-var-bits var)))
1442                                                   var)))
1443                                                   
1444        (setq ll (%cddr ll)))
1445      (multiple-value-bind (req opt rest keys auxen lexpr)
1446                           (nx-parse-simple-lambda-list pending ll)
1447        (nx-effect-other-decls pending *nx-lexical-environment*)
1448        (setq body (nx1-env-body body old-env))
1449        (nx1-punt-bindings (%car auxen) (%cdr auxen))         
1450        (when methvar
1451          (push methvar req)
1452          (unless (eq 0 (%ilogand (%ilogior (%ilsl $vbitreffed 1)
1453                                            (%ilsl $vbitclosed 1)
1454                                            (%ilsl $vbitsetq 1))
1455                                  (nx-var-bits methvar)))
1456            (setf (afunc-bits *nx-current-function*)
1457                  (%ilogior 
1458                   (%ilsl $fbitnextmethp 1)
1459                   (afunc-bits *nx-current-function*)))))
1460        (make-acode
1461         (%nx1-operator lambda-list) 
1462         req
1463         opt 
1464         (if lexpr (list rest) rest)
1465         keys
1466         auxen
1467         body
1468         *nx-new-p2decls*
1469         *nx-current-code-note*)))))
1470
1471(defun nx-parse-simple-lambda-list (pending ll &aux
1472                                              req
1473                                              opt
1474                                              rest
1475                                              keys
1476                                              lexpr
1477                                              sym)
1478  (multiple-value-bind (ok reqsyms opttail resttail keytail auxtail)
1479                       (verify-lambda-list ll)
1480    (unless ok (nx-error "Bad lambda list : ~S" ll))
1481    (dolist (var reqsyms)
1482      (push (nx-new-var pending var t) req))
1483    (when (eq (pop opttail) '&optional)
1484      (let* (optvars optinits optsuppliedp)
1485        (until (eq opttail resttail) 
1486          (setq sym (pop opttail))
1487          (let* ((var sym)
1488                 (initform nil)
1489                 (spvar nil))
1490            (when (consp var)
1491              (setq sym (pop var) initform (pop var) spvar (%car var)))
1492            (push (nx1-typed-var-initform pending sym initform) optinits)
1493            (push (nx-new-var pending sym t) optvars)
1494            (push (if spvar (nx-new-var pending spvar t)) optsuppliedp)))
1495        (if optvars
1496          (setq opt (list (nreverse optvars) (nreverse optinits) (nreverse optsuppliedp)))
1497          (nx1-whine :lambda ll))))
1498    (let ((temp (pop resttail)))
1499      (when (or (eq temp '&rest)
1500                (setq lexpr (eq temp '&lexpr)))
1501        (setq rest (nx-new-var pending (%car resttail) t))))
1502    (when (eq (%car keytail) '&key) 
1503      (setq keytail (%cdr keytail))
1504      (let* ((keysyms ())
1505             (keykeys ())
1506             (keyinits ())
1507             (keysupp ())
1508             (kallowother (not (null (memq '&allow-other-keys ll))))
1509             (kvar ())
1510             (kkey ())
1511             (kinit ())
1512             (ksupp))
1513        (until (eq keytail auxtail)
1514          (unless (eq (setq sym (pop keytail)) '&allow-other-keys)     
1515            (setq kinit *nx-nil* ksupp nil)
1516            (if (atom sym)
1517              (setq kvar sym kkey (make-keyword sym))
1518              (progn
1519                (if (consp (%car sym))
1520                  (setq kkey (%caar sym) kvar (%cadar sym))
1521                  (progn
1522                    (setq kvar (%car sym))
1523                    (setq kkey (make-keyword kvar))))
1524                (setq kinit (nx1-typed-var-initform pending kvar (%cadr sym)))
1525                (setq ksupp (%caddr sym))))
1526            (push (nx-new-var pending kvar t) keysyms)
1527            (push kkey keykeys)
1528            (push kinit keyinits)
1529            (push (if ksupp (nx-new-var pending ksupp t)) keysupp)))
1530        (setq 
1531         keys
1532         (list
1533          kallowother
1534          (nreverse keysyms)
1535          (nreverse keysupp)
1536          (nreverse keyinits)
1537          (apply #'vector (nreverse keykeys))))))
1538    (let (auxvals auxvars)
1539      (dolist (pair (%cdr auxtail))
1540        (let* ((auxvar (nx-pair-name pair))
1541               (auxval (nx1-typed-var-initform pending auxvar (nx-pair-initform pair))))
1542          (push auxval auxvals)
1543          (push (nx-new-var pending auxvar t) auxvars)))
1544      (values
1545       (nreverse req) 
1546       opt 
1547       rest
1548       keys
1549       (list (nreverse auxvars) (nreverse auxvals))
1550       lexpr))))
1551
1552(defun nx-new-structured-var (pending sym)
1553  (if sym
1554    (nx-new-var pending sym t)
1555    (nx-new-temp-var pending)))
1556
1557(defun nx-parse-structured-lambda-list (pending ll &optional no-acode whole-p &aux
1558                                           req
1559                                           opt
1560                                           rest
1561                                           keys
1562                                           sym)
1563  (multiple-value-bind (ok reqsyms opttail resttail keytail auxtail all whole structured-p)
1564                       (verify-lambda-list ll t whole-p nil)
1565    (declare (ignore all))
1566    (unless ok (nx-error "Bad lambda list : ~S" ll))
1567    (if (or whole (and whole-p structured-p)) (setq whole (nx-new-structured-var pending whole)))
1568    (dolist (var reqsyms)
1569      (push (if (symbolp var)
1570                    (nx-new-structured-var pending var)
1571                    (nx-structured-lambda-form pending var no-acode))
1572                  req))
1573    (when (eq (pop opttail) '&optional)
1574      (let* (optvars optinits optsuppliedp)
1575        (until (eq opttail resttail) 
1576          (setq sym (pop opttail))
1577          (let* ((var sym)
1578                 (initform nil)
1579                 (spvar nil))
1580            (when (consp var)
1581              (setq sym (pop var) initform (pop var) spvar (%car var)))
1582            (push (if no-acode initform (nx1-form initform)) optinits)
1583            (push (if (symbolp sym)
1584                          (nx-new-structured-var pending sym)
1585                          (nx-structured-lambda-form pending sym no-acode))
1586                        optvars)
1587            (push (if spvar (nx-new-var pending spvar)) optsuppliedp)))
1588        (if optvars
1589          (setq opt (list (nreverse optvars) (nreverse optinits) (nreverse optsuppliedp)))
1590          (nx1-whine :lambda ll))))
1591    (let ((var (pop resttail)))
1592      (when (or (eq var '&rest)
1593                (eq var '&body))
1594        (setq var (pop resttail)
1595              rest (if (symbolp var)
1596                     (nx-new-structured-var pending var)
1597                     (nx-structured-lambda-form pending var no-acode)))))
1598    (when (eq (%car keytail) '&key) 
1599      (setq keytail (%cdr keytail))
1600      (let* ((keysyms ())
1601             (keykeys ())
1602             (keyinits ())
1603             (keysupp ())
1604             (kallowother (not (null (memq '&allow-other-keys ll))))
1605             (kvar ())
1606             (kkey ())
1607             (kinit ())
1608             (ksupp))
1609        (until (eq keytail auxtail)
1610          (unless (eq (setq sym (pop keytail)) '&allow-other-keys)     
1611            (setq kinit *nx-nil* ksupp nil)
1612            (if (atom sym)
1613              (setq kvar sym kkey (make-keyword sym))
1614              (progn
1615                (if (consp (%car sym))
1616                  (setq kkey (%caar sym) kvar (%cadar sym))
1617                  (progn
1618                    (setq kvar (%car sym))
1619                    (setq kkey (make-keyword kvar))))
1620                (setq kinit (if no-acode (%cadr sym) (nx1-form (%cadr sym))))
1621                (setq ksupp (%caddr sym))))
1622            (push (if (symbolp kvar)
1623                          (nx-new-structured-var pending kvar)
1624                          (nx-structured-lambda-form pending kvar no-acode))
1625                        keysyms)
1626            (push kkey keykeys)
1627            (push kinit keyinits)
1628            (push (if ksupp (nx-new-var pending ksupp)) keysupp)))
1629        (setq 
1630         keys
1631         (list
1632          kallowother
1633          (nreverse keysyms)
1634          (nreverse keysupp)
1635          (nreverse keyinits)
1636          (apply #'vector (nreverse keykeys))))))
1637    (let (auxvals auxvars)
1638      (dolist (pair (%cdr auxtail))
1639        (let ((auxvar (nx-pair-name pair))
1640              (auxval (nx-pair-initform pair)))
1641          (push (if no-acode auxval (nx1-form auxval)) auxvals)
1642          (push (nx-new-var pending auxvar) auxvars)))
1643      (values
1644       (nreverse req) 
1645       opt 
1646       rest 
1647       keys
1648       (list (nreverse auxvars) (nreverse auxvals))
1649       whole))))
1650
1651(defun nx-structured-lambda-form (pending l &optional no-acode)
1652  (multiple-value-bind (req opt rest keys auxen whole)
1653                       (nx-parse-structured-lambda-list pending l no-acode t)
1654    (list (%nx1-operator lambda-list) whole req opt rest keys auxen)))
1655
1656(defun %fast-compact-simple-string (string start end)
1657  (declare (simple-string string)
1658           (fixnum start end))
1659  (let* ((len (- end start))
1660         (noctets (utf-8-octets-in-string string start end))
1661         (vec (make-array noctets :element-type '(unsigned-byte 8))))
1662    (declare (fixnum len noctets)
1663             (type (simple-array (unsigned-byte 8) (*)) vec))
1664    (if (= len noctets)                 ;ASCII.
1665      (do* ((in start (1+ in))
1666            (out 0 (1+ out)))
1667           ((= in end))
1668        (declare (fixnum in out))
1669        (setf (aref vec out) (%scharcode string in)))
1670      (funcall (character-encoding-vector-encode-function
1671                (get-character-encoding :utf-8))
1672               string
1673               vec
1674               0
1675               start
1676               end))
1677    vec))
1678
1679(defun %fast-compact (string)
1680  ;; mb: bootstrap
1681  (when (typep string '(array (unsigned-byte 8) (*)))
1682    (return-from %fast-compact string))
1683  (when (null string)
1684    (return-from %fast-compact nil))
1685  (etypecase string
1686    (simple-string
1687     (%fast-compact-simple-string string 0 (uvsize string)))
1688    (string
1689     (multiple-value-bind (data offset)
1690         (array-data-and-offset string)
1691       (declare (fixnum offset))
1692       (%fast-compact-simple-string data offset (the fixnum (+ offset (length string))))))))
1693
1694(defun %fast-uncompact (data)
1695  (etypecase data
1696    ((simple-array (unsigned-byte 8) (*))
1697     (let* ((encoding (get-character-encoding :utf-8))
1698            (noctets (length data))
1699            (nchars (funcall (character-encoding-length-of-vector-encoding-function encoding)
1700                             data
1701                             0
1702                             noctets))
1703            (string (make-string nchars)))
1704       (declare (fixnum noctets nchars)
1705                (simple-string string))
1706       (if (= noctets nchars)           ;ASCII
1707         (dotimes (i nchars)
1708           (setf (%scharcode string i) (aref data i)))
1709         (funcall (character-encoding-vector-decode-function encoding)
1710                  data
1711                  0
1712                  noctets
1713                  string))
1714       string))
1715    (null data)
1716    (string data)))
1717
1718
1719(defvar *form-source-note-map* nil
1720  "Hash table used when compiling a top level definition to map lists of source code to their
1721  corresponding source notes.")
1722
1723#||
1724(defun make-source-note-form-map (source-note &optional existing-map)
1725  "Creates a mapping from lisp forms to source-notes based on SOURCE-NOTES. This should be bound to
1726*form-source-note-map* or similar."
1727  (let ((map (or existing-map (make-hash-table))))
1728    (labels ((walk (note)
1729               (cond
1730                 ((consp note)
1731                  (walk (car note))
1732                  (walk (cdr note)))
1733                 ((source-note-p note)
1734                  (when (and note (not (gethash (source-note-form note) map)))
1735                    (setf (gethash (source-note-form note) map) note)
1736                    (walk (source-note-subform-notes note))
1737                    (setf (source-note-subform-notes note) '())))
1738                 ((null note) '())
1739                 (t (error "Don't know how to deal with a source note like ~S."
1740                           note)))))
1741      (walk source-note))
1742    map))
1743||#
1744
1745(defun nx1-source-note (nx1-code)
1746  "Return the source-note for the form which generated NX1-CODE."
1747  (and *fasl-save-source-locations*
1748       *nx1-source-note-map*
1749       (gethash nx1-code *nx1-source-note-map*)))
1750
1751(defun form-source-note (source-form)
1752  (and *fasl-save-source-locations*
1753       *form-source-note-map*
1754       (gethash source-form *form-source-note-map*)))
1755
1756(defun find-source-at-pc (function pc)
1757  (let* ((function-source-note (getf (%lfun-info function) 'function-source-note))
1758         (pc-source-map (getf (%lfun-info function) 'pc-source-map)))
1759    (when pc-source-map
1760      (let* ((best-guess nil)
1761             (best-length nil)
1762             (len (length pc-source-map)))
1763        (declare (fixnum len))
1764        (do* ((q 0 (+ q 4))
1765              (r 1 (+ r 4)))
1766             ((= q len))
1767          (declare (fixnum q r))
1768          (let* ((pc-start (aref pc-source-map q))
1769                 (pc-end (aref pc-source-map r)))
1770            (declare (fixnum pc-start pc-end))
1771            (when (and (<= pc-start pc pc-end)
1772                        (or (null best-guess)
1773                            (< (- pc-end pc-start) best-length)))
1774               (setf best-guess q
1775                     best-length (- pc-end pc-start)))))
1776        (when best-guess
1777          (list :pc-range (cons (aref pc-source-map best-guess)
1778                                (aref pc-source-map (+ best-guess 1)))
1779                :source-text-range (cons (aref pc-source-map (+ best-guess 2))
1780                                         (aref pc-source-map (+ best-guess 3)))
1781                :file-name (getf function-source-note :file-name)
1782                :text (getf function-source-note :text)))))))
1783
1784(defun nx1-form (form &optional (*nx-lexical-environment* *nx-lexical-environment*))
1785  (let* ((*nx-form-type* (if (and (consp form) (eq (car form) 'the))
1786                           (nx-target-type (cadr form))
1787                           t)))
1788    (nx1-typed-form form *nx-lexical-environment*)))
1789
1790(defun nx1-typed-form (original env)
1791  (with-program-error-handler
1792      (lambda (c)
1793        (nx1-transformed-form (nx-transform (runtime-program-error-form c) env) env original))
1794    (nx1-transformed-form (nx-transform original env) env original)))
1795
1796(defun nx1-transformed-form (form env &optional original)
1797  (if *nx-current-code-note*
1798    ;; It is possible for the form to be a source form when the original is not: macros
1799    ;; often insert wrappings, e.g. (when (foo) (bar)) becomes (IF (foo) (PROGN (bar))),
1800    ;; and (PROGN (bar)) transforms into (bar), which is a source form.
1801    (let* ((new-note (nx-ensure-code-note form original *nx-current-code-note*))
1802           (*nx-current-code-note* new-note))
1803      (unless new-note
1804        (compiler-bug "No source note for ~s -> ~s" original form))
1805      (make-acode (%nx1-operator with-code-note)
1806                  new-note
1807                  (nx1-transformed-form-aux form env)))
1808    (nx1-transformed-form-aux form env)))
1809
1810(defun nx1-transformed-form-aux (form env)
1811  (flet ((main ()
1812           (if (consp form)
1813               (nx1-combination form env)
1814               (let* ((symbolp (non-nil-symbol-p form))
1815                      (constant-value (unless symbolp form))
1816                      (constant-symbol-p nil))
1817                 (if symbolp 
1818                     (multiple-value-setq (constant-value constant-symbol-p) 
1819                       (nx-transform-defined-constant form env)))
1820                 (if (and symbolp (not constant-symbol-p))
1821                     (nx1-symbol form env)
1822                     (nx1-immediate (nx-unquote constant-value)))))))
1823    (if *fasl-save-source-locations*
1824        (destructuring-bind (nx1-form . values)
1825            (multiple-value-list (main))
1826          (record-form-to-nx1-transformation form nx1-form)
1827          (values-list (cons nx1-form values)))
1828        (main))))
1829
1830(defun nx1-prefer-areg (form env)
1831  (nx1-form form env))
1832
1833(defun nx1-target-fixnump (form)
1834  (when (typep form 'integer)
1835       (let* ((target (backend-target-arch *target-backend*)))
1836         (and
1837          (>= form (arch::target-most-negative-fixnum target))
1838          (<= form (arch::target-most-positive-fixnum target))))))
1839
1840
1841(defun nx1-immediate (form)
1842  (if (or (eq form t) (null form))
1843    (nx1-sysnode form)
1844    (make-acode 
1845     (if (nx1-target-fixnump form) 
1846       (%nx1-operator fixnum)
1847        (%nx1-operator immediate))   ; Screw: chars
1848     form)))
1849
1850(defun nx-constant-form-p (form)
1851  (setq form (nx-untyped-form form))
1852  (and (or (nx-null form)
1853           (nx-t form)
1854           (and (acode-p form)
1855                (or (eq (acode-operator form) (%nx1-operator immediate))
1856                    (eq (acode-operator form) (%nx1-operator fixnum))
1857                    (eq (acode-operator form) (%nx1-operator simple-function))
1858                    (and (eq (acode-operator form) (%nx1-operator with-code-note))
1859                         (setq form (nx-constant-form-p (%caddr form)))))))
1860       form))
1861
1862(defun nx-natural-constant-p (form)
1863  (setq form (nx-untyped-form form))
1864  (if (consp form)
1865    (let* ((val (if (or (eq (acode-operator form) (%nx1-operator fixnum))
1866                        (eq (acode-operator form) (%nx1-operator immediate)))
1867                  (cadr form))))
1868      (target-word-size-case
1869       (32 (and (typep val '(unsigned-byte 32)) val))
1870       (64 (and (typep val '(unsigned-byte 64)) val))))))
1871
1872(defun nx-u32-constant-p (form)
1873  (setq form (nx-untyped-form form))
1874  (if (consp form)
1875    (let* ((val (if (or (eq (acode-operator form) (%nx1-operator fixnum))
1876                        (eq (acode-operator form) (%nx1-operator immediate)))
1877                  (cadr form))))
1878      (and (typep val '(unsigned-byte 32)) val))))
1879
1880(defun nx-u31-constant-p (form)
1881  (setq form (nx-untyped-form form))
1882  (if (consp form)
1883    (let* ((val (if (or (eq (acode-operator form) (%nx1-operator fixnum))
1884                        (eq (acode-operator form) (%nx1-operator immediate)))
1885                  (cadr form))))
1886      (and (typep val '(unsigned-byte 31)) val))))
1887
1888
1889;;; Reference-count vcell, fcell refs.
1890(defun nx1-note-vcell-ref (sym)
1891  (let* ((there (assq sym *nx1-vcells*))
1892         (count (expt 4 *nx-loop-nesting-level*)))
1893    (if there
1894      (%rplacd there (%i+ (%cdr there) count))
1895      (push (cons sym count) *nx1-vcells*)))
1896  sym)
1897
1898(defun nx1-note-fcell-ref (sym)
1899  (let* ((there (assq sym *nx1-fcells*))
1900         (count (expt 4 *nx-loop-nesting-level*)))
1901    (if there
1902      (%rplacd there (%i+ (%cdr there) count))
1903      (push (cons sym count) *nx1-fcells*))
1904    sym))
1905
1906; Note that "simple lexical refs" may not be; that's the whole problem ...
1907(defun nx1-symbol (form &optional (env *nx-lexical-environment*))
1908  (let* ((type (nx-declared-type form))
1909         (form
1910          (multiple-value-bind (info inherited-p more)
1911                               (nx-lex-info form)
1912            (if (and info (neq info :special))
1913              (if (eq info :symbol-macro)
1914                (progn
1915                  (nx-set-var-bits more (%ilogior (%ilsl $vbitreffed 1) (nx-var-bits more)))
1916                  (if (eq type t)
1917                    (nx1-form inherited-p)
1918                    (nx1-form `(the ,(prog1 type (setq type t)) ,inherited-p))))
1919                (progn
1920                  (when (not inherited-p)
1921                    (nx-set-var-bits info (%ilogior2 (%ilsl $vbitreffed 1) (nx-var-bits info)))
1922                    (nx-adjust-ref-count info))
1923                  (make-acode (%nx1-operator lexical-reference) info)))
1924              (make-acode
1925               (if (nx1-check-special-ref form info)
1926                   (progn
1927                     (nx-record-xref-info :references form)
1928                     (if (nx-global-p form env)
1929                         (%nx1-operator global-ref)
1930                         (if (and (not (nx-force-boundp-checks form env))
1931                                  (or (nx-proclaimed-parameter-p form)
1932                                  (assq form *nx-compile-time-types*)
1933                                  (assq form *nx-proclaimed-types*)
1934                                  (nx-open-code-in-line env)))
1935                             (%nx1-operator bound-special-ref)
1936                             (%nx1-operator special-ref))))
1937                   (%nx1-operator free-reference))
1938               (nx1-note-vcell-ref form))))))
1939    (if (eq type t)
1940        form
1941      (make-acode (%nx1-operator typed-form) type form))))
1942
1943(defun nx1-check-special-ref (form auxinfo)
1944  (or (eq auxinfo :special) 
1945      (nx-proclaimed-special-p form)
1946      (let ((defenv (definition-environment *nx-lexical-environment*)))
1947        (unless (and defenv (eq (car (defenv.type defenv)) :execute) (boundp form))
1948          (nx1-whine :special form))
1949        nil)))
1950
1951
1952
1953(defun nx1-whine (about &rest forms)
1954    (push (make-condition (or (cdr (assq about *compiler-whining-conditions*)) 'compiler-warning)
1955                          :function-name (list *nx-cur-func-name*)
1956                          :warning-type about
1957                          :args (or forms (list nil)))
1958          *nx-warnings*)
1959  nil)
1960
1961(defun p2-whine (afunc about &rest forms)
1962  (let* ((warning (make-condition (or (cdr (assq about *compiler-whining-conditions*)) 'compiler-warning)
1963                                  :function-name (list (afunc-name afunc))
1964                                  :warning-type about
1965                                  :args (or forms (list nil)))))
1966    (push warning (afunc-warnings afunc))
1967    (do* ((p (afunc-parent afunc) (afunc-parent p)))
1968         ((null p) warning)
1969      (let* ((pname (afunc-name p)))
1970        (push pname (compiler-warning-function-name warning))
1971        (push warning (afunc-warnings p))))))
1972
1973(defun nx1-type-intersect (form type1 type2 &optional env)
1974  (declare (ignore env)) ; use it when deftype records info in env.  Fix this then ...
1975  (let* ((ctype1 (if (typep type1 'ctype) type1 (specifier-type type1)))
1976         (ctype2 (if (typep type2 'ctype) type2 (specifier-type type2)))
1977         (intersection (type-intersection ctype1 ctype2)))
1978    (if (eq intersection *empty-type*)
1979      (let ((type1 (if (typep type1 'ctype)
1980                     (type-specifier type1)
1981                     type1))
1982            (type2 (if (typep type2 'ctype)
1983                     (type-specifier type2)
1984                     type2)))
1985        (nx1-whine :type-conflict form type1 type2)))
1986    (type-specifier intersection)))
1987                 
1988
1989
1990(defun nx-declared-notinline-p (sym env)
1991  (setq sym (maybe-setf-function-name sym))
1992  (loop
1993    (when (listp env)
1994      (return (and (symbolp sym)
1995                   (proclaimed-notinline-p sym))))
1996    (dolist (decl (lexenv.fdecls env))
1997      (when (and (eq (car decl) sym)
1998                 (eq (cadr decl) 'inline))
1999         (return-from nx-declared-notinline-p (eq (cddr decl) 'notinline))))
2000    (setq env (lexenv.parent-env env))))
2001
2002
2003
2004(defun nx1-combination (form env)
2005  (destructuring-bind (sym &rest args)
2006                      form
2007    (if (symbolp sym)
2008      (let* ((*nx-sfname* sym) special)
2009        (if (and (setq special (gethash sym *nx1-alphatizers*))
2010                 (or (not (functionp (fboundp sym)))
2011                     (memq sym '(apply funcall ;; see bug #285
2012                                 %defun        ;; see bug #295
2013                                 ))
2014                     (< (safety-optimize-quantity env) 3))
2015                 ;(not (nx-lexical-finfo sym env))
2016                 (not (nx-declared-notinline-p sym *nx-lexical-environment*)))
2017          (funcall special form env) ; pass environment arg ...
2018          (progn           
2019            (nx1-typed-call sym args))))
2020      (if (lambda-expression-p sym)
2021        (nx1-lambda-bind (%cadr sym) args (%cddr sym))
2022      (nx-error "~S is not a symbol or lambda expression in the form ~S ." sym form)))))
2023
2024(defun nx1-treat-as-call (args)
2025  (nx1-typed-call (car args) (%cdr args)))
2026
2027(defun nx1-typed-call (sym args)
2028  (multiple-value-bind (type errors-p) (nx1-call-result-type sym args)
2029    (let ((form (nx1-call sym args nil nil errors-p)))
2030      (if (eq type t)
2031        form
2032        (list (%nx1-operator typed-form) type form)))))
2033
2034;;; Wimpy.
2035(defun nx1-call-result-type (sym &optional (args nil args-p) spread-p)
2036  (let* ((env *nx-lexical-environment*)
2037         (global-def nil)
2038         (lexenv-def nil)
2039         (defenv-def nil)
2040         (somedef nil)
2041         (whined nil))
2042    (when (and sym 
2043               (symbolp sym)
2044               (not (find-ftype-decl sym env))
2045               (not (setq lexenv-def (nth-value 1 (nx-lexical-finfo sym))))
2046               (null (setq defenv-def (retrieve-environment-function-info sym env)))
2047               (neq sym *nx-global-function-name*)
2048               (not (functionp (setq global-def (fboundp sym)))))
2049      (if args-p
2050        (nx1-whine :undefined-function sym args spread-p)
2051        (nx1-whine :undefined-function sym))
2052      (setq whined t))
2053    (when (and args-p (setq somedef (or lexenv-def defenv-def global-def)))
2054      (multiple-value-bind (deftype reason)
2055          (nx1-check-call-args somedef args spread-p)
2056        (when deftype
2057          (nx1-whine deftype sym reason args spread-p)
2058          (setq whined t))))
2059    (values (nx-target-type *nx-form-type*) whined)))
2060
2061(defun find-ftype-decl (sym env)
2062  (setq sym (maybe-setf-function-name sym))
2063  (loop 
2064    (when (listp env)
2065      (return (and (symbolp sym)
2066                   (proclaimed-ftype sym))))
2067    (dolist (fdecl (lexenv.fdecls env))
2068      (declare (list fdecl))
2069      (when (and (eq (car fdecl) sym)
2070                 (eq (car (the list (cdr fdecl))) 'ftype))
2071        (return-from find-ftype-decl (cdr (the list (cdr fdecl))))))
2072    (setq env (lexenv.parent-env env))))
2073
2074(defun innermost-lfun-bits-keyvect (def)
2075  (declare (notinline innermost-lfun-bits-keyvect))
2076  (let* ((inner-def (closure-function (find-unencapsulated-definition def)))
2077         (bits (lfun-bits inner-def))
2078         (keys (lfun-keyvect inner-def)))
2079    (declare (fixnum bits))
2080    (when (and (eq (ash 1 $lfbits-gfn-bit)
2081                   (logand bits (logior (ash 1 $lfbits-gfn-bit)
2082                                        (ash 1 $lfbits-method-bit))))
2083               (logbitp $lfbits-keys-bit bits))
2084      (setq bits (logior (ash 1 $lfbits-aok-bit) bits)
2085            keys nil))
2086    (values bits keys)))
2087
2088
2089(defun nx1-check-call-args (def arglist spread-p)
2090  (let* ((deftype (if (functionp def) 
2091                    :global-mismatch
2092                    (if (istruct-typep def 'afunc)
2093                      :lexical-mismatch
2094                      :environment-mismatch)))
2095         (reason nil))
2096    (multiple-value-bind (bits keyvect)
2097                         (case deftype
2098                           (:global-mismatch (innermost-lfun-bits-keyvect def))
2099                           (:environment-mismatch
2100                              (values (def-info.lfbits (cdr def)) (def-info.keyvect (cdr def))))
2101                           (t (let* ((lambda-form (afunc-lambdaform def)))
2102                                (if (lambda-expression-p lambda-form)
2103                                  (encode-lambda-list (cadr lambda-form))))))
2104      (when bits
2105        (unless (typep bits 'fixnum) (error "Bug: Bad bits ~s!" bits))
2106        (let* ((nargs (length arglist))
2107               (minargs (if spread-p (1- nargs) nargs))
2108               (maxargs (if spread-p nil nargs))
2109               (required (ldb $lfbits-numreq bits))
2110               (max (if (logtest (logior (ash 1 $lfbits-rest-bit) (ash 1 $lfbits-restv-bit) (ash 1 $lfbits-keys-bit)) bits)
2111                      nil
2112                      (+ required (ldb $lfbits-numopt bits)))))
2113          ;; If the (apparent) number of args in the call doesn't
2114          ;; match the definition, complain.  If "spread-p" is true,
2115          ;; we can only be sure of the case when more than the
2116          ;; required number of args have been supplied.
2117          (if (or (if (and (not spread-p) (< minargs required))
2118                    (setq reason `(:toofew ,minargs ,required)))
2119                  (if (and max (or (> minargs max)) (if maxargs (> maxargs max)))
2120                    (setq reason (list :toomany (if (> minargs max) minargs maxargs) max)))
2121                  (setq reason (nx1-find-bogus-keywords arglist spread-p bits keyvect)))
2122            (values deftype reason)))))))
2123
2124(defun nx1-find-bogus-keywords (args spread-p bits keyvect)
2125  (declare (fixnum bits))
2126  (when (logbitp $lfbits-aok-bit bits)
2127    (setq keyvect nil))                 ; only check for even length tail
2128  (when (and (logbitp $lfbits-keys-bit bits) 
2129             (not spread-p))     ; Can't be sure, last argform may contain :allow-other-keys
2130    (do* ((key-values (nthcdr (+ (ldb $lfbits-numreq bits)  (ldb $lfbits-numopt bits)) args))
2131          (key-args key-values  (cddr key-args)))
2132         ((null key-args))
2133      (if (null (cdr key-args))
2134        (return (list :odd-keywords key-values))
2135        (when keyvect
2136          (let* ((keyword (%car key-args)))
2137            (unless (constantp keyword)
2138              (return nil))
2139            (unless (eq keyword :allow-other-keys)
2140              (unless (position (nx-unquote keyword) keyvect)               
2141                (return (list :unknown-keyword
2142                              (nx-unquote keyword)
2143                              (coerce keyvect 'list)))))))))))
2144
2145;;; we can save some space by going through subprims to call "builtin"
2146;;; functions for us.
2147(defun nx1-builtin-function-offset (name)
2148   (arch::builtin-function-name-offset name))
2149
2150(defun nx1-call-form (global-name afunc arglist spread-p  &optional (env *nx-lexical-environment*))
2151  (if afunc
2152    (make-acode (%nx1-operator lexical-function-call) afunc (nx1-arglist arglist (if spread-p 1 (backend-num-arg-regs *target-backend*))) spread-p)
2153    (let* ((builtin (unless (or spread-p
2154                                (eql 3 (safety-optimize-quantity env)))
2155                      (nx1-builtin-function-offset global-name))))
2156      (if (and builtin
2157               (let* ((bits (lfun-bits (fboundp global-name))))
2158                 (and bits (eql (logand $lfbits-args-mask bits)
2159                                (dpb (length arglist)
2160                                     $lfbits-numreq
2161                                     0)))))
2162        (make-acode (%nx1-operator builtin-call) 
2163                    (make-acode (%nx1-operator fixnum) builtin)
2164                    (nx1-arglist arglist))
2165        (make-acode (%nx1-operator call)
2166                     (if (symbolp global-name)
2167                       (nx1-immediate (nx1-note-fcell-ref global-name))
2168                       global-name)
2169                     (nx1-arglist arglist (if spread-p 1 (backend-num-arg-regs *target-backend*)))
2170                     spread-p)))))
2171 
2172;;; If "sym" is an expression (not a symbol which names a function),
2173;;; the caller has already alphatized it.
2174(defun nx1-call (sym args &optional spread-p global-only inhibit-inline)
2175  (nx1-verify-length args 0 nil)
2176  (let ((args-in-regs (if spread-p 1 (backend-num-arg-regs *target-backend*))))
2177    (if (nx-self-call-p sym global-only)
2178      ;; Should check for downward functions here as well.
2179      (multiple-value-bind (deftype reason)
2180                           (nx1-check-call-args *nx-current-function* args spread-p)
2181        (when deftype
2182          (nx1-whine deftype sym reason args spread-p))
2183        (make-acode (%nx1-operator self-call) (nx1-arglist args args-in-regs) spread-p))
2184      (multiple-value-bind (lambda-form containing-env token) (nx-inline-expansion sym *nx-lexical-environment* global-only)
2185        (or (and (not inhibit-inline)
2186                 (nx1-expand-inline-call lambda-form containing-env token args spread-p *nx-lexical-environment*))
2187            (multiple-value-bind (info afunc) (if (and  (symbolp sym) (not global-only)) (nx-lexical-finfo sym))
2188              (when (eq 'macro (car info))
2189                (nx-error "Can't call macro function ~s" sym))
2190              (nx-record-xref-info :direct-calls sym)
2191              (if (and afunc (%ilogbitp $fbitruntimedef (afunc-bits afunc)))
2192                (let ((sym (var-name (afunc-lfun afunc))))
2193                  (nx1-form 
2194                   (if spread-p
2195                     `(,(if (eql spread-p 0) 'applyv 'apply) ,sym ,args)
2196                     `(funcall ,sym ,@args))))
2197                (let* ((val (nx1-call-form sym afunc args spread-p)))
2198                    (when afunc
2199                      (let ((callers (afunc-callers afunc))
2200                            (self *nx-current-function*))
2201                        (unless (or (eq self afunc) (memq self callers))
2202                          (setf (afunc-callers afunc) (cons self callers)))))
2203                    (if (and (null afunc) (memq sym *nx-never-tail-call*))
2204                      (make-acode (%nx1-operator values) (list val))
2205                      val)))))))))
2206
2207(defun nx1-expand-inline-call (lambda-form env token args spread-p old-env)
2208  (if (and (or (null spread-p) (eq (length args) 1)))
2209    (if (and token (not (memq token *nx-inline-expansions*)))
2210      (with-program-error-handler (lambda (c) (declare (ignore c)) nil)
2211        (let* ((*nx-inline-expansions* (cons token *nx-inline-expansions*))
2212               (lambda-list (cadr lambda-form))
2213               (body (cddr lambda-form))
2214               (new-env (new-lexical-environment env)))
2215          (setf (lexenv.mdecls new-env)
2216                `((speed . ,(speed-optimize-quantity old-env))
2217                  (space . ,(space-optimize-quantity old-env))
2218                  (safety . ,(space-optimize-quantity old-env))
2219                  (compilation-speed . ,(compilation-speed-optimize-quantity old-env))
2220                  (debug . ,(debug-optimize-quantity old-env))))
2221          (if spread-p
2222            (nx1-destructure lambda-list (car args) nil nil body new-env)
2223            (nx1-lambda-bind lambda-list args body new-env)))))))
2224             
2225; note that regforms are reversed: arg_z is always in the car
2226(defun nx1-arglist (args &optional (nregargs (backend-num-arg-regs *target-backend*)))
2227  (declare (fixnum nregargs))
2228  (let* ((stkforms nil)
2229         (regforms nil)
2230         (nstkargs (%i- (length args) nregargs)))
2231    (declare (fixnum nstkargs))
2232      (list
2233       (dotimes (i nstkargs (nreverse stkforms))
2234         (declare (fixnum i))
2235         (push (nx1-form (%car args)) stkforms)
2236         (setq args (%cdr args)))
2237       (dolist (arg args regforms)
2238         (push (nx1-form arg) regforms)))))
2239
2240(defun nx1-formlist (args)
2241  (let* ((a nil))
2242    (dolist (arg args)
2243      (push (nx1-form arg) a))
2244    (nreverse a)))
2245
2246(defun nx1-verify-length (forms min max &aux (len (list-length forms)))
2247 (if (or (null len)
2248         (%i> min len)
2249         (and max (%i> len max)))
2250     (nx-error "Wrong number of args in form ~S." (cons *nx-sfname* forms))
2251     len))
2252
2253(defun nx-unquote (form)
2254  (if (nx-quoted-form-p form)
2255    (%cadr form)
2256    form))
2257
2258(defun nx-quoted-form-p (form &aux (f form))
2259 (and (consp form)
2260      (eq (pop form) 'quote)
2261      (or
2262       (and (consp form)
2263            (not (%cdr form)))
2264       (nx-error "Illegally quoted form ~S." f))))
2265
2266; Returns two values: expansion & win
2267; win is true if expansion is not EQ to form.
2268; This is a bootstrapping version.
2269; The real one is in "ccl:compiler;optimizers.lisp".
2270(unless (fboundp 'maybe-optimize-slot-accessor-form)
2271
2272(defun maybe-optimize-slot-accessor-form (form environment)
2273  (declare (ignore environment))
2274  (values form nil))
2275
2276)
2277
2278(defun record-form-to-nx1-transformation (form nx1)
2279  (when (and *nx1-source-note-map* (form-source-note form))
2280    (setf (gethash nx1 *nx1-source-note-map*) (form-source-note form))))
2281
2282(defun record-nx1-source-equivalent (original new)
2283  (when (and *nx1-source-note-map*
2284             (nx1-source-note original)
2285             (not (nx1-source-note new)))
2286    (setf (gethash new *nx1-source-note-map*)
2287          (gethash original *nx1-source-note-map*))))
2288
2289(defun record-form-source-equivalent (original new)
2290  (when (and *form-source-note-map*
2291             (form-source-note original)
2292             (not (form-source-note new)))
2293    (setf (gethash new *form-source-note-map*)
2294          (gethash original *form-source-note-map*))))
2295
2296(defun nx-note-source-transformation (original new)
2297  (when (and *nx-source-note-map*
2298             (gethash original *nx-source-note-map*)
2299             (not (gethash new *nx-source-note-map*)))
2300    (setf (gethash new *nx-source-note-map*)
2301          (gethash original *nx-source-note-map*)))
2302  (record-form-source-equivalent original new))
2303
2304(defun nx-transform (form &optional (environment *nx-lexical-environment*) (source-note-map *nx-source-note-map*))
2305  (let* (sym transforms lexdefs changed enabled macro-function compiler-macro (source t))
2306    (when source-note-map
2307      (setq source (gethash form source-note-map)))
2308    (tagbody
2309       (go START)
2310     LOOP
2311       (unless source (setq source (gethash form source-note-map)))
2312       (setq changed t)
2313       (when (and (consp form) 
2314                  (or (eq (%car form) 'the)
2315                      (and sym (eq (%car form) sym))))
2316         (go DONE))
2317     START
2318       (when (non-nil-symbol-p form)
2319         (multiple-value-bind (newform win) (nx-transform-symbol form environment)
2320           (unless win (go DONE))
2321           (setq form newform)
2322           (go LOOP)))
2323       (when (atom form) (go DONE))
2324       (unless (symbolp (setq sym (%car form)))
2325         (go DONE))
2326       (when (eq sym 'the)
2327         (destructuring-bind (typespec thing) (cdr form)
2328           (if (constantp thing)
2329             (progn
2330               (setq form thing)
2331               (go LOOP))
2332             (multiple-value-bind (newform win) (nx-transform thing environment)
2333               (when win
2334                 (unless source (setq source (gethash newform source-note-map)))
2335                 (setq changed t)
2336                 (if (and (self-evaluating-p newform)
2337                          (typep newform typespec))
2338                   (setq form newform)
2339                   (setq form `(the ,typespec ,newform)))
2340                 (go DONE))))))
2341       (when (nx-quoted-form-p form)
2342         (when (self-evaluating-p (%cadr form))
2343           (setq form (%cadr form)))
2344         (go DONE))
2345       (when (setq lexdefs (nx-lexical-finfo sym environment))
2346         (if (eq 'function (%car lexdefs))
2347           (go DONE)))
2348       (setq transforms (setq compiler-macro (compiler-macro-function sym environment))
2349             macro-function (macro-function sym environment)
2350             enabled (nx-allow-transforms environment))
2351       (unless macro-function
2352         (let* ((win nil))
2353           (when (and enabled (functionp (fboundp sym)))
2354             (multiple-value-setq (form win) (nx-transform-arglist form environment source-note-map))
2355             (when win
2356               (unless source (setq source (gethash form source-note-map)))
2357               (setq changed t)))))
2358       (when (and enabled
2359                  (not (nx-declared-notinline-p sym environment)))
2360         (multiple-value-bind (value folded) (nx-constant-fold form environment)
2361           (when folded
2362             (setq form value changed t)
2363             (unless source (setq source (gethash form source-note-map)))
2364             (unless (and (consp form) (eq (car form) sym)) (go START))))
2365         (when compiler-macro
2366           (multiple-value-bind (newform win) (compiler-macroexpand-1 form environment)
2367             (when win
2368               (when (and (consp newform) (eq (car newform) sym) (functionp (fboundp sym)))
2369                 (setq sym nil))
2370               (setq form newform)
2371               (go LOOP))))
2372         (multiple-value-bind (newform win) (maybe-optimize-slot-accessor-form form environment)
2373           (when win
2374             (setq sym nil)
2375             (setq form newform)
2376             (go START)))
2377         (unless macro-function
2378           (when (setq transforms (or (environment-structref-info sym environment)
2379                                      (and #-bccl (boundp '%structure-refs%)
2380                                           (gethash sym %structure-refs%))))
2381             (setq form (defstruct-ref-transform transforms (%cdr form)) changed T)
2382             (unless source (setq source (gethash form source-note-map)))
2383             (go START))
2384           (when (setq transforms (assq sym *nx-synonyms*))
2385             (setq form (cons (%cdr transforms) (setq sym (%cdr form))))
2386             (go LOOP))))
2387       (when (and macro-function
2388                  (or lexdefs
2389                      (not (and (gethash sym *nx1-alphatizers*) (not (nx-declared-notinline-p sym environment))))))
2390         (nx-record-xref-info :macro-calls (function-name macro-function))
2391         (setq form (macroexpand-1 form environment) changed t)
2392         (unless source (setq source (gethash form source-note-map)))
2393         (go START))
2394     DONE)
2395    (when (and source (neq source t) (not (gethash form source-note-map)))
2396      (unless (and (consp form)
2397                   (eq (%car form) 'the)
2398                   (eq source (gethash (caddr form) source-note-map)))
2399        (unless (eq form (%unbound-marker))
2400          (setf (gethash form source-note-map) source))))
2401    (values form changed)))
2402
2403; Transform all of the arguments to the function call form.
2404; If any of them won, return a new call form (with the same operator as the original), else return the original
2405; call form unchanged.
2406
2407(defun nx-transform-arglist (callform env &optional source-note-map)
2408    (let* ((any-wins nil)
2409           (transformed-call (cons (car callform) nil))
2410           (ptr transformed-call)
2411           (win nil))
2412      (declare (type cons ptr))
2413      (dolist (form (cdr callform) (if any-wins (values (copy-list transformed-call) t) (values callform nil)))
2414        (multiple-value-setq (form win) (nx-transform form env source-note-map))
2415        (rplacd ptr (setq ptr (cons form nil)))
2416        (if win (setq any-wins t)))))
2417
2418;This is needed by (at least) SETF.
2419(defun nxenv-local-function-p (name macro-env)
2420  (multiple-value-bind (type local-p) (function-information name macro-env)
2421    (and local-p (eq :function type))))
2422
2423           
2424;;; This guy has to return multiple values.  The arguments have
2425;;; already been transformed; if they're all constant (or quoted), try
2426;;; to evaluate the expression at compile-time.
2427(defun nx-constant-fold (original-call &optional (environment *nx-lexical-environment*) &aux 
2428                                       (fn (car original-call)) form mv foldable foldfn)
2429  (flet ((quotify (x) (if (self-evaluating-p x) x (list 'quote x))))
2430    (if (and (nx-allow-transforms environment)
2431             (let* ((bits (if (symbolp fn) (%symbol-bits fn) 0)))
2432               (declare (fixnum bits))
2433               (if (setq foldable (logbitp $sym_fbit_constant_fold bits))
2434                 (if (logbitp $sym_fbit_fold_subforms bits)
2435                   (setq foldfn 'fold-constant-subforms))
2436                 (setq foldable (assq fn *nx-can-constant-fold*)
2437                       foldfn (cdr foldable)))
2438               foldable))
2439      (if foldfn
2440        (funcall foldfn original-call environment)
2441        (progn
2442          (let ((args nil))
2443            (dolist (arg (cdr original-call) (setq args (nreverse args)))
2444              (if (quoted-form-p arg)
2445                (setq arg (%cadr arg))
2446                (unless (self-evaluating-p arg) (return-from nx-constant-fold (values original-call nil))))
2447              (push arg args))
2448            (if (nx1-check-call-args (fboundp fn) args nil)
2449              (return-from nx-constant-fold (values original-call nil))
2450              (setq form (multiple-value-list 
2451                             (handler-case (apply fn args)
2452                               (error (condition)
2453                                      (warn "Error: \"~A\" ~&signalled during compile-time evaluation of ~S ."
2454                                            condition original-call)
2455                                      (return-from nx-constant-fold
2456                                        (values `(locally (declare (notinline ,fn))
2457                                                  ,original-call)
2458                                                t))))))))
2459          (if form
2460            (if (null (%cdr form))
2461              (setq form (%car form))
2462              (setq mv (setq form (cons 'values (mapcar #'quotify form))))))
2463          (values (if mv form (quotify form)) T)))
2464      (values original-call nil))))
2465
2466(defun nx-transform-symbol (sym &optional (env *nx-lexical-environment*))
2467; Gak.  Can't call NX-LEX-INFO without establishing *nx-lexical-environment*.
2468; NX-LEX-INFO should take env arg!.
2469  (let* ((*nx-lexical-environment* env))
2470    (multiple-value-bind (expansion win) (macroexpand-1 sym env)
2471      (if win
2472        (let ((type (nx-declared-type sym))
2473              (var (nth-value 2 (nx-lex-info sym))))
2474          (unless (eq t type) (setq expansion `(the ,type ,expansion)))
2475          (if var (nx-set-var-bits var (%ilogior (%ilsl $vbitreffed 1) (nx-var-bits var)))))
2476        (progn
2477          (multiple-value-setq (expansion win)
2478            (nx-transform-defined-constant sym env))
2479          (if win (setq win (neq sym expansion)))))
2480      (values expansion win))))
2481
2482; if sym has a substitutable constant value in env (or globally), return
2483; (values <value> t), else (values nil nil)
2484(defun nx-transform-defined-constant (sym env)
2485  (let* ((defenv (definition-environment env))
2486         (val (if defenv (assq sym (defenv.constants defenv))))
2487         (constant-value-p val))
2488    (if val
2489      (setq val (%cdr val))
2490      (if (constant-symbol-p sym)
2491        (setq constant-value-p t val (%sym-global-value sym))))
2492    (if (and (neq val (%unbound-marker-8))
2493             constant-value-p 
2494             (nx-substititute-constant-value sym val env))
2495      (values (if (self-evaluating-p val) val (list 'quote val)) t)
2496      (values nil nil))))
2497
2498
2499(defun nx-var-bits (var)
2500  (do* ((var var bits)
2501        (bits (var-bits var) (var-bits var)))
2502       ((fixnump bits) bits)))
2503
2504(defun nx-set-var-bits (var newbits)
2505  (do* ((var var bits)
2506        (bits (var-bits var) (var-bits var)))
2507       ((fixnump bits) (setf (var-bits var) newbits))))
2508
2509(defun nx-adjust-ref-count (var)
2510  (let* ((bits (nx-var-bits var))
2511         (temp-p (%ilogbitp $vbittemporary bits))
2512         (by (if temp-p 1 (expt  4 *nx-loop-nesting-level*)))
2513         (new (%imin (%i+ (%ilogand2 $vrefmask bits) by) 255)))
2514    (nx-set-var-bits var (%ilogior (%ilogand (%ilognot $vrefmask) bits) new))
2515    new))
2516
2517;;; Treat (VALUES x . y) as X if it appears in a THE form
2518(defun nx-form-type (form &optional (env *nx-lexical-environment*))
2519  (if (quoted-form-p form)
2520    (type-of (nx-unquote form))
2521    (if (self-evaluating-p form)
2522      (type-of form)
2523      (if (and (consp form)             ; Kinda bogus now, but require-type
2524               (eq (%car form) 'require-type) ; should be special some day
2525               (quoted-form-p (caddr form)))
2526        (%cadr (%caddr form))
2527        (if (nx-trust-declarations env)
2528          (if (symbolp form)
2529            (nx-target-type (nx-declared-type form env))
2530            (if (consp form)
2531              (if (eq (%car form) 'the)
2532                (destructuring-bind (typespec val) (%cdr form)
2533                  (declare (ignore val))
2534                  (let* ((ctype (values-specifier-type typespec)))
2535                    (if (typep ctype 'values-ctype)
2536                      (let* ((req (values-ctype-required ctype)))
2537                        (if req
2538                          (nx-target-type (type-specifier (car req)))
2539                          '*))
2540                      (nx-target-type (type-specifier ctype)))))
2541                (if (eq (%car form) 'setq)
2542                  (nx-declared-type (cadr form) env)
2543                  (let* ((op (gethash (%car form) *nx1-operators*)))
2544                    (or (and op (cdr (assq op *nx-operator-result-types*)))
2545                        (and (not op)(cdr (assq (car form) *nx-operator-result-types-by-name*)))
2546                        (and (memq (car form) *numeric-ops*)
2547                             (grovel-numeric-form form env))
2548                        (and (memq (car form) *logical-ops*)
2549                             (grovel-logical-form form env))
2550                        ;; Sort of the right idea, but this should be done
2551                        ;; in a more general way.
2552                        (when (or (eq (car form) 'aref)
2553                                  (eq (car form) 'uvref))
2554                          (let* ((atype (nx-form-type (cadr form) env))
2555                                 (a-ctype (specifier-type atype)))
2556                            (when (array-ctype-p a-ctype)
2557                              (type-specifier (array-ctype-specialized-element-type
2558                                               a-ctype)))))
2559                        t))))
2560              t))
2561          t)))))
2562
2563(defparameter *numeric-ops* '(+ -  / * +-2 --2 *-2 /-2))
2564
2565(defparameter *logical-ops* '(logxor-2 logior-2 logand-2  lognot logxor))
2566
2567(defun numeric-type-p (type &optional not-complex)
2568  (or (memq type '(fixnum integer double-float single-float float))
2569      (let ((ctype (specifier-type type)))
2570        (and (numeric-ctype-p ctype)
2571             (or (not not-complex)
2572                 (neq (numeric-ctype-complexp ctype) :complex))))))
2573
2574(defun grovel-numeric-form (form env)
2575  (let* ((op (car form))
2576         (args (cdr form)))
2577    (if (every #'(lambda (x) (nx-form-typep x 'float env)) args)
2578      (if (some #'(lambda (x) (nx-form-typep x 'double-float env)) args)
2579        'double-float
2580        'single-float)
2581      (if (every #'(lambda (x) (nx-form-typep x 'integer env)) args)
2582        (if (or (eq op '/) (eq op '/-2))
2583          t
2584          'integer)))))
2585
2586;; now e.g. logxor of 3 known fixnums is inline as is (logior a (logxor b c))
2587;; and (the fixnum (+ a (logxor b c)))
2588
2589(defun grovel-logical-form (form env)
2590  (when (nx-trust-declarations env)
2591    (let (;(op (car form))
2592          type)
2593      (dolist (arg (cdr form))
2594        (let ((it (nx-form-type arg env)))         
2595          (if (not (subtypep it 'fixnum))
2596            (return (setq type nil))
2597            (setq type 'fixnum))))
2598      type)))
2599
2600(defun nx-form-typep (arg type &optional (env *nx-lexical-environment*))
2601  (setq type (nx-target-type (type-expand type)))
2602  (if (constantp arg)
2603    (typep (nx-unquote arg) type env)
2604    (subtypep (nx-form-type arg env) type env)))
2605
2606
2607(defun nx-binary-fixnum-op-p (form1 form2 env &optional ignore-result-type)
2608  (setq form1 (nx-transform form1 env)
2609        form2 (nx-transform form2 env))
2610  (and
2611   (target-word-size-case
2612    (32 (nx-form-typep form1 '(signed-byte 30) env))
2613    (64 (nx-form-typep form1 '(signed-byte 61) env)))
2614   (target-word-size-case
2615    (32 (nx-form-typep form2 '(signed-byte 30) env))
2616    (64 (nx-form-typep form2 '(signed-byte 61) env)))
2617   (or ignore-result-type
2618        (and (nx-trust-declarations env)
2619                (target-word-size-case
2620                 (32 (subtypep *nx-form-type* '(signed-byte 30)))
2621                 (64 (subtypep *nx-form-type* '(signed-byte 61))))))))
2622
2623
2624(defun nx-binary-natural-op-p (form1 form2 env &optional (ignore-result-type t))
2625  (and
2626   (target-word-size-case
2627    (32
2628     (and (nx-form-typep form1 '(unsigned-byte 32)  env)
2629          (nx-form-typep form2 '(unsigned-byte 32)  env)))
2630    (64
2631     (and (nx-form-typep form1 '(unsigned-byte 64)  env)
2632          (nx-form-typep form2 '(unsigned-byte 64)  env))))
2633   (or ignore-result-type
2634       (and (nx-trust-declarations env)
2635            (target-word-size-case
2636             (32 (subtypep *nx-form-type* '(unsigned-byte 32)))
2637             (64 (subtypep *nx-form-type* '(unsigned-byte 64))))))))
2638
2639   
2640
2641
2642(defun nx-binary-boole-op (whole env arg-1 arg-2 fixop intop naturalop)
2643  (let* ((use-fixop (nx-binary-fixnum-op-p arg-1 arg-2 env t))
2644         (use-naturalop (nx-binary-natural-op-p arg-1 arg-2 env)))
2645    (if (or use-fixop use-naturalop intop)
2646      (make-acode (if use-fixop fixop (if use-naturalop naturalop intop))
2647                  (nx1-form arg-1)
2648                  (nx1-form arg-2))
2649      (nx1-treat-as-call whole))))
2650
2651(defun nx-global-p (sym &optional (env *nx-lexical-environment*))
2652  (or 
2653   (logbitp $sym_vbit_global (the fixnum (%symbol-bits sym)))
2654   (let* ((defenv (definition-environment env)))
2655     (if defenv 
2656       (eq :global (%cdr (assq sym (defenv.specials defenv))))))))
2657 
2658(defun nx-need-var (sym &optional (check-bindable t))
2659  (if (and (nx-need-sym sym)
2660           (not (constantp sym))
2661           (let* ((defenv (definition-environment *nx-lexical-environment*)))
2662             (or (null defenv)
2663                 (not (assq sym (defenv.constants defenv)))))) ; check compile-time-constants, too
2664    (if (and check-bindable (nx-global-p sym))
2665      (nx-error "~S is declared static and can not be bound" sym)
2666      sym)
2667    (nx-error "Can't bind or assign to constant ~S." sym)))
2668
2669(defun nx-need-sym (sym)
2670  (if (symbolp sym)
2671    sym
2672    (nx-error "~S is not a symbol." sym)))
2673
2674(defun nx-need-function-name (name)
2675  (multiple-value-bind (valid nm) (valid-function-name-p name)
2676    (if valid nm (nx-error "Invalid function name ~S" name))))
2677
2678(defun nx-pair-name (form)
2679  (nx-need-sym (if (consp form) (%car form) form)))
2680
2681(defun nx-pair-initform (form)
2682  (if (atom form)
2683    nil
2684    (if (and (listp (%cdr form)) (null (%cddr form)))
2685      (%cadr form)
2686      (nx-error "Bad initialization form: ~S." form))))
2687
2688; some callers might assume that this guy errors out if it can't conjure up
2689; a fixnum.  I certainly did ...
2690(defun nx-get-fixnum (form &aux (trans (nx-transform form *nx-lexical-environment*)))
2691 (if (fixnump trans)
2692  trans
2693  form))
2694 
2695(defun nx1-func-name (gizmo)
2696  (and (consp gizmo)
2697       (or (eq (%car gizmo) 'function) (eq (%car gizmo) 'quote))
2698       (consp (%cdr gizmo))
2699       (null (%cddr gizmo))
2700       (nth-value 1 (valid-function-name-p (%cadr gizmo)))))
2701
2702; distinguish between program errors & incidental ones.
2703(defun nx-error (format-string &rest args)
2704  (error (make-condition 'compile-time-program-error 
2705                :context (nx-error-context)
2706                :format-control format-string
2707                :format-arguments args)))
2708
2709(defun nx-compile-time-error (format-string &rest args)
2710  (error (make-condition 'compile-time-program-error 
2711                :context (nx-error-context)
2712                :format-control format-string
2713                :format-arguments args)))
2714
2715; Should return information about file being compiled, nested functions, etc. ...
2716(defun nx-error-context ()
2717  (or *nx-cur-func-name* "an anonymous function"))
2718
2719(defparameter *warn-if-function-result-ignored*
2720  '(sort stable-sort delete delete-if delete-if-not remf nreverse
2721    nunion nset-intersection)
2722  "Names of functions whos result(s) should ordinarily be used, because of their side-effects or lack of them.")
Note: See TracBrowser for help on using the repository browser.