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

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

Add CCL:TEST-CCL - runs the gcl test suite (checking it out into ccl:tests;
if necessary). This will print out a bunch of warnings early on (for now),
then sit there for a while (about 3 mins on a MacBook? Pro) and finally
report "No tests failed".

Propagate assorted small fixes from trunk:

r8996 - fix case of spurious defvar warning
r9027 - check arg count before deciding to use builtin-call
r9046 - small fix for ~@:C
r9047 - report a TYPE-ERROR when make-broadcast-stream is given a non-output-stream
r9048 - Make make-file-stream rejected wildcarded pathnames. Various tweaks to make

meta-. work when using pathnames relative to the file system's "current directory".

r9049 - make defclass check for illegal class options
r9052 - Don't constant-fold if arg count is obviously wrong.
r9059 - Try harder to do function calls as function calls when (OPTIMIZE (SAFETY 3))

is in effect.

r9060, r9061 - CTYPE-SUBTYPE: try harder in some cases.
r9068, r9069, r9103, r9104 - PPC2-REF-SYMBOL-VALUE: force boundp checks unless

*ppc2-reckless* (same policy as x86; the per-thread binding lookup is generally
more expensive than boundp trap these days.). Unless skipping boundp check, don't
ignore unused result (so we can error when safety is 3, mostly.)

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