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