source: branches/working-0711/ccl/compiler/nx0.lisp @ 9620

Last change on this file since 9620 was 9620, checked in by gz, 12 years ago

Warn about declarations referring to unknown variables; then fix a whole bunch of them in ccl, a surprisingly large number of which actually mattered

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