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

Last change on this file since 8514 was 8514, checked in by gb, 13 years ago

Propagate changeset:8513 to this branch.

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