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

Last change on this file since 12069 was 12069, checked in by gz, 10 years ago

merge r12050

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