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

Last change on this file since 12154 was 12154, checked in by gz, 11 years ago

allow compound type specifiers as declarations identifiers. consistently do not allow unknown types as declaration identifers (i.e. report them as a bad declaration rather than unknown type)

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