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

Last change on this file since 14980 was 14980, checked in by gb, 8 years ago

Add (%nx1-operator div2) to *numeric-acode-ops*; this allows us to
do some simple type inference/handle some cases of numeric contagion
involving two-arg #'/. (We don't do anything with INTEGER-typed args;
if we ever did, we'd have to be careful with #'/ here.)

In NX1-NOTE-VAR-BINDING, be careful: NX-ACODE-FORM-TYPE can
destrictively modify its argument, making an acode from that's had
type info stripped from it bcome a type-asserted form. Change the
order in which the variables INIT and INITTYPE are initialized so
that we can recognize:

  (let* ((v0 v1))
    ...)

and consider whether or not the two variables need to be disjoint.

While we're at it: ACODE-FORM-TYPE (which does these destructive type
assertions) is supposed to plead ignorance when it encounters a
lexical reference and it's called from the frontend. It really
shouldn't assert that ignorance, which may inhibit subsequent calls
from the backend from determining type info when more information
is available.

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