source: branches/gz-working/compiler/nx0.lisp @ 8505

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

checkpoint work in progress, mainly some final cleanup, reorg, don't try to track atoms, keep track of source through transforms; reporting implementation in library;cover.lisp

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