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