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

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

Don't pass "the eventcheck bit" into encodsd declaration info.
Do set the "full safety" bit as appropriate, and ensure that conflicting
bits are not set in that case.

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