source: branches/pinsn/source/compiler/nx0.lisp @ 16157

Last change on this file since 16157 was 16157, checked in by gb, 7 years ago

fixes

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