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

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

run alphatizers for FUNCALL and APPLY regardless of safety setting, so they can do call-next-method magic (bug #285)

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