source: trunk/source/compiler/nx0.lisp @ 10367

Last change on this file since 10367 was 10367, checked in by gb, 11 years ago

Define $DECL_FULL_SAFETY. Set that bit in p2 decls when (SAFETY 3) is
in effect. Bind *X862-FULL-SAFETY* in x86 backend based on setting
of that bit.

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