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

Last change on this file since 9059 was 9059, checked in by gb, 12 years ago

Try harder to do function calls as function calls when (OPTIMIZE (SAFETY 3))
is in effect.

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