1 | ;;; jvm.lisp |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 2003-2005 Peter Graves |
---|
4 | ;;; $Id: jvm.lisp,v 1.350 2005-01-14 22:02:20 piso Exp $ |
---|
5 | ;;; |
---|
6 | ;;; This program is free software; you can redistribute it and/or |
---|
7 | ;;; modify it under the terms of the GNU General Public License |
---|
8 | ;;; as published by the Free Software Foundation; either version 2 |
---|
9 | ;;; of the License, or (at your option) any later version. |
---|
10 | ;;; |
---|
11 | ;;; This program is distributed in the hope that it will be useful, |
---|
12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
---|
13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
---|
14 | ;;; GNU General Public License for more details. |
---|
15 | ;;; |
---|
16 | ;;; You should have received a copy of the GNU General Public License |
---|
17 | ;;; along with this program; if not, write to the Free Software |
---|
18 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
---|
19 | |
---|
20 | (in-package "EXT") |
---|
21 | |
---|
22 | (export 'defsubst) |
---|
23 | |
---|
24 | (in-package "JVM") |
---|
25 | |
---|
26 | (export '(compile-defun *catch-errors* jvm-compile jvm-compile-package)) |
---|
27 | |
---|
28 | (import '(sys::%format |
---|
29 | sys::source-transform |
---|
30 | sys::define-source-transform |
---|
31 | sys::expand-source-transform)) |
---|
32 | |
---|
33 | (require :source-transform) |
---|
34 | |
---|
35 | (require '#:opcodes) |
---|
36 | |
---|
37 | (shadow '(method variable)) |
---|
38 | |
---|
39 | (defparameter *trust-user-type-declarations* t) |
---|
40 | |
---|
41 | (defvar *closure-variables* nil) |
---|
42 | |
---|
43 | (defvar *enable-dformat* nil) |
---|
44 | |
---|
45 | (defun dformat (destination control-string &rest args) |
---|
46 | (when *enable-dformat* |
---|
47 | (apply #'sys::%format destination control-string args))) |
---|
48 | |
---|
49 | (defun inline-expansion (name) |
---|
50 | (let ((info (sys::function-info name))) |
---|
51 | (and info (getf info :inline-expansion)))) |
---|
52 | |
---|
53 | (defun (setf inline-expansion) (expansion name) |
---|
54 | (let ((info (sys::function-info name))) |
---|
55 | (setf info (sys::%putf info :inline-expansion expansion)) |
---|
56 | (setf (sys::function-info name) info)) |
---|
57 | expansion) |
---|
58 | |
---|
59 | ;; Just an experiment... |
---|
60 | (defmacro defsubst (name lambda-list &rest body) |
---|
61 | `(progn |
---|
62 | (sys::%defun ',name ',lambda-list ',body) |
---|
63 | (precompile ',name) |
---|
64 | (setf (inline-expansion ',name) |
---|
65 | (precompile-form (list* 'LAMBDA ',lambda-list ',body) t)) |
---|
66 | ',name)) |
---|
67 | #+nil |
---|
68 | (defmacro defsubst (&rest args) |
---|
69 | `(defun ,@args)) |
---|
70 | |
---|
71 | ;; (defvar *use-locals-vector* nil) |
---|
72 | |
---|
73 | (defvar *compiler-debug* nil) |
---|
74 | |
---|
75 | (defstruct compiland |
---|
76 | name |
---|
77 | lambda-expression |
---|
78 | arg-vars |
---|
79 | p1-result |
---|
80 | classfile |
---|
81 | parent |
---|
82 | (children 0) ; Number of local functions defined with FLET or LABELS. |
---|
83 | contains-lambda |
---|
84 | argument-register |
---|
85 | closure-register |
---|
86 | ) |
---|
87 | |
---|
88 | (defvar *current-compiland* nil) |
---|
89 | |
---|
90 | (defvar *pool* nil) |
---|
91 | (defvar *pool-count* 1) |
---|
92 | (defvar *pool-entries* nil) |
---|
93 | |
---|
94 | ;; (defvar *stream* nil) |
---|
95 | (defvar *this-class* nil) |
---|
96 | |
---|
97 | (defvar *code* ()) |
---|
98 | (defvar *static-code* ()) |
---|
99 | (defvar *fields* ()) |
---|
100 | |
---|
101 | ;; All tags visible at the current point of compilation, some of which may not |
---|
102 | ;; be in the current compiland. |
---|
103 | (defvar *visible-tags* ()) |
---|
104 | |
---|
105 | ;; Next available register. |
---|
106 | (defvar *register* 0) |
---|
107 | |
---|
108 | ;; Total number of registers allocated. |
---|
109 | (defvar *registers-allocated* 0) |
---|
110 | |
---|
111 | (defvar *handlers* ()) |
---|
112 | |
---|
113 | (defstruct handler |
---|
114 | from |
---|
115 | to |
---|
116 | code |
---|
117 | catch-type) |
---|
118 | |
---|
119 | ;; Variables visible at the current point of compilation. |
---|
120 | (defvar *visible-variables* ()) |
---|
121 | |
---|
122 | ;; All variables seen so far. |
---|
123 | (defvar *all-variables* ()) |
---|
124 | |
---|
125 | ;; Undefined variables that we've already warned about. |
---|
126 | (defvar *undefined-variables* ()) |
---|
127 | |
---|
128 | (defvar *dump-variables* nil) |
---|
129 | |
---|
130 | (defun dump-1-variable (variable) |
---|
131 | (%format t " ~S special-p = ~S register = ~S level = ~S index = ~S declared-type = ~S~%" |
---|
132 | (variable-name variable) |
---|
133 | (variable-special-p variable) |
---|
134 | (variable-register variable) |
---|
135 | (variable-level variable) |
---|
136 | (variable-index variable) |
---|
137 | (variable-declared-type variable))) |
---|
138 | |
---|
139 | (defun dump-variables (list caption &optional (force nil)) |
---|
140 | (when (or force *dump-variables*) |
---|
141 | (write-string caption) |
---|
142 | (if list |
---|
143 | (dolist (variable list) |
---|
144 | (dump-1-variable variable)) |
---|
145 | (%format t " None.~%")))) |
---|
146 | |
---|
147 | (defstruct variable |
---|
148 | name |
---|
149 | initform |
---|
150 | temp-register |
---|
151 | special-p |
---|
152 | (declared-type t) |
---|
153 | representation ; NIL (i.e. a LispObject reference) or :UNBOXED-FIXNUM |
---|
154 | register ; register number or NIL |
---|
155 | index |
---|
156 | closure-index |
---|
157 | (reads 0) |
---|
158 | (writes 0) |
---|
159 | used-non-locally-p |
---|
160 | (compiland *current-compiland*)) |
---|
161 | |
---|
162 | ;; obj can be a symbol or variable |
---|
163 | ;; returns variable or nil |
---|
164 | (defun unboxed-fixnum-variable (obj) |
---|
165 | (cond |
---|
166 | ((symbolp obj) |
---|
167 | (let ((variable (find-visible-variable obj))) |
---|
168 | (if (and variable |
---|
169 | (eq (variable-representation variable) :unboxed-fixnum)) |
---|
170 | variable |
---|
171 | nil))) |
---|
172 | ((variable-p obj) |
---|
173 | (if (eq (variable-representation obj) :unboxed-fixnum) |
---|
174 | obj |
---|
175 | nil)) |
---|
176 | (t |
---|
177 | nil))) |
---|
178 | |
---|
179 | (defun arg-is-fixnum-p (arg) |
---|
180 | (or (fixnump arg) |
---|
181 | (unboxed-fixnum-variable arg))) |
---|
182 | |
---|
183 | ;; True for local functions defined with FLET or LABELS. |
---|
184 | (defvar *child-p* nil) |
---|
185 | |
---|
186 | (defvar *child-count* 0) |
---|
187 | |
---|
188 | (defun find-visible-variable (name) |
---|
189 | (dolist (variable *visible-variables*) |
---|
190 | (when (eq name (variable-name variable)) |
---|
191 | (return variable)))) |
---|
192 | |
---|
193 | (defun unboxed-fixnum-variable-p (obj) |
---|
194 | ;; (let ((variable (and (symbolp obj) |
---|
195 | ;; (find-visible-variable obj)))) |
---|
196 | ;; (and variable |
---|
197 | ;; (eq (variable-representation variable) :unboxed-fixnum)))) |
---|
198 | (unboxed-fixnum-variable obj)) |
---|
199 | |
---|
200 | (defun allocate-register () |
---|
201 | (let* ((register *register*) |
---|
202 | (next-register (1+ register))) |
---|
203 | (declare (type fixnum register next-register)) |
---|
204 | (setf *register* next-register) |
---|
205 | (when (< *registers-allocated* next-register) |
---|
206 | (setf *registers-allocated* next-register)) |
---|
207 | register)) |
---|
208 | |
---|
209 | (defstruct local-function |
---|
210 | name |
---|
211 | compiland |
---|
212 | function |
---|
213 | classfile |
---|
214 | variable) |
---|
215 | |
---|
216 | (defvar *local-functions* ()) |
---|
217 | |
---|
218 | (defun find-local-function (name) |
---|
219 | (find name *local-functions* :key #'local-function-name)) |
---|
220 | |
---|
221 | (defvar *using-arg-array* nil) |
---|
222 | (defvar *hairy-arglist-p* nil) |
---|
223 | (defvar *arity* nil) |
---|
224 | |
---|
225 | (defvar *val* nil) ; index of value register |
---|
226 | |
---|
227 | (defstruct node |
---|
228 | ;; Block name or (TAGBODY) or (LET) or (MULTIPLE-VALUE-BIND). |
---|
229 | name |
---|
230 | form |
---|
231 | (compiland *current-compiland*)) |
---|
232 | |
---|
233 | ;; Used to wrap TAGBODYs, UNWIND-PROTECTs and LET/LET*/M-V-B forms as well as |
---|
234 | ;; BLOCKs per se. |
---|
235 | (defstruct (block-node (:conc-name block-) (:include node)) |
---|
236 | (exit (gensym)) |
---|
237 | target |
---|
238 | catch-tag |
---|
239 | ;; True if there is any RETURN from this block. |
---|
240 | return-p |
---|
241 | ;; True if there is a non-local RETURN from this block. |
---|
242 | non-local-return-p |
---|
243 | ;; True if a tag in this tagbody is the target of a non-local GO. |
---|
244 | non-local-go-p |
---|
245 | ;; If non-nil, register containing saved dynamic environment for this block. |
---|
246 | environment-register |
---|
247 | ;; Only used in LET/LET*/M-V-B nodes. |
---|
248 | vars |
---|
249 | free-specials |
---|
250 | ) |
---|
251 | |
---|
252 | (defvar *blocks* ()) |
---|
253 | |
---|
254 | (defun find-block (name) |
---|
255 | (dolist (block *blocks*) |
---|
256 | (when (eq name (block-name block)) |
---|
257 | (return block)))) |
---|
258 | |
---|
259 | (defstruct tag |
---|
260 | name |
---|
261 | label |
---|
262 | block |
---|
263 | (compiland *current-compiland*)) |
---|
264 | |
---|
265 | ;;; Pass 1. |
---|
266 | |
---|
267 | (defun p1-let-vars (varlist) |
---|
268 | (let ((vars ())) |
---|
269 | (dolist (varspec varlist) |
---|
270 | (cond ((consp varspec) |
---|
271 | (let ((name (car varspec)) |
---|
272 | (initform (p1 (cadr varspec)))) |
---|
273 | (push (make-variable :name name :initform initform) vars))) |
---|
274 | (t |
---|
275 | (push (make-variable :name varspec) vars)))) |
---|
276 | (setf vars (nreverse vars)) |
---|
277 | (dolist (variable vars) |
---|
278 | (push variable *visible-variables*) |
---|
279 | (push variable *all-variables*)) |
---|
280 | vars)) |
---|
281 | |
---|
282 | (defun p1-let*-vars (varlist) |
---|
283 | (let ((vars ())) |
---|
284 | (dolist (varspec varlist) |
---|
285 | (cond ((consp varspec) |
---|
286 | (let* ((name (car varspec)) |
---|
287 | (initform (p1 (cadr varspec))) |
---|
288 | (var (make-variable :name name :initform initform))) |
---|
289 | (push var vars) |
---|
290 | (push var *visible-variables*) |
---|
291 | (push var *all-variables*))) |
---|
292 | (t |
---|
293 | (let ((var (make-variable :name varspec))) |
---|
294 | (push var vars) |
---|
295 | (push var *visible-variables*) |
---|
296 | (push var *all-variables*))))) |
---|
297 | (nreverse vars))) |
---|
298 | |
---|
299 | (defun p1-let/let* (form) |
---|
300 | (let* ((*visible-variables* *visible-variables*) |
---|
301 | (block (make-block-node :name '(LET))) |
---|
302 | (*blocks* (cons block *blocks*)) |
---|
303 | (op (car form)) |
---|
304 | (varlist (cadr form)) |
---|
305 | (body (cddr form))) |
---|
306 | (aver (or (eq op 'LET) (eq op 'LET*))) |
---|
307 | (when (eq op 'LET) |
---|
308 | ;; Convert to LET* if possible. |
---|
309 | (dolist (varspec varlist (setf op 'LET*)) |
---|
310 | (or (atom varspec) |
---|
311 | (constantp (cadr varspec)) |
---|
312 | (eq (car varspec) (cadr varspec)) |
---|
313 | (return nil)))) |
---|
314 | (let ((vars (if (eq op 'LET) (p1-let-vars varlist) (p1-let*-vars varlist))) |
---|
315 | (free-specials '())) |
---|
316 | (dformat t "p1-let/let* vars = ~S~%" (mapcar #'variable-name vars)) |
---|
317 | ;; Check for globally declared specials. |
---|
318 | (dolist (variable vars) |
---|
319 | (when (special-variable-p (variable-name variable)) |
---|
320 | (setf (variable-special-p variable) t))) |
---|
321 | ;; Process declarations. |
---|
322 | (dolist (subform body) |
---|
323 | (unless (and (consp subform) (eq (car subform) 'DECLARE)) |
---|
324 | (return)) |
---|
325 | (let ((decls (cdr subform))) |
---|
326 | (dolist (decl decls) |
---|
327 | (case (car decl) |
---|
328 | (SPECIAL |
---|
329 | (dolist (sym (cdr decl)) |
---|
330 | ;; (dolist (variable vars) |
---|
331 | ;; (when (eq sym (variable-name variable)) |
---|
332 | ;; (setf (variable-special-p variable) t))) |
---|
333 | (let ((variable (find sym vars :key #'variable-name))) |
---|
334 | (cond (variable |
---|
335 | (setf (variable-special-p variable) t)) |
---|
336 | (t |
---|
337 | (dformat t "adding free special ~S~%" sym) |
---|
338 | (push (make-variable :name sym :special-p t) free-specials)))) |
---|
339 | )) |
---|
340 | (TYPE |
---|
341 | (dolist (sym (cddr decl)) |
---|
342 | (dolist (variable vars) |
---|
343 | (when (eq sym (variable-name variable)) |
---|
344 | (setf (variable-declared-type variable) (cadr decl)))))))))) |
---|
345 | (setf (block-vars block) vars) |
---|
346 | (setf (block-free-specials block) free-specials)) |
---|
347 | (setf body (mapcar #'p1 body)) |
---|
348 | (setf (block-form block) (list* op varlist body)) |
---|
349 | block)) |
---|
350 | |
---|
351 | (defun p1-m-v-b (form) |
---|
352 | ;; (dformat t "p1-multiple-value-bind~%") |
---|
353 | (let* ((*visible-variables* *visible-variables*) |
---|
354 | (block (make-block-node :name '(MULTIPLE-VALUE-BIND))) |
---|
355 | (*blocks* (cons block *blocks*)) |
---|
356 | (varlist (cadr form)) |
---|
357 | (values-form (caddr form)) |
---|
358 | (body (cdddr form))) |
---|
359 | ;; Process the values-form first. ("The scopes of the name binding and |
---|
360 | ;; declarations do not include the values-form.") |
---|
361 | (setf values-form (p1 values-form)) |
---|
362 | (let ((vars ())) |
---|
363 | (dolist (symbol varlist) |
---|
364 | (let ((var (make-variable :name symbol))) |
---|
365 | (push var vars) |
---|
366 | (push var *visible-variables*) |
---|
367 | (push var *all-variables*))) |
---|
368 | ;; Check for globally declared specials. |
---|
369 | (dolist (variable vars) |
---|
370 | (when (special-variable-p (variable-name variable)) |
---|
371 | (setf (variable-special-p variable) t))) |
---|
372 | ;; Process declarations. |
---|
373 | (dolist (subform body) |
---|
374 | (unless (and (consp subform) (eq (car subform) 'DECLARE)) |
---|
375 | (return)) |
---|
376 | (let ((decls (cdr subform))) |
---|
377 | (dolist (decl decls) |
---|
378 | (case (car decl) |
---|
379 | (SPECIAL |
---|
380 | (dolist (sym (cdr decl)) |
---|
381 | (dolist (variable vars) |
---|
382 | (when (eq sym (variable-name variable)) |
---|
383 | (setf (variable-special-p variable) t))))) |
---|
384 | (TYPE |
---|
385 | (dolist (sym (cddr decl)) |
---|
386 | (dolist (variable vars) |
---|
387 | (when (eq sym (variable-name variable)) |
---|
388 | (setf (variable-declared-type variable) (cadr decl)))))))))) |
---|
389 | (setf (block-vars block) (nreverse vars))) |
---|
390 | (setf body (mapcar #'p1 body)) |
---|
391 | (setf (block-form block) (list* 'MULTIPLE-VALUE-BIND varlist values-form body)) |
---|
392 | block)) |
---|
393 | |
---|
394 | (defun p1-block (form) |
---|
395 | (let* ((block (make-block-node :name (cadr form))) |
---|
396 | (*blocks* (cons block *blocks*))) |
---|
397 | (setf (block-form block) (list* 'BLOCK (cadr form) (mapcar #'p1 (cddr form)))) |
---|
398 | block)) |
---|
399 | |
---|
400 | (defun p1-return-from (form) |
---|
401 | (let* ((name (second form)) |
---|
402 | (result-form (third form)) |
---|
403 | (block (find-block name))) |
---|
404 | (cond ((null block) |
---|
405 | (error "P1-RETURN-FROM: no block named ~S is currently visible." name)) |
---|
406 | ((eq (block-compiland block) *current-compiland*) |
---|
407 | (setf (block-return-p block) t)) |
---|
408 | (t |
---|
409 | (setf (block-return-p block) t) |
---|
410 | (setf (block-non-local-return-p block) t)))) |
---|
411 | (list* 'RETURN-FROM (cadr form) (mapcar #'p1 (cddr form)))) |
---|
412 | |
---|
413 | (defun p1-tagbody (form) |
---|
414 | (let* ((block (make-block-node :name '(TAGBODY))) |
---|
415 | (*blocks* (cons block *blocks*)) |
---|
416 | (*visible-tags* *visible-tags*) |
---|
417 | (body (cdr form))) |
---|
418 | ;; Make all the tags visible before processing the body forms. |
---|
419 | (dolist (subform body) |
---|
420 | (when (or (symbolp subform) (integerp subform)) |
---|
421 | (let* ((tag (make-tag :name subform :label (gensym) :block block))) |
---|
422 | (push tag *visible-tags*)))) |
---|
423 | (let ((new-body '())) |
---|
424 | (dolist (subform body) |
---|
425 | (push (if (or (symbolp subform) (integerp subform)) |
---|
426 | subform |
---|
427 | (p1 subform)) |
---|
428 | new-body)) |
---|
429 | (setf (block-form block) (list* 'TAGBODY (nreverse new-body)))) |
---|
430 | block)) |
---|
431 | |
---|
432 | (defun p1-go (form) |
---|
433 | (let* ((name (cadr form)) |
---|
434 | (tag (find-tag name))) |
---|
435 | (unless tag |
---|
436 | (error "p1-go: tag not found: ~S" name)) |
---|
437 | (unless (eq (tag-compiland tag) *current-compiland*) |
---|
438 | (setf (block-non-local-go-p (tag-block tag)) t))) |
---|
439 | form) |
---|
440 | |
---|
441 | (defun p1-flet (form) |
---|
442 | ;; (when *current-compiland* |
---|
443 | (incf (compiland-children *current-compiland*) (length (cadr form))) |
---|
444 | ;; ) |
---|
445 | (let ((*current-compiland* *current-compiland*) |
---|
446 | (compilands ())) |
---|
447 | (dolist (definition (cadr form)) |
---|
448 | (let* ((name (car definition)) |
---|
449 | (lambda-list (cadr definition)) |
---|
450 | (body (cddr definition)) |
---|
451 | (compiland (make-compiland :name name |
---|
452 | :parent *current-compiland*))) |
---|
453 | (multiple-value-bind (body decls) |
---|
454 | (sys::parse-body body) |
---|
455 | (setf (compiland-lambda-expression compiland) |
---|
456 | `(lambda ,lambda-list ,@decls (block ,name ,@body))) |
---|
457 | (let ((*visible-variables* *visible-variables*) |
---|
458 | (*current-compiland* compiland)) |
---|
459 | (p1-compiland compiland))) |
---|
460 | (push compiland compilands))) |
---|
461 | (list* (car form) (nreverse compilands) (mapcar #'p1 (cddr form))))) |
---|
462 | |
---|
463 | (defun p1-labels (form) |
---|
464 | (incf (compiland-children *current-compiland*) (length (cadr form))) |
---|
465 | (let ((*visible-variables* *visible-variables*) |
---|
466 | (*local-functions* *local-functions*) |
---|
467 | (*current-compiland* *current-compiland*) |
---|
468 | (local-functions ())) |
---|
469 | (dolist (definition (cadr form)) |
---|
470 | (let* ((name (car definition)) |
---|
471 | (lambda-list (cadr definition)) |
---|
472 | (body (cddr definition)) |
---|
473 | (compiland (make-compiland :name name |
---|
474 | :parent *current-compiland*)) |
---|
475 | (variable (make-variable :name (copy-symbol name))) |
---|
476 | (local-function (make-local-function :name name |
---|
477 | :compiland compiland |
---|
478 | :variable variable))) |
---|
479 | (multiple-value-bind (body decls) |
---|
480 | (sys::parse-body body) |
---|
481 | (setf (compiland-lambda-expression compiland) |
---|
482 | `(lambda ,lambda-list ,@decls (block ,name ,@body)))) |
---|
483 | (push variable *all-variables*) |
---|
484 | (push local-function local-functions))) |
---|
485 | (setf local-functions (nreverse local-functions)) |
---|
486 | ;; Make the local functions visible. |
---|
487 | (dolist (local-function local-functions) |
---|
488 | (push local-function *local-functions*) |
---|
489 | (push (local-function-variable local-function) *visible-variables*)) |
---|
490 | (dolist (local-function local-functions) |
---|
491 | (let ((*visible-variables* *visible-variables*) |
---|
492 | (*current-compiland* (local-function-compiland local-function))) |
---|
493 | (p1-compiland (local-function-compiland local-function)))) |
---|
494 | (list* (car form) local-functions (mapcar #'p1 (cddr form))))) |
---|
495 | |
---|
496 | (defun p1-function (form) |
---|
497 | (cond |
---|
498 | ((and (consp (cadr form)) (eq (caadr form) 'LAMBDA)) |
---|
499 | (when *current-compiland* |
---|
500 | (incf (compiland-children *current-compiland*))) |
---|
501 | (let* ((*current-compiland* *current-compiland*) |
---|
502 | (lambda-form (cadr form)) |
---|
503 | (lambda-list (cadr lambda-form)) |
---|
504 | (body (cddr lambda-form)) |
---|
505 | (compiland (make-compiland :name (gensym "ANONYMOUS-LAMBDA-") |
---|
506 | :lambda-expression lambda-form |
---|
507 | :parent *current-compiland*))) |
---|
508 | (multiple-value-bind (body decls) |
---|
509 | (sys::parse-body body) |
---|
510 | (setf (compiland-lambda-expression compiland) |
---|
511 | `(lambda ,lambda-list ,@decls (block nil ,@body))) |
---|
512 | (let ((*visible-variables* *visible-variables*) |
---|
513 | (*current-compiland* compiland)) |
---|
514 | (p1-compiland compiland))) |
---|
515 | (list 'FUNCTION compiland))) |
---|
516 | (t |
---|
517 | form))) |
---|
518 | |
---|
519 | (defun p1-lambda (form) |
---|
520 | (let* ((lambda-list (cadr form)) |
---|
521 | (body (cddr form)) |
---|
522 | (auxvars (memq '&AUX lambda-list))) |
---|
523 | (when auxvars |
---|
524 | (setf lambda-list (subseq lambda-list 0 (position '&AUX lambda-list))) |
---|
525 | (setf body (list (append (list 'LET* (cdr auxvars)) body)))) |
---|
526 | (p1-function (list 'FUNCTION (list* 'LAMBDA lambda-list body))))) |
---|
527 | |
---|
528 | (defun p1-eval-when (form) |
---|
529 | (list* (car form) (cadr form) (mapcar #'p1 (cddr form)))) |
---|
530 | |
---|
531 | (defun p1-quote (form) |
---|
532 | (if (numberp (second form)) |
---|
533 | (second form) |
---|
534 | form)) |
---|
535 | |
---|
536 | (defun p1-setq (form) |
---|
537 | (unless (= (length form) 3) |
---|
538 | (error "Too many arguments for SETQ.")) |
---|
539 | (let ((arg1 (second form)) |
---|
540 | (arg2 (third form))) |
---|
541 | (let ((variable (find-visible-variable arg1))) |
---|
542 | (if variable |
---|
543 | (progn |
---|
544 | (incf (variable-writes variable)) |
---|
545 | (cond |
---|
546 | ((eq (variable-compiland variable) *current-compiland*) |
---|
547 | (dformat t "p1-setq: write ~S~%" arg1)) |
---|
548 | (t |
---|
549 | (dformat t "p1-setq: non-local write ~S~%" arg1) |
---|
550 | (setf (variable-used-non-locally-p variable) t)))) |
---|
551 | (dformat t "p1-setq: unknown variable ~S~%" arg1))) |
---|
552 | (list 'SETQ arg1 (p1 arg2)))) |
---|
553 | |
---|
554 | (defun p1-the (form) |
---|
555 | (dformat t "p1-the form = ~S~%" form) |
---|
556 | (let ((type (second form)) |
---|
557 | (expr (third form))) |
---|
558 | (cond |
---|
559 | ((and (listp type) (eq (car type) 'VALUES)) |
---|
560 | ;; FIXME |
---|
561 | (p1 expr)) |
---|
562 | ((= *safety* 3) |
---|
563 | (dformat t "p1-the expr = ~S~%" expr) |
---|
564 | (let* ((sym (gensym)) |
---|
565 | (new-expr |
---|
566 | `(let ((,sym ,expr)) |
---|
567 | (sys::require-type ,sym ',type) |
---|
568 | ,sym))) |
---|
569 | (dformat t "p1-the new-expr = ~S~%" new-expr) |
---|
570 | (p1 new-expr))) |
---|
571 | (t |
---|
572 | (dformat t "p1-the t case expr = ~S~%" expr) |
---|
573 | (if (subtypep type 'FIXNUM) |
---|
574 | (list 'THE type (p1 expr)) |
---|
575 | (p1 expr)))))) |
---|
576 | |
---|
577 | (defun p1-default (form) |
---|
578 | (list* (car form) (mapcar #'p1 (cdr form)))) |
---|
579 | |
---|
580 | (defun p1-throw (form) |
---|
581 | (let ((new-form (rewrite-throw form))) |
---|
582 | (when (neq new-form form) |
---|
583 | (return-from p1-throw (p1 new-form)))) |
---|
584 | (list* 'THROW (mapcar #'p1 (cdr form)))) |
---|
585 | |
---|
586 | (defun expand-inline (form expansion) |
---|
587 | (let ((args (cdr form)) |
---|
588 | (vars (cadr expansion)) |
---|
589 | (varlist ()) |
---|
590 | new-form) |
---|
591 | (do ((vars vars (cdr vars)) |
---|
592 | (args args (cdr args))) |
---|
593 | ((null vars)) |
---|
594 | (push (list (car vars) (car args)) varlist)) |
---|
595 | (setf varlist (nreverse varlist)) |
---|
596 | (setf new-form (list* 'LET varlist (cddr expansion))) |
---|
597 | new-form)) |
---|
598 | |
---|
599 | (defun p1 (form) |
---|
600 | (cond |
---|
601 | ((symbolp form) |
---|
602 | (cond |
---|
603 | ((constantp form) ; a DEFCONSTANT |
---|
604 | (let ((value (symbol-value form))) |
---|
605 | (if (numberp value) |
---|
606 | value |
---|
607 | form))) |
---|
608 | ((keywordp form) |
---|
609 | form) |
---|
610 | (t |
---|
611 | (let ((variable (find-visible-variable form))) |
---|
612 | (if variable |
---|
613 | (progn |
---|
614 | (incf (variable-reads variable)) |
---|
615 | (cond |
---|
616 | ((eq (variable-compiland variable) *current-compiland*) |
---|
617 | (dformat t "p1: read ~S~%" form)) |
---|
618 | (t |
---|
619 | (dformat t "p1: non-local read ~S variable-compiland = ~S current compiland = ~S~%" |
---|
620 | form |
---|
621 | (compiland-name (variable-compiland variable)) |
---|
622 | (compiland-name *current-compiland*)) |
---|
623 | (setf (variable-used-non-locally-p variable) t)))) |
---|
624 | (dformat t "p1: unknown variable ~S~%" form))) |
---|
625 | form))) |
---|
626 | ((atom form) |
---|
627 | form) |
---|
628 | (t |
---|
629 | (let ((op (car form)) |
---|
630 | handler) |
---|
631 | (cond ((symbolp op) |
---|
632 | (cond ((setf handler (get op 'p1-handler)) |
---|
633 | (funcall handler form)) |
---|
634 | ((macro-function op) |
---|
635 | (p1 (macroexpand form))) |
---|
636 | ((special-operator-p op) |
---|
637 | (error "P1: unsupported special operator ~S" op)) |
---|
638 | (t |
---|
639 | ;; Function call. |
---|
640 | (let ((new-form (rewrite-function-call form))) |
---|
641 | (when (neq new-form form) |
---|
642 | (dformat t "old form = ~S~%" form) |
---|
643 | (dformat t "new form = ~S~%" new-form) |
---|
644 | (return-from p1 (p1 new-form)))) |
---|
645 | (let ((source-transform (source-transform op))) |
---|
646 | (when source-transform |
---|
647 | (let ((new-form (expand-source-transform form))) |
---|
648 | (when (neq new-form form) |
---|
649 | (return-from p1 (p1 new-form)))))) |
---|
650 | (let ((expansion (inline-expansion op))) |
---|
651 | (when expansion |
---|
652 | (return-from p1 (p1 (expand-inline form expansion))))) |
---|
653 | (let ((local-function (find-local-function op))) |
---|
654 | (when local-function |
---|
655 | (dformat t "p1 local function ~S~%" op) |
---|
656 | (unless (eq (local-function-compiland local-function) |
---|
657 | *current-compiland*) |
---|
658 | (let ((variable (local-function-variable local-function))) |
---|
659 | (when variable |
---|
660 | (unless (eq (variable-compiland variable) *current-compiland*) |
---|
661 | (dformat t "p1 ~S used non-locally~%" (variable-name variable)) |
---|
662 | (setf (variable-used-non-locally-p variable) t))))))) |
---|
663 | (list* op (mapcar #'p1 (cdr form))) |
---|
664 | ))) |
---|
665 | ((and (consp op) (eq (car op) 'LAMBDA)) |
---|
666 | (p1 (list* 'FUNCALL form))) |
---|
667 | (t |
---|
668 | form)))))) |
---|
669 | |
---|
670 | (defun install-p1-handler (symbol handler) |
---|
671 | (setf (get symbol 'p1-handler) handler)) |
---|
672 | |
---|
673 | (install-p1-handler 'block 'p1-block) |
---|
674 | (install-p1-handler 'catch 'p1-default) |
---|
675 | (install-p1-handler 'declare 'identity) |
---|
676 | (install-p1-handler 'eval-when 'p1-eval-when) |
---|
677 | (install-p1-handler 'flet 'p1-flet) |
---|
678 | (install-p1-handler 'function 'p1-function) |
---|
679 | (install-p1-handler 'go 'p1-go) |
---|
680 | (install-p1-handler 'if 'p1-default) |
---|
681 | (install-p1-handler 'labels 'p1-labels) |
---|
682 | (install-p1-handler 'lambda 'p1-lambda) |
---|
683 | (install-p1-handler 'let 'p1-let/let*) |
---|
684 | (install-p1-handler 'let* 'p1-let/let*) |
---|
685 | (install-p1-handler 'load-time-value 'identity) |
---|
686 | (install-p1-handler 'locally 'p1-default) |
---|
687 | (install-p1-handler 'multiple-value-bind 'p1-m-v-b) |
---|
688 | (install-p1-handler 'multiple-value-call 'p1-default) |
---|
689 | (install-p1-handler 'multiple-value-list 'p1-default) |
---|
690 | (install-p1-handler 'multiple-value-prog1 'p1-default) |
---|
691 | (install-p1-handler 'progn 'p1-default) |
---|
692 | (install-p1-handler 'progv 'identity) |
---|
693 | (install-p1-handler 'quote 'p1-quote) |
---|
694 | (install-p1-handler 'return-from 'p1-return-from) |
---|
695 | (install-p1-handler 'setq 'p1-setq) |
---|
696 | (install-p1-handler 'symbol-macrolet 'identity) |
---|
697 | (install-p1-handler 'tagbody 'p1-tagbody) |
---|
698 | (install-p1-handler 'the 'p1-the) |
---|
699 | (install-p1-handler 'throw 'p1-throw) |
---|
700 | (install-p1-handler 'unwind-protect 'p1-default) |
---|
701 | |
---|
702 | (defun dump-pool () |
---|
703 | (let ((pool (reverse *pool*)) |
---|
704 | entry type) |
---|
705 | (dotimes (index (1- *pool-count*)) |
---|
706 | (setq entry (car pool)) |
---|
707 | (setq type (case (car entry) |
---|
708 | (7 'class) |
---|
709 | (9 'field) |
---|
710 | (10 'method) |
---|
711 | (11 'interface) |
---|
712 | (8 'string) |
---|
713 | (3 'integer) |
---|
714 | (4 'float) |
---|
715 | (5 'long) |
---|
716 | (6 'double) |
---|
717 | (12 'name-and-type) |
---|
718 | (1 'utf8))) |
---|
719 | (%format t "~D: ~A ~S~%" (1+ index) type entry) |
---|
720 | (setq pool (cdr pool)))) |
---|
721 | t) |
---|
722 | |
---|
723 | (defun pool-get (entry) |
---|
724 | (declare (optimize speed)) |
---|
725 | (let ((index (gethash entry *pool-entries*))) |
---|
726 | (unless index |
---|
727 | (setf index *pool-count*) |
---|
728 | (push entry *pool*) |
---|
729 | (setf (gethash entry *pool-entries*) index) |
---|
730 | (setf *pool-count* (1+ index))) |
---|
731 | index)) |
---|
732 | |
---|
733 | (defun pool-name (name) |
---|
734 | (declare (optimize speed)) |
---|
735 | (pool-get (list 1 (length name) name))) |
---|
736 | |
---|
737 | (defun pool-name-and-type (name type) |
---|
738 | (declare (optimize speed)) |
---|
739 | (pool-get (list 12 |
---|
740 | (pool-name name) |
---|
741 | (pool-name type)))) |
---|
742 | |
---|
743 | ;; Assumes CLASS-NAME is already in the correct form ("org/armedbear/lisp/Lisp" |
---|
744 | ;; as opposed to "org.armedbear.lisp.Lisp"). |
---|
745 | (defun pool-class (class-name) |
---|
746 | (declare (optimize speed)) |
---|
747 | (pool-get (list 7 (pool-name class-name)))) |
---|
748 | |
---|
749 | ;; (tag class-index name-and-type-index) |
---|
750 | (defun pool-field (class-name field-name type-name) |
---|
751 | (declare (optimize speed)) |
---|
752 | (pool-get (list 9 |
---|
753 | (pool-class class-name) |
---|
754 | (pool-name-and-type field-name type-name)))) |
---|
755 | |
---|
756 | ;; (tag class-index name-and-type-index) |
---|
757 | (defun pool-method (class-name method-name type-name) |
---|
758 | (declare (optimize speed)) |
---|
759 | (pool-get (list 10 |
---|
760 | (pool-class class-name) |
---|
761 | (pool-name-and-type method-name type-name)))) |
---|
762 | |
---|
763 | (defun pool-string (string) |
---|
764 | (declare (optimize speed)) |
---|
765 | (pool-get (list 8 (pool-name string)))) |
---|
766 | |
---|
767 | (defun pool-int (n) |
---|
768 | (declare (optimize speed)) |
---|
769 | (pool-get (list 3 n))) |
---|
770 | |
---|
771 | (defun u2 (n) |
---|
772 | (declare (optimize speed)) |
---|
773 | (declare (type fixnum n)) |
---|
774 | (list (logand (ash n -8) #xff) |
---|
775 | (logand n #xff))) |
---|
776 | |
---|
777 | (locally (declare (optimize speed)) |
---|
778 | (defstruct (instruction |
---|
779 | (:constructor make-instruction (opcode args))) |
---|
780 | opcode |
---|
781 | args |
---|
782 | stack |
---|
783 | depth)) |
---|
784 | |
---|
785 | (defun print-instruction (instruction) |
---|
786 | (%format nil "~A ~A stack = ~S depth = ~S" |
---|
787 | (opcode-name (instruction-opcode instruction)) |
---|
788 | (instruction-args instruction) |
---|
789 | (instruction-stack instruction) |
---|
790 | (instruction-depth instruction))) |
---|
791 | |
---|
792 | (defun inst (instr &optional args) |
---|
793 | (let ((opcode (if (numberp instr) |
---|
794 | instr |
---|
795 | (opcode-number instr)))) |
---|
796 | (unless (listp args) |
---|
797 | (setf args (list args))) |
---|
798 | (make-instruction opcode args))) |
---|
799 | |
---|
800 | (defun emit (instr &rest args) |
---|
801 | (declare (optimize speed)) |
---|
802 | (let ((instruction (inst instr args))) |
---|
803 | (push instruction *code*) |
---|
804 | instruction)) |
---|
805 | |
---|
806 | (defun label (symbol) |
---|
807 | (declare (optimize speed)) |
---|
808 | (emit 'label symbol) |
---|
809 | (setf (symbol-value symbol) nil)) |
---|
810 | |
---|
811 | (defconstant +java-string+ "Ljava/lang/String;") |
---|
812 | (defconstant +lisp-class+ "org/armedbear/lisp/Lisp") |
---|
813 | (defconstant +lisp-object-class+ "org/armedbear/lisp/LispObject") |
---|
814 | (defconstant +lisp-object+ "Lorg/armedbear/lisp/LispObject;") |
---|
815 | (defconstant +lisp-string+ "Lorg/armedbear/lisp/SimpleString;") |
---|
816 | (defconstant +lisp-symbol-class+ "org/armedbear/lisp/Symbol") |
---|
817 | (defconstant +lisp-symbol+ "Lorg/armedbear/lisp/Symbol;") |
---|
818 | (defconstant +lisp-thread-class+ "org/armedbear/lisp/LispThread") |
---|
819 | (defconstant +lisp-thread+ "Lorg/armedbear/lisp/LispThread;") |
---|
820 | (defconstant +lisp-cons-class+ "org/armedbear/lisp/Cons") |
---|
821 | (defconstant +lisp-fixnum-class+ "org/armedbear/lisp/Fixnum") |
---|
822 | (defconstant +lisp-fixnum+ "Lorg/armedbear/lisp/Fixnum;") |
---|
823 | (defconstant +lisp-simple-string-class+ "org/armedbear/lisp/SimpleString") |
---|
824 | (defconstant +lisp-simple-string+ "Lorg/armedbear/lisp/SimpleString;") |
---|
825 | (defconstant +lisp-environment+ "Lorg/armedbear/lisp/Environment;") |
---|
826 | (defconstant +lisp-binding+ "Lorg/armedbear/lisp/Binding;") |
---|
827 | (defconstant +lisp-throw-class+ "org/armedbear/lisp/Throw") |
---|
828 | (defconstant +lisp-return-class+ "org/armedbear/lisp/Return") |
---|
829 | (defconstant +lisp-go-class+ "org/armedbear/lisp/Go") |
---|
830 | (defconstant +lisp-ctf-class+ "org/armedbear/lisp/ClosureTemplateFunction") |
---|
831 | |
---|
832 | (defsubst emit-push-nil () |
---|
833 | (emit 'getstatic +lisp-class+ "NIL" +lisp-object+)) |
---|
834 | |
---|
835 | (defsubst emit-push-t () |
---|
836 | (emit 'getstatic +lisp-class+ "T" +lisp-symbol+)) |
---|
837 | |
---|
838 | (defun emit-push-constant-int (n) |
---|
839 | (if (<= -32768 n 32767) |
---|
840 | (emit 'sipush n) |
---|
841 | (emit 'ldc (pool-int n)))) |
---|
842 | |
---|
843 | (defun make-descriptor (arg-types return-type) |
---|
844 | (with-output-to-string (s) |
---|
845 | (princ #\( s) |
---|
846 | (dolist (type arg-types) |
---|
847 | (princ type s)) |
---|
848 | (princ #\) s) |
---|
849 | (princ (if return-type return-type "V") s))) |
---|
850 | |
---|
851 | (defun descriptor (designator) |
---|
852 | (cond ((stringp designator) |
---|
853 | designator) |
---|
854 | ((listp designator) |
---|
855 | (unless (= (length designator) 2) |
---|
856 | (error "Bad method type descriptor ~S." designator)) |
---|
857 | (make-descriptor (car designator) (cadr designator))) |
---|
858 | (t |
---|
859 | (error "Bad method type descriptor ~S." designator)))) |
---|
860 | |
---|
861 | (defun emit-invokestatic (class-name method-name descriptor stack) |
---|
862 | (aver stack) |
---|
863 | (let ((instruction (emit 'invokestatic |
---|
864 | class-name method-name (descriptor descriptor)))) |
---|
865 | (setf (instruction-stack instruction) stack) |
---|
866 | (aver (eql (instruction-stack instruction) stack)))) |
---|
867 | |
---|
868 | (defun emit-invokespecial (class-name method-name descriptor stack) |
---|
869 | (let ((instruction (emit 'invokespecial |
---|
870 | class-name method-name (descriptor descriptor)))) |
---|
871 | (setf (instruction-stack instruction) stack))) |
---|
872 | |
---|
873 | (defun emit-invokevirtual (class-name method-name descriptor stack) |
---|
874 | (let ((instruction (emit 'invokevirtual |
---|
875 | class-name method-name (descriptor descriptor)))) |
---|
876 | (setf (instruction-stack instruction) stack))) |
---|
877 | |
---|
878 | ;; Index of local variable used to hold the current thread. |
---|
879 | (defvar *thread* nil) |
---|
880 | |
---|
881 | (defvar *initialize-thread-var* nil) |
---|
882 | |
---|
883 | (defun maybe-initialize-thread-var () |
---|
884 | (when *initialize-thread-var* |
---|
885 | (emit-invokestatic +lisp-thread-class+ |
---|
886 | "currentThread" |
---|
887 | (make-descriptor () +lisp-thread+) |
---|
888 | 1) |
---|
889 | (emit 'astore *thread*))) |
---|
890 | |
---|
891 | (defsubst ensure-thread-var-initialized () |
---|
892 | (setf *initialize-thread-var* t)) |
---|
893 | |
---|
894 | (defun emit-push-current-thread () |
---|
895 | (declare (optimize speed)) |
---|
896 | (ensure-thread-var-initialized) |
---|
897 | (emit 'aload *thread*)) |
---|
898 | |
---|
899 | (defun maybe-generate-arg-count-check () |
---|
900 | (when *arity* |
---|
901 | (let ((label1 (gensym))) |
---|
902 | (aver (fixnump *arity*)) |
---|
903 | (aver (not (minusp *arity*))) |
---|
904 | (emit 'aload 1) |
---|
905 | (emit 'arraylength) |
---|
906 | (emit 'bipush *arity*) |
---|
907 | (emit 'if_icmpeq `,label1) |
---|
908 | (emit 'aload 0) ; this |
---|
909 | (emit-invokevirtual *this-class* |
---|
910 | "argCountError" |
---|
911 | "()V" |
---|
912 | -1) |
---|
913 | (emit 'label `,label1)))) |
---|
914 | |
---|
915 | (defun maybe-generate-interrupt-check () |
---|
916 | (unless (> *speed* *safety*) |
---|
917 | (let ((label1 (gensym))) |
---|
918 | (emit 'getstatic +lisp-class+ "interrupted" "Z") |
---|
919 | (emit 'ifeq `,label1) |
---|
920 | (emit-invokestatic +lisp-class+ |
---|
921 | "handleInterrupt" |
---|
922 | "()V" |
---|
923 | 0) |
---|
924 | (emit 'label `,label1)))) |
---|
925 | |
---|
926 | (defun single-valued-p-init () |
---|
927 | (dolist (op '(+ - * / |
---|
928 | 1+ 1- < > <= >= = /= |
---|
929 | car cdr caar cadr cdar cddr cadar caddr cdddr cddddr |
---|
930 | first second third |
---|
931 | eq eql equal equalp |
---|
932 | length |
---|
933 | constantp symbolp |
---|
934 | list list* |
---|
935 | macro-function |
---|
936 | compiler-macro-function |
---|
937 | sys::%defun |
---|
938 | get |
---|
939 | atom |
---|
940 | compiled-function-p |
---|
941 | fdefinition |
---|
942 | special-operator-p keywordp functionp fboundp zerop consp listp |
---|
943 | numberp integerp floatp |
---|
944 | plusp minusp |
---|
945 | complexp arrayp readtablep packagep |
---|
946 | array-dimensions array-rank array-total-size |
---|
947 | array-element-type upgraded-array-element-type |
---|
948 | simple-vector-p simple-string-p bit-vector-p simple-bit-vector-p |
---|
949 | stringp |
---|
950 | row-major-aref |
---|
951 | quote function |
---|
952 | mapcar |
---|
953 | find position |
---|
954 | append nconc subseq adjoin |
---|
955 | revappend nreconc |
---|
956 | copy-seq |
---|
957 | assoc assoc-if assoc-if-not acons assq assql |
---|
958 | char-code code-char char-int digit-char-p |
---|
959 | member ext:memq |
---|
960 | remove remove-if remove-if-not delete delete-if delete-if-not |
---|
961 | special-variable-p |
---|
962 | gensym |
---|
963 | symbol-name symbol-function |
---|
964 | coerce |
---|
965 | reverse nreverse |
---|
966 | last |
---|
967 | cons rplaca rplacd |
---|
968 | sys::%rplaca sys::%rplacd |
---|
969 | copy-list copy-tree |
---|
970 | make-sequence make-list make-array make-package make-hash-table |
---|
971 | make-string |
---|
972 | find-package |
---|
973 | pathname make-pathname pathname-name directory |
---|
974 | package-used-by-list package-shadowing-symbols |
---|
975 | nthcdr |
---|
976 | aref elt |
---|
977 | not null endp |
---|
978 | concatenate |
---|
979 | format sys::%format |
---|
980 | prin1 princ print write |
---|
981 | compute-restarts find-restart restart-name |
---|
982 | string |
---|
983 | string= |
---|
984 | setq |
---|
985 | multiple-value-list push pop |
---|
986 | type-of class-of |
---|
987 | typep sys::%typep |
---|
988 | abs |
---|
989 | ash |
---|
990 | float-radix |
---|
991 | logand logandc1 logandc2 logeqv logior lognand |
---|
992 | lognot logorc1 logorc2 logxor |
---|
993 | logbitp |
---|
994 | slot-boundp slot-value slot-exists-p |
---|
995 | allocate-instance |
---|
996 | find-class |
---|
997 | class-name |
---|
998 | constantly |
---|
999 | exp expt log |
---|
1000 | min max |
---|
1001 | realpart imagpart |
---|
1002 | integer-length |
---|
1003 | sqrt isqrt gcd lcm signum |
---|
1004 | char schar |
---|
1005 | open |
---|
1006 | svref |
---|
1007 | fill-pointer |
---|
1008 | symbol-value symbol-package package-name |
---|
1009 | fourth |
---|
1010 | vector-push vector-push-extend |
---|
1011 | union nunion |
---|
1012 | remove-duplicates delete-duplicates |
---|
1013 | read-byte |
---|
1014 | fresh-line terpri |
---|
1015 | lambda |
---|
1016 | ext:classp |
---|
1017 | ext:fixnump |
---|
1018 | ext:memql |
---|
1019 | sys::generic-function-name |
---|
1020 | sys::puthash |
---|
1021 | precompiler::precompile1 |
---|
1022 | declare |
---|
1023 | go |
---|
1024 | sys::%structure-ref |
---|
1025 | inst |
---|
1026 | emit |
---|
1027 | label |
---|
1028 | maybe-emit-clear-values |
---|
1029 | single-valued-p |
---|
1030 | sys:single-valued-p |
---|
1031 | sys:write-8-bits |
---|
1032 | )) |
---|
1033 | (setf (sys:single-valued-p op) t))) |
---|
1034 | |
---|
1035 | (eval-when (:load-toplevel :execute) |
---|
1036 | (single-valued-p-init)) |
---|
1037 | |
---|
1038 | (defun single-valued-p (form) |
---|
1039 | (cond ((block-node-p form) |
---|
1040 | (if (equal (block-name form) '(TAGBODY)) |
---|
1041 | t |
---|
1042 | (single-valued-p (node-form form)))) |
---|
1043 | ((atom form) |
---|
1044 | t) |
---|
1045 | ((eq (first form) 'IF) |
---|
1046 | (and ;;(single-valued-p (second form)) |
---|
1047 | (single-valued-p (third form)) |
---|
1048 | (single-valued-p (fourth form)))) |
---|
1049 | ((eq (first form) 'PROGN) |
---|
1050 | (single-valued-p (car (last form)))) |
---|
1051 | ((memq (first form) '(LET LET*)) |
---|
1052 | (single-valued-p (car (last (cddr form))))) |
---|
1053 | ((memq (car form) '(AND OR)) |
---|
1054 | (every #'single-valued-p (cdr form))) |
---|
1055 | ((eq (first form) 'RETURN-FROM) |
---|
1056 | (single-valued-p (third form))) |
---|
1057 | (t |
---|
1058 | (sys:single-valued-p (car form))))) |
---|
1059 | |
---|
1060 | (defun emit-clear-values () |
---|
1061 | ;; (break "EMIT-CLEAR-VALUES called~%") |
---|
1062 | (ensure-thread-var-initialized) |
---|
1063 | (emit 'clear-values)) |
---|
1064 | |
---|
1065 | (defun maybe-emit-clear-values (form) |
---|
1066 | (declare (optimize speed)) |
---|
1067 | (unless (single-valued-p form) |
---|
1068 | ;; (format t "Not single-valued: ~S~%" form) |
---|
1069 | (ensure-thread-var-initialized) |
---|
1070 | (emit 'clear-values))) |
---|
1071 | |
---|
1072 | (defun emit-unbox-fixnum () |
---|
1073 | (declare (optimize speed)) |
---|
1074 | (cond ((= *safety* 3) |
---|
1075 | (emit-invokestatic +lisp-fixnum-class+ |
---|
1076 | "getValue" |
---|
1077 | "(Lorg/armedbear/lisp/LispObject;)I" |
---|
1078 | 0)) |
---|
1079 | (t |
---|
1080 | (emit 'checkcast +lisp-fixnum-class+) |
---|
1081 | (emit 'getfield +lisp-fixnum-class+ "value" "I")))) |
---|
1082 | |
---|
1083 | (defun emit-box-long () |
---|
1084 | (declare (optimize speed)) |
---|
1085 | (emit-invokestatic +lisp-class+ |
---|
1086 | "number" |
---|
1087 | "(J)Lorg/armedbear/lisp/LispObject;" |
---|
1088 | -1)) |
---|
1089 | |
---|
1090 | ;; Expects value on stack. |
---|
1091 | (defun emit-invoke-method (method-name target representation) |
---|
1092 | (emit-invokevirtual +lisp-object-class+ |
---|
1093 | method-name |
---|
1094 | "()Lorg/armedbear/lisp/LispObject;" |
---|
1095 | 0) |
---|
1096 | (when (eq representation :unboxed-fixnum) |
---|
1097 | (emit-unbox-fixnum)) |
---|
1098 | (emit-move-from-stack target representation)) |
---|
1099 | |
---|
1100 | (defvar *style-warnings* nil) |
---|
1101 | (defvar *warnings* nil) |
---|
1102 | (defvar *errors* nil) |
---|
1103 | |
---|
1104 | (defun compiler-style-warn (format-control &rest format-arguments) |
---|
1105 | (incf *style-warnings*) |
---|
1106 | (warn 'style-warning |
---|
1107 | :format-control format-control |
---|
1108 | :format-arguments format-arguments)) |
---|
1109 | |
---|
1110 | (defun compiler-warn (format-control &rest format-arguments) |
---|
1111 | (incf *warnings*) |
---|
1112 | (warn 'warning |
---|
1113 | :format-control format-control |
---|
1114 | :format-arguments format-arguments)) |
---|
1115 | |
---|
1116 | (defun check-args (form n) |
---|
1117 | (declare (type fixnum n)) |
---|
1118 | (cond ((= (length form) (1+ n)) |
---|
1119 | t) |
---|
1120 | (t |
---|
1121 | (compiler-style-warn "Wrong number of arguments for ~A." (car form)) |
---|
1122 | nil))) |
---|
1123 | |
---|
1124 | (defparameter *resolvers* (make-hash-table :test #'eql)) |
---|
1125 | |
---|
1126 | (defun unsupported-opcode (instruction) |
---|
1127 | (error "Unsupported opcode ~D." |
---|
1128 | (instruction-opcode instruction))) |
---|
1129 | |
---|
1130 | (dotimes (n (1+ *last-opcode*)) |
---|
1131 | (setf (gethash n *resolvers*) #'unsupported-opcode)) |
---|
1132 | |
---|
1133 | ;; The following opcodes resolve to themselves. |
---|
1134 | (dolist (n '(0 ; NOP |
---|
1135 | 1 ; ACONST_NULL |
---|
1136 | 2 ; ICONST_M1 |
---|
1137 | 3 ; ICONST_0 |
---|
1138 | 4 ; ICONST_1 |
---|
1139 | 5 ; ICONST_2 |
---|
1140 | 6 ; ICONST_3 |
---|
1141 | 7 ; ICONST_4 |
---|
1142 | 8 ; ICONST_5 |
---|
1143 | 42 ; ALOAD_0 |
---|
1144 | 43 ; ALOAD_1 |
---|
1145 | 44 ; ALOAD_2 |
---|
1146 | 45 ; ALOAD_3 |
---|
1147 | 50 ; AALOAD |
---|
1148 | 75 ; ASTORE_0 |
---|
1149 | 76 ; ASTORE_1 |
---|
1150 | 77 ; ASTORE_2 |
---|
1151 | 78 ; ASTORE_3 |
---|
1152 | 83 ; AASTORE |
---|
1153 | 87 ; POP |
---|
1154 | 89 ; DUP |
---|
1155 | 90 ; DUP_X1 |
---|
1156 | 91 ; DUP_X2 |
---|
1157 | 95 ; SWAP |
---|
1158 | 96 ; IADD |
---|
1159 | 97 ; LADD |
---|
1160 | 101 ; LSUB |
---|
1161 | 116 ; INEG |
---|
1162 | 120 ; ISHL |
---|
1163 | 121 ; LSHL |
---|
1164 | 122 ; ISHR |
---|
1165 | 123 ; LSHR |
---|
1166 | 126 ; IAND |
---|
1167 | 132 ; IINC |
---|
1168 | 133 ; I2L |
---|
1169 | 136 ; L2I |
---|
1170 | 153 ; IFEQ |
---|
1171 | 154 ; IFNE |
---|
1172 | 155 ; IFGE |
---|
1173 | 156 ; IFGT |
---|
1174 | 157 ; IFGT |
---|
1175 | 158 ; IFLE |
---|
1176 | 159 ; IF_ICMPEQ |
---|
1177 | 160 ; IF_ICMPNE |
---|
1178 | 161 ; IF_ICMPLT |
---|
1179 | 162 ; IF_ICMPGE |
---|
1180 | 163 ; IF_ICMPGT |
---|
1181 | 164 ; IF_ICMPLE |
---|
1182 | 165 ; IF_ACMPEQ |
---|
1183 | 166 ; IF_ACMPNE |
---|
1184 | 167 ; GOTO |
---|
1185 | 168 ; JSR |
---|
1186 | 169 ; RET |
---|
1187 | 176 ; ARETURN |
---|
1188 | 177 ; RETURN |
---|
1189 | 190 ; ARRAYLENGTH |
---|
1190 | 191 ; ATHROW |
---|
1191 | 198 ; IFNULL |
---|
1192 | 202 ; LABEL |
---|
1193 | )) |
---|
1194 | (setf (gethash n *resolvers*) nil)) |
---|
1195 | |
---|
1196 | (defmacro define-resolver (opcodes args &body body) |
---|
1197 | (let ((name (gensym))) |
---|
1198 | (if (listp opcodes) |
---|
1199 | `(progn |
---|
1200 | (defun ,name ,args ,@body) |
---|
1201 | (eval-when (:load-toplevel :execute) |
---|
1202 | (dolist (op ',opcodes) |
---|
1203 | (setf (gethash op *resolvers*) (symbol-function ',name))))) |
---|
1204 | `(progn |
---|
1205 | (defun ,name ,args ,@body) |
---|
1206 | (eval-when (:load-toplevel :execute) |
---|
1207 | (setf (gethash ,opcodes *resolvers*) (symbol-function ',name))))))) |
---|
1208 | |
---|
1209 | ;; ALOAD |
---|
1210 | (define-resolver 25 (instruction) |
---|
1211 | (let* ((args (instruction-args instruction)) |
---|
1212 | (index (car args))) |
---|
1213 | (cond ((<= 0 index 3) |
---|
1214 | (inst (+ index 42))) |
---|
1215 | ((<= 0 index 255) |
---|
1216 | (inst 25 index)) |
---|
1217 | (t |
---|
1218 | (error "ALOAD unsupported case"))))) |
---|
1219 | |
---|
1220 | ;; ILOAD |
---|
1221 | (define-resolver 21 (instruction) |
---|
1222 | (let* ((args (instruction-args instruction)) |
---|
1223 | (index (car args))) |
---|
1224 | (cond ((<= 0 index 3) |
---|
1225 | (inst (+ index 26))) |
---|
1226 | ((<= 0 index 255) |
---|
1227 | (inst 21 index)) |
---|
1228 | (t |
---|
1229 | (error "ILOAD unsupported case"))))) |
---|
1230 | |
---|
1231 | ;; ASTORE |
---|
1232 | (define-resolver 58 (instruction) |
---|
1233 | (let* ((args (instruction-args instruction)) |
---|
1234 | (index (car args))) |
---|
1235 | (cond ((<= 0 index 3) |
---|
1236 | (inst (+ index 75))) |
---|
1237 | ((<= 0 index 255) |
---|
1238 | (inst 58 index)) |
---|
1239 | (t |
---|
1240 | (error "ASTORE unsupported case"))))) |
---|
1241 | |
---|
1242 | ;; ISTORE |
---|
1243 | (define-resolver 54 (instruction) |
---|
1244 | (let* ((args (instruction-args instruction)) |
---|
1245 | (index (car args))) |
---|
1246 | (cond ((<= 0 index 3) |
---|
1247 | (inst (+ index 59))) |
---|
1248 | ((<= 0 index 255) |
---|
1249 | (inst 54 index)) |
---|
1250 | (t |
---|
1251 | (error "ASTORE unsupported case"))))) |
---|
1252 | |
---|
1253 | ;; GETSTATIC, PUTSTATIC |
---|
1254 | (define-resolver (178 179) (instruction) |
---|
1255 | (let* ((args (instruction-args instruction)) |
---|
1256 | (index (pool-field (first args) (second args) (third args)))) |
---|
1257 | (inst (instruction-opcode instruction) (u2 index)))) |
---|
1258 | |
---|
1259 | ;; BIPUSH, SIPUSH |
---|
1260 | (define-resolver (16 17) (instruction) |
---|
1261 | (let* ((args (instruction-args instruction)) |
---|
1262 | (n (first args))) |
---|
1263 | (cond ((<= 0 n 5) |
---|
1264 | (inst (+ n 3))) |
---|
1265 | ((<= -128 n 127) |
---|
1266 | (inst 16 (logand n #xff))) ; BIPUSH |
---|
1267 | (t ; SIPUSH |
---|
1268 | (inst 17 (u2 n)))))) |
---|
1269 | |
---|
1270 | ;; INVOKEVIRTUAL, INVOKESPECIAL, INVOKESTATIC class-name method-name descriptor |
---|
1271 | (define-resolver (182 183 184) (instruction) |
---|
1272 | (let* ((args (instruction-args instruction)) |
---|
1273 | (index (pool-method (first args) (second args) (third args)))) |
---|
1274 | (setf (instruction-args instruction) (u2 index)) |
---|
1275 | instruction)) |
---|
1276 | |
---|
1277 | ;; LDC |
---|
1278 | (define-resolver 18 (instruction) |
---|
1279 | (let* ((args (instruction-args instruction))) |
---|
1280 | (unless (= (length args) 1) |
---|
1281 | (error "Wrong number of args for LDC.")) |
---|
1282 | (if (> (car args) 255) |
---|
1283 | (inst 19 (u2 (car args))) ; LDC_W |
---|
1284 | (inst 18 args)))) |
---|
1285 | |
---|
1286 | ;; GETFIELD, PUTFIELD class-name field-name type-name |
---|
1287 | (define-resolver (180 181) (instruction) |
---|
1288 | (let* ((args (instruction-args instruction)) |
---|
1289 | (index (pool-field (first args) (second args) (third args)))) |
---|
1290 | (inst (instruction-opcode instruction) (u2 index)))) |
---|
1291 | |
---|
1292 | ;; NEW, ANEWARRAY, CHECKCAST, INSTANCEOF class-name |
---|
1293 | (define-resolver (187 189 192 193) (instruction) |
---|
1294 | (let* ((args (instruction-args instruction)) |
---|
1295 | (index (pool-class (first args)))) |
---|
1296 | (inst (instruction-opcode instruction) (u2 index)))) |
---|
1297 | |
---|
1298 | (defun resolve-instruction (instruction) |
---|
1299 | (declare (optimize speed)) |
---|
1300 | (let ((resolver (gethash (instruction-opcode instruction) *resolvers*))) |
---|
1301 | (if resolver |
---|
1302 | (funcall resolver instruction) |
---|
1303 | instruction))) |
---|
1304 | |
---|
1305 | (defun resolve-instructions (code) |
---|
1306 | (let ((vector (make-array 512 :fill-pointer 0 :adjustable t))) |
---|
1307 | (dotimes (index (the fixnum (length code)) vector) |
---|
1308 | (declare (type fixnum index)) |
---|
1309 | (let ((instruction (svref code index))) |
---|
1310 | (case (instruction-opcode instruction) |
---|
1311 | (205 ; CLEAR-VALUES |
---|
1312 | (let ((instructions |
---|
1313 | (list |
---|
1314 | (inst 'aload *thread*) |
---|
1315 | (inst 'aconst_null) |
---|
1316 | (inst 'putfield (list +lisp-thread-class+ "_values" |
---|
1317 | "[Lorg/armedbear/lisp/LispObject;"))))) |
---|
1318 | (dolist (instruction instructions) |
---|
1319 | (vector-push-extend (resolve-instruction instruction) vector)))) |
---|
1320 | (t |
---|
1321 | (vector-push-extend (resolve-instruction instruction) vector))))))) |
---|
1322 | |
---|
1323 | (defconstant +branch-opcodes+ |
---|
1324 | '(153 ; IFEQ |
---|
1325 | 154 ; IFNE |
---|
1326 | 155 ; IFLT |
---|
1327 | 156 ; IFGE |
---|
1328 | 157 ; IFGT |
---|
1329 | 158 ; IFLE |
---|
1330 | 159 ; IF_ICMPEQ |
---|
1331 | 160 ; IF_ICMPNE |
---|
1332 | 161 ; IF_ICMPLT |
---|
1333 | 162 ; IF_ICMPGE |
---|
1334 | 163 ; IF_ICMPGT |
---|
1335 | 164 ; IF_ICMPLE |
---|
1336 | 165 ; IF_ACMPEQ |
---|
1337 | 166 ; IF_ACMPNE |
---|
1338 | 167 ; GOTO |
---|
1339 | 168 ; JSR |
---|
1340 | 198 ; IFNULL |
---|
1341 | )) |
---|
1342 | |
---|
1343 | (defsubst branch-opcode-p (opcode) |
---|
1344 | (declare (optimize speed)) |
---|
1345 | (member opcode +branch-opcodes+)) |
---|
1346 | |
---|
1347 | (defun walk-code (code start-index depth) |
---|
1348 | (declare (optimize speed)) |
---|
1349 | (do* ((i start-index (1+ i)) |
---|
1350 | (limit (length code))) |
---|
1351 | ((>= i limit)) |
---|
1352 | (declare (type fixnum i limit)) |
---|
1353 | (let ((instruction (aref code i))) |
---|
1354 | (when (instruction-depth instruction) |
---|
1355 | (unless (eql (instruction-depth instruction) (+ depth (instruction-stack instruction))) |
---|
1356 | (fresh-line) |
---|
1357 | (%format t "Stack inconsistency at index ~D: found ~S, expected ~S.~%" |
---|
1358 | i |
---|
1359 | (instruction-depth instruction) |
---|
1360 | (+ depth (instruction-stack instruction)))) |
---|
1361 | (return-from walk-code)) |
---|
1362 | (let ((opcode (instruction-opcode instruction))) |
---|
1363 | (unless (eql opcode 168) ; JSR |
---|
1364 | (setf depth (+ depth (instruction-stack instruction)))) |
---|
1365 | (setf (instruction-depth instruction) depth) |
---|
1366 | (if (eql opcode 168) ; JSR |
---|
1367 | (let ((label (car (instruction-args instruction)))) |
---|
1368 | (walk-code code (symbol-value label) (1+ depth))) |
---|
1369 | (when (branch-opcode-p opcode) |
---|
1370 | (let ((label (car (instruction-args instruction)))) |
---|
1371 | (walk-code code (symbol-value label) depth)))) |
---|
1372 | (when (member opcode '(167 169 191)) ; GOTO RET ATHROW |
---|
1373 | ;; Current path ends. |
---|
1374 | (return-from walk-code)))))) |
---|
1375 | |
---|
1376 | (defun analyze-stack () |
---|
1377 | (let* ((code *code*) |
---|
1378 | (code-length (length code))) |
---|
1379 | (declare (type fixnum code-length)) |
---|
1380 | (aver (vectorp code)) |
---|
1381 | (dotimes (i code-length) |
---|
1382 | (declare (type fixnum i)) |
---|
1383 | (let* ((instruction (aref code i)) |
---|
1384 | (opcode (instruction-opcode instruction))) |
---|
1385 | (when (eql opcode 202) ; LABEL |
---|
1386 | (let ((label (car (instruction-args instruction)))) |
---|
1387 | (set label i))) |
---|
1388 | (if (instruction-stack instruction) |
---|
1389 | (when (opcode-stack-effect opcode) |
---|
1390 | (unless (eql (instruction-stack instruction) (opcode-stack-effect opcode)) |
---|
1391 | (%format t "instruction-stack = ~S opcode-stack-effect = ~S~%" |
---|
1392 | (instruction-stack instruction) |
---|
1393 | (opcode-stack-effect opcode)) |
---|
1394 | (%format t "index = ~D instruction = ~A~%" i (print-instruction instruction)))) |
---|
1395 | (setf (instruction-stack instruction) (opcode-stack-effect opcode))) |
---|
1396 | ;; (aver (not (null (instruction-stack instruction)))) |
---|
1397 | (unless (instruction-stack instruction) |
---|
1398 | (%format t "no stack information for instruction ~D~%" (instruction-opcode instruction)) |
---|
1399 | (aver nil)))) |
---|
1400 | (walk-code code 0 0) |
---|
1401 | (dolist (handler *handlers*) |
---|
1402 | ;; Stack depth is always 1 when handler is called. |
---|
1403 | (walk-code code (symbol-value (handler-code handler)) 1)) |
---|
1404 | (let ((max-stack 0)) |
---|
1405 | (dotimes (i code-length) |
---|
1406 | (declare (type fixnum i)) |
---|
1407 | (let* ((instruction (aref code i)) |
---|
1408 | (depth (instruction-depth instruction))) |
---|
1409 | (when depth |
---|
1410 | (setf max-stack (max max-stack depth))))) |
---|
1411 | (when *compiler-debug* |
---|
1412 | (%format t "compiland name = ~S~%" (compiland-name *current-compiland*)) |
---|
1413 | (%format t "max-stack = ~D~%" max-stack) |
---|
1414 | (%format t "----- after stack analysis -----~%") |
---|
1415 | (print-code)) |
---|
1416 | max-stack))) |
---|
1417 | |
---|
1418 | (defun emit-move-from-stack (target &optional representation) |
---|
1419 | (declare (optimize speed)) |
---|
1420 | (cond ((null target) |
---|
1421 | (emit 'pop)) |
---|
1422 | ((eq target :stack)) |
---|
1423 | ((fixnump target) |
---|
1424 | (emit (if (eq representation :unboxed-fixnum) 'istore 'astore) target)) |
---|
1425 | (t |
---|
1426 | (aver nil)))) |
---|
1427 | |
---|
1428 | (defun resolve-variables () |
---|
1429 | (let ((code (nreverse *code*))) |
---|
1430 | (setf *code* nil) |
---|
1431 | (dolist (instruction code) |
---|
1432 | (case (instruction-opcode instruction) |
---|
1433 | (206 ; VAR-REF |
---|
1434 | (let* ((instruction-args (instruction-args instruction)) |
---|
1435 | (variable (first instruction-args)) |
---|
1436 | (target (second instruction-args)) |
---|
1437 | (representation (third instruction-args))) |
---|
1438 | (aver (variable-p variable)) |
---|
1439 | (cond |
---|
1440 | ((variable-register variable) |
---|
1441 | (dformat t "variable = ~S register = ~S~%" |
---|
1442 | (variable-name variable) |
---|
1443 | (variable-register variable)) |
---|
1444 | (emit 'aload (variable-register variable)) |
---|
1445 | (emit-move-from-stack target)) |
---|
1446 | ((variable-special-p variable) |
---|
1447 | (compile-special-reference (variable-name variable) target nil)) |
---|
1448 | ((variable-closure-index variable) |
---|
1449 | (dformat t "variable = ~S closure-index = ~S~%" |
---|
1450 | (variable-name variable) (variable-closure-index variable)) |
---|
1451 | (aver (not (null (compiland-closure-register *current-compiland*)))) |
---|
1452 | (emit 'aload (compiland-closure-register *current-compiland*)) |
---|
1453 | (emit 'bipush (variable-closure-index variable)) |
---|
1454 | (emit 'aaload) |
---|
1455 | (emit-move-from-stack target)) |
---|
1456 | ((variable-index variable) |
---|
1457 | (aver (not (null (compiland-argument-register *current-compiland*)))) |
---|
1458 | (emit 'aload (compiland-argument-register *current-compiland*)) |
---|
1459 | (emit-push-constant-int (variable-index variable)) |
---|
1460 | (emit 'aaload) |
---|
1461 | (emit-move-from-stack target)) |
---|
1462 | (t |
---|
1463 | (dformat t "VAR-REF unhandled case variable = ~S~%" (variable-name variable)) |
---|
1464 | (aver (progn 'unhandled-case nil)))) |
---|
1465 | (when (eq representation :unboxed-fixnum) |
---|
1466 | (dformat t "resolve-variables calling emit-unbox-fixnum~%") |
---|
1467 | (emit-unbox-fixnum)))) |
---|
1468 | (207 ; VAR-SET |
---|
1469 | (let ((variable (car (instruction-args instruction)))) |
---|
1470 | (dformat t "var-set var = ~S reg = ~S closure index = ~S~%" |
---|
1471 | (variable-name variable) |
---|
1472 | (variable-register variable) |
---|
1473 | (variable-closure-index variable) |
---|
1474 | ) |
---|
1475 | (aver (variable-p variable)) |
---|
1476 | (aver (not (variable-special-p variable))) |
---|
1477 | (cond ((variable-register variable) |
---|
1478 | (emit 'astore (variable-register variable))) |
---|
1479 | ((variable-closure-index variable) |
---|
1480 | (dformat t "variable = ~S closure-index = ~S~%" |
---|
1481 | (variable-name variable) (variable-closure-index variable)) |
---|
1482 | (aver (not (null (compiland-closure-register *current-compiland*)))) |
---|
1483 | (emit 'aload (compiland-closure-register *current-compiland*)) |
---|
1484 | (emit 'swap) ; array value |
---|
1485 | (emit 'bipush (variable-closure-index variable)) |
---|
1486 | (emit 'swap) ; array index value |
---|
1487 | (emit 'aastore) |
---|
1488 | ) |
---|
1489 | (t |
---|
1490 | (dformat t "var-set fall-through case~%") |
---|
1491 | (aver (not (null (compiland-argument-register *current-compiland*)))) |
---|
1492 | (emit 'aload (compiland-argument-register *current-compiland*)) ; Stack: value array |
---|
1493 | (emit 'swap) ; array value |
---|
1494 | (emit 'bipush (variable-index variable)) ; array value index |
---|
1495 | (emit 'swap) ; array index value |
---|
1496 | (emit 'aastore))))) |
---|
1497 | (t |
---|
1498 | (push instruction *code*)))))) |
---|
1499 | |
---|
1500 | (defun finalize-code () |
---|
1501 | (setf *code* (nreverse (coerce *code* 'vector)))) |
---|
1502 | |
---|
1503 | (defun print-code() |
---|
1504 | (dotimes (i (length *code*)) |
---|
1505 | (let ((instruction (aref *code* i))) |
---|
1506 | (%format t "~D ~A ~S ~S ~S~%" |
---|
1507 | i |
---|
1508 | (opcode-name (instruction-opcode instruction)) |
---|
1509 | (instruction-args instruction) |
---|
1510 | (instruction-stack instruction) |
---|
1511 | (instruction-depth instruction))))) |
---|
1512 | |
---|
1513 | (defun validate-labels (code) |
---|
1514 | (let ((code (coerce code 'list)) |
---|
1515 | (i 0)) |
---|
1516 | (dolist (instruction code) |
---|
1517 | (when (eql (instruction-opcode instruction) 202) ; LABEL |
---|
1518 | (let ((label (car (instruction-args instruction)))) |
---|
1519 | (set label i))) |
---|
1520 | (incf i)))) |
---|
1521 | |
---|
1522 | ;; Remove unused labels. |
---|
1523 | (defun optimize-1 () |
---|
1524 | (let ((code (coerce *code* 'list)) |
---|
1525 | (changed nil) |
---|
1526 | (marker (gensym))) |
---|
1527 | ;; Mark the labels that are actually branched to. |
---|
1528 | (dolist (instruction code) |
---|
1529 | (when (branch-opcode-p (instruction-opcode instruction)) |
---|
1530 | (let ((label (car (instruction-args instruction)))) |
---|
1531 | (set label marker)))) |
---|
1532 | ;; Add labels used for exception handlers. |
---|
1533 | (dolist (handler *handlers*) |
---|
1534 | (set (handler-from handler) marker) |
---|
1535 | (set (handler-to handler) marker) |
---|
1536 | (set (handler-code handler) marker)) |
---|
1537 | ;; Remove labels that are not used as branch targets. |
---|
1538 | (let ((tail code)) |
---|
1539 | (loop |
---|
1540 | (when (null tail) |
---|
1541 | (return)) |
---|
1542 | (let ((instruction (car tail))) |
---|
1543 | (when (= (instruction-opcode instruction) 202) ; LABEL |
---|
1544 | (let ((label (car (instruction-args instruction)))) |
---|
1545 | (unless (eq (symbol-value label) marker) |
---|
1546 | (setf (car tail) nil) |
---|
1547 | (setf changed t))))) |
---|
1548 | (setf tail (cdr tail)))) |
---|
1549 | (when changed |
---|
1550 | (setf *code* (delete nil code)) |
---|
1551 | t))) |
---|
1552 | |
---|
1553 | (defun optimize-2 () |
---|
1554 | (let* ((code (coerce *code* 'list)) |
---|
1555 | (tail code) |
---|
1556 | (changed nil)) |
---|
1557 | (loop |
---|
1558 | (when (null (cdr tail)) |
---|
1559 | (return)) |
---|
1560 | (let ((instruction (car tail)) |
---|
1561 | next-instruction) |
---|
1562 | (when (and instruction |
---|
1563 | (= (instruction-opcode instruction) 167) ; GOTO |
---|
1564 | (setf next-instruction (cadr tail))) |
---|
1565 | (cond ((and (= (instruction-opcode next-instruction) 202) ; LABEL |
---|
1566 | (eq (car (instruction-args instruction)) |
---|
1567 | (car (instruction-args next-instruction)))) |
---|
1568 | ;; GOTO next instruction: we don't need this one. |
---|
1569 | (setf (car tail) nil) |
---|
1570 | (setf changed t)) |
---|
1571 | ((= (instruction-opcode next-instruction) 167) ; GOTO |
---|
1572 | ;; Two GOTOs in a row: the next instruction is unreachable. |
---|
1573 | (setf (cadr tail) nil) |
---|
1574 | (setf changed t))))) |
---|
1575 | (setf tail (cdr tail))) |
---|
1576 | (when changed |
---|
1577 | (setf *code* (delete nil code)) |
---|
1578 | t))) |
---|
1579 | |
---|
1580 | ;; CLEAR-VALUES CLEAR-VALUES => CLEAR-VALUES |
---|
1581 | ;; GETSTATIC POP => nothing |
---|
1582 | (defun optimize-3 () |
---|
1583 | (let* ((code (coerce *code* 'list)) |
---|
1584 | (tail code) |
---|
1585 | (changed nil)) |
---|
1586 | (loop |
---|
1587 | (when (null (cdr tail)) |
---|
1588 | (return)) |
---|
1589 | (let ((this-opcode (instruction-opcode (car tail))) |
---|
1590 | (next-opcode (instruction-opcode (cadr tail)))) |
---|
1591 | (case this-opcode |
---|
1592 | (205 ; CLEAR-VALUES |
---|
1593 | (when (eql next-opcode 205) ; CLEAR-VALUES |
---|
1594 | (setf (car tail) (cadr tail) |
---|
1595 | (cdr tail) (cddr tail) |
---|
1596 | changed t))) |
---|
1597 | (178 ; GETSTATIC |
---|
1598 | (when (eql next-opcode 87) ; POP |
---|
1599 | (setf (car tail) (caddr tail) |
---|
1600 | (cdr tail) (cdddr tail) |
---|
1601 | changed t))))) |
---|
1602 | (setf tail (cdr tail))) |
---|
1603 | (when changed |
---|
1604 | (setf *code* code) |
---|
1605 | t))) |
---|
1606 | |
---|
1607 | (defvar *delete-unreachable-code-flag* t) |
---|
1608 | |
---|
1609 | (defun delete-unreachable-code () |
---|
1610 | (when *delete-unreachable-code-flag* |
---|
1611 | ;; Look for unreachable code after GOTO. |
---|
1612 | (unless (listp *code*) |
---|
1613 | (setf *code* (coerce *code* 'list))) |
---|
1614 | (validate-labels *code*) |
---|
1615 | (let* ((code *code*) |
---|
1616 | (tail code) |
---|
1617 | (locally-changed-p nil) |
---|
1618 | (after-goto nil)) |
---|
1619 | (loop |
---|
1620 | (when (null tail) |
---|
1621 | (return)) |
---|
1622 | (let ((instruction (car tail))) |
---|
1623 | (cond (after-goto |
---|
1624 | (if (= (instruction-opcode instruction) 202) ; LABEL |
---|
1625 | (setf after-goto nil) |
---|
1626 | ;; Unreachable. |
---|
1627 | (progn |
---|
1628 | (setf (car tail) nil) |
---|
1629 | (setf locally-changed-p t)))) |
---|
1630 | ((= (instruction-opcode instruction) 167) ; GOTO |
---|
1631 | (setf after-goto t)))) |
---|
1632 | (setf tail (cdr tail))) |
---|
1633 | (when locally-changed-p |
---|
1634 | (setf *code* (delete nil code)) |
---|
1635 | t)))) |
---|
1636 | |
---|
1637 | (defvar *enable-optimization* t) |
---|
1638 | |
---|
1639 | (defun optimize-code () |
---|
1640 | (unless *enable-optimization* |
---|
1641 | (%format t "optimizations are disabled~%")) |
---|
1642 | (when *enable-optimization* |
---|
1643 | (when *compiler-debug* |
---|
1644 | (%format t "----- before optimization -----~%") |
---|
1645 | (print-code)) |
---|
1646 | (loop |
---|
1647 | (let ((changed-p nil)) |
---|
1648 | (setf changed-p (or (optimize-1) changed-p)) |
---|
1649 | (setf changed-p (or (optimize-2) changed-p)) |
---|
1650 | (setf changed-p (or (optimize-3) changed-p)) |
---|
1651 | (setf changed-p (or (delete-unreachable-code) changed-p)) |
---|
1652 | (unless changed-p |
---|
1653 | (return)))) |
---|
1654 | (unless (typep *code* 'vector) |
---|
1655 | (setf *code* (coerce *code* 'vector))) |
---|
1656 | (when *compiler-debug* |
---|
1657 | (%format t "----- after optimization -----~%") |
---|
1658 | (print-code)))) |
---|
1659 | |
---|
1660 | (defun code-bytes (code) |
---|
1661 | (let ((length 0)) |
---|
1662 | ;; (declare (type fixnum length)) |
---|
1663 | ;; Pass 1: calculate label offsets and overall length. |
---|
1664 | (dotimes (i (length code)) |
---|
1665 | (declare (type fixnum i)) |
---|
1666 | (let* ((instruction (aref code i)) |
---|
1667 | (opcode (instruction-opcode instruction))) |
---|
1668 | (if (= opcode 202) ; LABEL |
---|
1669 | (let ((label (car (instruction-args instruction)))) |
---|
1670 | (set label length)) |
---|
1671 | (incf length (opcode-size opcode))))) |
---|
1672 | ;; Pass 2: replace labels with calculated offsets. |
---|
1673 | (let ((index 0)) |
---|
1674 | ;; (declare (type fixnum index)) |
---|
1675 | (dotimes (i (length code)) |
---|
1676 | (declare (type fixnum i)) |
---|
1677 | (let ((instruction (aref code i))) |
---|
1678 | (when (branch-opcode-p (instruction-opcode instruction)) |
---|
1679 | (let* ((label (car (instruction-args instruction))) |
---|
1680 | (offset (- (symbol-value `,label) index))) |
---|
1681 | (setf (instruction-args instruction) (u2 offset)))) |
---|
1682 | (unless (= (instruction-opcode instruction) 202) ; LABEL |
---|
1683 | (incf index (opcode-size (instruction-opcode instruction))))))) |
---|
1684 | ;; Expand instructions into bytes, skipping LABEL pseudo-instructions. |
---|
1685 | (let ((bytes (make-array length)) |
---|
1686 | (index 0)) |
---|
1687 | ;; (declare (type fixnum index)) |
---|
1688 | (dotimes (i (length code)) |
---|
1689 | (declare (type fixnum i)) |
---|
1690 | (let ((instruction (aref code i))) |
---|
1691 | (unless (= (instruction-opcode instruction) 202) ; LABEL |
---|
1692 | (setf (svref bytes index) (instruction-opcode instruction)) |
---|
1693 | (incf index) |
---|
1694 | (dolist (byte (instruction-args instruction)) |
---|
1695 | (setf (svref bytes index) byte) |
---|
1696 | (incf index))))) |
---|
1697 | bytes))) |
---|
1698 | |
---|
1699 | (defsubst write-u1 (n stream) |
---|
1700 | (declare (optimize speed)) |
---|
1701 | (sys::write-8-bits n stream)) |
---|
1702 | |
---|
1703 | (defun write-u2 (n stream) |
---|
1704 | (declare (optimize speed)) |
---|
1705 | (sys::write-8-bits (ash n -8) stream) |
---|
1706 | (sys::write-8-bits (logand n #xFF) stream)) |
---|
1707 | |
---|
1708 | (defun write-u4 (n stream) |
---|
1709 | (declare (optimize speed)) |
---|
1710 | (write-u2 (ash n -16) stream) |
---|
1711 | (write-u2 (logand n #xFFFF) stream)) |
---|
1712 | |
---|
1713 | (defun write-s4 (n stream) |
---|
1714 | (declare (optimize speed)) |
---|
1715 | (cond ((minusp n) |
---|
1716 | (write-u4 (1+ (logxor (- n) #xFFFFFFFF)) stream)) |
---|
1717 | (t |
---|
1718 | (write-u4 n stream)))) |
---|
1719 | |
---|
1720 | (defun write-utf8 (string stream) |
---|
1721 | (declare (optimize speed)) |
---|
1722 | (dotimes (i (length string)) |
---|
1723 | (declare (type fixnum i)) |
---|
1724 | (let ((c (schar string i))) |
---|
1725 | (if (eql c #\null) |
---|
1726 | (progn |
---|
1727 | (sys::write-8-bits #xC0 stream) |
---|
1728 | (sys::write-8-bits #x80 stream)) |
---|
1729 | (sys::write-8-bits (char-int c) stream))))) |
---|
1730 | |
---|
1731 | (defun utf8-length (string) |
---|
1732 | (declare (optimize speed)) |
---|
1733 | (let ((length (length string))) |
---|
1734 | (declare (type fixnum length)) |
---|
1735 | (dotimes (i length) |
---|
1736 | (declare (type fixnum i)) |
---|
1737 | (when (eql (schar string i) #\null) |
---|
1738 | (incf length))) |
---|
1739 | length)) |
---|
1740 | |
---|
1741 | (defun write-constant-pool-entry (entry stream) |
---|
1742 | (declare (optimize speed)) |
---|
1743 | (let ((tag (first entry))) |
---|
1744 | (write-u1 tag stream) |
---|
1745 | (case tag |
---|
1746 | (1 ; UTF8 |
---|
1747 | (write-u2 (utf8-length (third entry)) stream) |
---|
1748 | (write-utf8 (third entry) stream)) |
---|
1749 | (3 ; int |
---|
1750 | (write-s4 (second entry) stream)) |
---|
1751 | ((5 6) |
---|
1752 | (write-u4 (second entry) stream) |
---|
1753 | (write-u4 (third entry)) stream) |
---|
1754 | ((9 10 11 12) |
---|
1755 | (write-u2 (second entry) stream) |
---|
1756 | (write-u2 (third entry) stream)) |
---|
1757 | ((7 8) |
---|
1758 | (write-u2 (second entry) stream)) |
---|
1759 | (t |
---|
1760 | (error "WRITE-CP-ENTRY unhandled tag ~D~%" tag))))) |
---|
1761 | |
---|
1762 | (defun write-constant-pool (stream) |
---|
1763 | (declare (optimize speed)) |
---|
1764 | (write-u2 *pool-count* stream) |
---|
1765 | (dolist (entry (reverse *pool*)) |
---|
1766 | (write-constant-pool-entry entry stream))) |
---|
1767 | |
---|
1768 | (defstruct field |
---|
1769 | access-flags |
---|
1770 | name |
---|
1771 | descriptor |
---|
1772 | name-index |
---|
1773 | descriptor-index) |
---|
1774 | |
---|
1775 | (defstruct method |
---|
1776 | access-flags |
---|
1777 | name |
---|
1778 | descriptor |
---|
1779 | name-index |
---|
1780 | descriptor-index |
---|
1781 | max-stack |
---|
1782 | max-locals |
---|
1783 | code |
---|
1784 | handlers) |
---|
1785 | |
---|
1786 | (defun make-constructor (super name args body) |
---|
1787 | (let* ((*compiler-debug* nil) ; We don't normally need to see debugging output for constructors. |
---|
1788 | (constructor (make-method :name "<init>" |
---|
1789 | :descriptor "()V")) |
---|
1790 | (*code* ()) |
---|
1791 | (*handlers* nil)) |
---|
1792 | (dformat t "make-constructor super = ~S~%" super) |
---|
1793 | (setf (method-name-index constructor) (pool-name (method-name constructor))) |
---|
1794 | (setf (method-descriptor-index constructor) (pool-name (method-descriptor constructor))) |
---|
1795 | (setf (method-max-locals constructor) 1) |
---|
1796 | (cond |
---|
1797 | (*hairy-arglist-p* |
---|
1798 | (emit 'aload_0) ;; this |
---|
1799 | (emit 'aconst_null) ;; name |
---|
1800 | (let* ((*print-level* nil) |
---|
1801 | (*print-length* nil) |
---|
1802 | (s (%format nil "~S" args))) |
---|
1803 | (emit 'ldc |
---|
1804 | (pool-string s)) |
---|
1805 | (emit-invokestatic +lisp-class+ |
---|
1806 | "readObjectFromString" |
---|
1807 | "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;" |
---|
1808 | 0)) |
---|
1809 | (emit-push-nil) ;; body |
---|
1810 | (emit 'aconst_null) ;; environment |
---|
1811 | (emit-invokespecial super |
---|
1812 | "<init>" |
---|
1813 | ;; "(Lorg/armedbear/lisp/Symbol;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/Environment;)V" |
---|
1814 | `((,+lisp-symbol+ ,+lisp-object+ ,+lisp-object+ ,+lisp-environment+) nil) |
---|
1815 | -5)) |
---|
1816 | (*child-p* |
---|
1817 | (cond |
---|
1818 | ((null *closure-variables*) |
---|
1819 | (emit 'aload_0) |
---|
1820 | (emit-invokespecial super |
---|
1821 | "<init>" |
---|
1822 | "()V" |
---|
1823 | -1)) |
---|
1824 | (t |
---|
1825 | (emit 'aload_0) ;; this |
---|
1826 | (let* ((*print-level* nil) |
---|
1827 | (*print-length* nil) |
---|
1828 | (s (%format nil "~S" args))) |
---|
1829 | (emit 'ldc |
---|
1830 | (pool-string s)) |
---|
1831 | (emit-invokestatic +lisp-class+ |
---|
1832 | "readObjectFromString" |
---|
1833 | "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;" |
---|
1834 | 0)) |
---|
1835 | (emit-invokespecial super |
---|
1836 | "<init>" |
---|
1837 | "(Lorg/armedbear/lisp/LispObject;)V" |
---|
1838 | -2)))) |
---|
1839 | (t |
---|
1840 | (emit 'aload_0) |
---|
1841 | (emit-invokespecial super |
---|
1842 | "<init>" |
---|
1843 | "()V" |
---|
1844 | -1))) |
---|
1845 | (setf *code* (append *static-code* *code*)) |
---|
1846 | (emit 'return) |
---|
1847 | (finalize-code) |
---|
1848 | ;; (optimize-code) |
---|
1849 | (setf *code* (resolve-instructions *code*)) |
---|
1850 | (setf (method-max-stack constructor) (analyze-stack)) |
---|
1851 | (setf (method-code constructor) (code-bytes *code*)) |
---|
1852 | (setf (method-handlers constructor) (nreverse *handlers*)) |
---|
1853 | constructor)) |
---|
1854 | |
---|
1855 | (defun write-exception-table (method stream) |
---|
1856 | (let ((handlers (method-handlers method))) |
---|
1857 | (write-u2 (length handlers) stream) ; number of entries |
---|
1858 | (dolist (handler handlers) |
---|
1859 | (write-u2 (symbol-value (handler-from handler)) stream) |
---|
1860 | (write-u2 (symbol-value (handler-to handler)) stream) |
---|
1861 | (write-u2 (symbol-value (handler-code handler)) stream) |
---|
1862 | (write-u2 (handler-catch-type handler) stream)))) |
---|
1863 | |
---|
1864 | (defun write-code-attr (method stream) |
---|
1865 | (declare (optimize speed)) |
---|
1866 | (let* ((name-index (pool-name "Code")) |
---|
1867 | (code (method-code method)) |
---|
1868 | (code-length (length code)) |
---|
1869 | (length (+ code-length 12 |
---|
1870 | (* (length (method-handlers method)) 8))) |
---|
1871 | (max-stack (or (method-max-stack method) 20)) |
---|
1872 | (max-locals (or (method-max-locals method) 1))) |
---|
1873 | (write-u2 name-index stream) |
---|
1874 | (write-u4 length stream) |
---|
1875 | (write-u2 max-stack stream) |
---|
1876 | (write-u2 max-locals stream) |
---|
1877 | (write-u4 code-length stream) |
---|
1878 | (dotimes (i code-length) |
---|
1879 | (declare (type fixnum i)) |
---|
1880 | (write-u1 (svref code i) stream)) |
---|
1881 | (write-exception-table method stream) |
---|
1882 | (write-u2 0 stream) ; attributes count |
---|
1883 | )) |
---|
1884 | |
---|
1885 | (defun write-method (method stream) |
---|
1886 | (declare (optimize speed)) |
---|
1887 | (write-u2 (or (method-access-flags method) #x1) stream) ; access flags |
---|
1888 | (write-u2 (method-name-index method) stream) |
---|
1889 | (write-u2 (method-descriptor-index method) stream) |
---|
1890 | (write-u2 1 stream) ; attributes count |
---|
1891 | (write-code-attr method stream)) |
---|
1892 | |
---|
1893 | (defun write-field (field stream) |
---|
1894 | (declare (optimize speed)) |
---|
1895 | (write-u2 (or (field-access-flags field) #x1) stream) ; access flags |
---|
1896 | (write-u2 (field-name-index field) stream) |
---|
1897 | (write-u2 (field-descriptor-index field) stream) |
---|
1898 | (write-u2 0 stream)) ; attributes count |
---|
1899 | |
---|
1900 | (defun declare-field (name descriptor) |
---|
1901 | (let ((field (make-field :name name :descriptor descriptor))) |
---|
1902 | (setf (field-access-flags field) (logior #x8 #x2)) ; private static |
---|
1903 | (setf (field-name-index field) (pool-name (field-name field))) |
---|
1904 | (setf (field-descriptor-index field) (pool-name (field-descriptor field))) |
---|
1905 | (setq *fields* (cons field *fields*)))) |
---|
1906 | |
---|
1907 | (defun sanitize (symbol) |
---|
1908 | (declare (optimize speed)) |
---|
1909 | (let* ((input (symbol-name symbol)) |
---|
1910 | (output (make-array (length input) :fill-pointer 0 :element-type 'character))) |
---|
1911 | (dotimes (i (length input)) |
---|
1912 | (declare (type fixnum i)) |
---|
1913 | (let ((c (char-upcase (char input i)))) |
---|
1914 | (cond ((<= #.(char-code #\A) (char-code c) #.(char-code #\Z)) |
---|
1915 | (vector-push c output)) |
---|
1916 | ((eql c #\-) |
---|
1917 | (vector-push #\_ output))))) |
---|
1918 | (when (plusp (length output)) |
---|
1919 | output))) |
---|
1920 | |
---|
1921 | (defvar *declared-symbols* nil) |
---|
1922 | (defvar *declared-functions* nil) |
---|
1923 | (defvar *declared-strings* nil) |
---|
1924 | (defvar *declared-fixnums* nil) |
---|
1925 | |
---|
1926 | (defun declare-symbol (symbol) |
---|
1927 | (let ((g (gethash symbol *declared-symbols*))) |
---|
1928 | (unless g |
---|
1929 | (let ((*code* *static-code*) |
---|
1930 | (s (sanitize symbol))) |
---|
1931 | (setf g (symbol-name (gensym))) |
---|
1932 | (when s |
---|
1933 | (setf g (concatenate 'string g "_" s))) |
---|
1934 | (declare-field g +lisp-symbol+) |
---|
1935 | (emit 'ldc (pool-string (symbol-name symbol))) |
---|
1936 | (emit 'ldc (pool-string (package-name (symbol-package symbol)))) |
---|
1937 | (emit-invokestatic +lisp-class+ |
---|
1938 | "internInPackage" |
---|
1939 | "(Ljava/lang/String;Ljava/lang/String;)Lorg/armedbear/lisp/Symbol;" |
---|
1940 | -1) |
---|
1941 | (emit 'putstatic |
---|
1942 | *this-class* |
---|
1943 | g |
---|
1944 | +lisp-symbol+) |
---|
1945 | (setf *static-code* *code*) |
---|
1946 | (setf (gethash symbol *declared-symbols*) g))) |
---|
1947 | g)) |
---|
1948 | |
---|
1949 | (defun declare-keyword (symbol) |
---|
1950 | (let ((g (gethash symbol *declared-symbols*))) |
---|
1951 | (unless g |
---|
1952 | (let ((*code* *static-code*)) |
---|
1953 | (setf g (symbol-name (gensym))) |
---|
1954 | (declare-field g +lisp-symbol+) |
---|
1955 | (emit 'ldc (pool-string (symbol-name symbol))) |
---|
1956 | (emit-invokestatic "org/armedbear/lisp/Keyword" |
---|
1957 | "internKeyword" |
---|
1958 | "(Ljava/lang/String;)Lorg/armedbear/lisp/Symbol;" |
---|
1959 | 0) |
---|
1960 | (emit 'putstatic |
---|
1961 | *this-class* |
---|
1962 | g |
---|
1963 | +lisp-symbol+) |
---|
1964 | (setf *static-code* *code*) |
---|
1965 | (setf (gethash symbol *declared-symbols*) g))) |
---|
1966 | g)) |
---|
1967 | |
---|
1968 | (defun declare-function (symbol) |
---|
1969 | (let ((f (gethash symbol *declared-functions*))) |
---|
1970 | (unless f |
---|
1971 | (setf f (symbol-name (gensym))) |
---|
1972 | (let ((s (sanitize symbol))) |
---|
1973 | (when s |
---|
1974 | (setf f (concatenate 'string f "_" s)))) |
---|
1975 | (let ((*code* *static-code*) |
---|
1976 | (g (gethash symbol *declared-symbols*))) |
---|
1977 | (cond (g |
---|
1978 | (emit 'getstatic |
---|
1979 | *this-class* |
---|
1980 | g |
---|
1981 | +lisp-symbol+)) |
---|
1982 | (t |
---|
1983 | (emit 'ldc (pool-string (symbol-name symbol))) |
---|
1984 | (emit 'ldc (pool-string (package-name (symbol-package symbol)))) |
---|
1985 | (emit-invokestatic +lisp-class+ |
---|
1986 | "internInPackage" |
---|
1987 | "(Ljava/lang/String;Ljava/lang/String;)Lorg/armedbear/lisp/Symbol;" |
---|
1988 | -1))) |
---|
1989 | (declare-field f +lisp-object+) |
---|
1990 | (emit-invokevirtual +lisp-symbol-class+ |
---|
1991 | "getSymbolFunctionOrDie" |
---|
1992 | "()Lorg/armedbear/lisp/LispObject;" |
---|
1993 | 0) |
---|
1994 | (emit 'putstatic |
---|
1995 | *this-class* |
---|
1996 | f |
---|
1997 | +lisp-object+) |
---|
1998 | (setq *static-code* *code*) |
---|
1999 | (setf (gethash symbol *declared-functions*) f))) |
---|
2000 | f)) |
---|
2001 | |
---|
2002 | (defun declare-setf-function (name) |
---|
2003 | (let ((f (gethash name *declared-functions*))) |
---|
2004 | (unless f |
---|
2005 | (let ((symbol (cadr name))) |
---|
2006 | (setf f (symbol-name (gensym))) |
---|
2007 | (let ((s (sanitize symbol))) |
---|
2008 | (when s |
---|
2009 | (setf f (concatenate 'string f "_SETF_" s)))) |
---|
2010 | (let ((*code* *static-code*) |
---|
2011 | (g (gethash symbol *declared-symbols*))) |
---|
2012 | (cond (g |
---|
2013 | (emit 'getstatic |
---|
2014 | *this-class* |
---|
2015 | g |
---|
2016 | +lisp-symbol+)) |
---|
2017 | (t |
---|
2018 | (emit 'ldc (pool-string (symbol-name symbol))) |
---|
2019 | (emit 'ldc (pool-string (package-name (symbol-package symbol)))) |
---|
2020 | (emit-invokestatic +lisp-class+ |
---|
2021 | "internInPackage" |
---|
2022 | "(Ljava/lang/String;Ljava/lang/String;)Lorg/armedbear/lisp/Symbol;" |
---|
2023 | -1))) |
---|
2024 | (declare-field f +lisp-object+) |
---|
2025 | (emit-invokevirtual +lisp-symbol-class+ |
---|
2026 | "getSymbolSetfFunctionOrDie" |
---|
2027 | "()Lorg/armedbear/lisp/LispObject;" |
---|
2028 | 0) |
---|
2029 | (emit 'putstatic |
---|
2030 | *this-class* |
---|
2031 | f |
---|
2032 | +lisp-object+) |
---|
2033 | (setq *static-code* *code*) |
---|
2034 | (setf (gethash name *declared-functions*) f)))) |
---|
2035 | f)) |
---|
2036 | |
---|
2037 | (defun declare-fixnum (n) |
---|
2038 | (declare (type fixnum n)) |
---|
2039 | (let ((g (gethash n *declared-fixnums*))) |
---|
2040 | (unless g |
---|
2041 | (let ((*code* *static-code*)) |
---|
2042 | (setf g (%format nil "FIXNUM_~A~D" |
---|
2043 | (if (minusp n) "MINUS_" "") |
---|
2044 | (abs n))) |
---|
2045 | (declare-field g +lisp-fixnum+) |
---|
2046 | (emit 'new +lisp-fixnum-class+) |
---|
2047 | (emit 'dup) |
---|
2048 | (case n |
---|
2049 | (-1 |
---|
2050 | (emit 'iconst_m1)) |
---|
2051 | (0 |
---|
2052 | (emit 'iconst_0)) |
---|
2053 | (1 |
---|
2054 | (emit 'iconst_1)) |
---|
2055 | (2 |
---|
2056 | (emit 'iconst_2)) |
---|
2057 | (3 |
---|
2058 | (emit 'iconst_3)) |
---|
2059 | (4 |
---|
2060 | (emit 'iconst_4)) |
---|
2061 | (5 |
---|
2062 | (emit 'iconst_5)) |
---|
2063 | (t |
---|
2064 | (emit 'ldc (pool-int n)))) |
---|
2065 | (emit-invokespecial +lisp-fixnum-class+ "<init>" "(I)V" -2) |
---|
2066 | (emit 'putstatic *this-class* g +lisp-fixnum+) |
---|
2067 | (setf *static-code* *code*) |
---|
2068 | (setf (gethash n *declared-fixnums*) g))) |
---|
2069 | g)) |
---|
2070 | |
---|
2071 | (defun declare-object-as-string (obj) |
---|
2072 | (let* ((g (symbol-name (gensym))) |
---|
2073 | (*print-level* nil) |
---|
2074 | (*print-length* nil) |
---|
2075 | (s (%format nil "~S" obj)) |
---|
2076 | (*code* *static-code*)) |
---|
2077 | (declare-field g +lisp-object+) |
---|
2078 | (emit 'ldc |
---|
2079 | (pool-string s)) |
---|
2080 | (emit-invokestatic +lisp-class+ |
---|
2081 | "readObjectFromString" |
---|
2082 | "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;" |
---|
2083 | 0) |
---|
2084 | (emit 'putstatic |
---|
2085 | *this-class* |
---|
2086 | g |
---|
2087 | +lisp-object+) |
---|
2088 | (setf *static-code* *code*) |
---|
2089 | g)) |
---|
2090 | |
---|
2091 | (defun declare-package (obj) |
---|
2092 | (let* ((g (symbol-name (gensym))) |
---|
2093 | (*print-level* nil) |
---|
2094 | (*print-length* nil) |
---|
2095 | (s (%format nil "#.(FIND-PACKAGE ~S)" (package-name obj))) |
---|
2096 | (*code* *static-code*)) |
---|
2097 | (declare-field g +lisp-object+) |
---|
2098 | (emit 'ldc |
---|
2099 | (pool-string s)) |
---|
2100 | (emit-invokestatic +lisp-class+ |
---|
2101 | "readObjectFromString" |
---|
2102 | "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;" |
---|
2103 | 0) |
---|
2104 | (emit 'putstatic |
---|
2105 | *this-class* |
---|
2106 | g |
---|
2107 | +lisp-object+) |
---|
2108 | (setf *static-code* *code*) |
---|
2109 | g)) |
---|
2110 | |
---|
2111 | (defun declare-object (obj) |
---|
2112 | (let ((key (symbol-name (gensym)))) |
---|
2113 | (sys::remember key obj) |
---|
2114 | (let* ((g1 (declare-string key)) |
---|
2115 | (g2 (symbol-name (gensym))) |
---|
2116 | (*code* *static-code*)) |
---|
2117 | (declare-field g2 +lisp-object+) |
---|
2118 | (emit 'getstatic |
---|
2119 | *this-class* |
---|
2120 | g1 |
---|
2121 | +lisp-string+) |
---|
2122 | (emit 'dup) |
---|
2123 | (emit-invokestatic +lisp-class+ |
---|
2124 | "recall" |
---|
2125 | "(Lorg/armedbear/lisp/SimpleString;)Lorg/armedbear/lisp/LispObject;" |
---|
2126 | 0) |
---|
2127 | (emit 'putstatic |
---|
2128 | *this-class* |
---|
2129 | g2 |
---|
2130 | +lisp-object+) |
---|
2131 | (emit-invokestatic +lisp-class+ |
---|
2132 | "forget" |
---|
2133 | "(Lorg/armedbear/lisp/SimpleString;)V" |
---|
2134 | -1) |
---|
2135 | (setf *static-code* *code*) |
---|
2136 | g2))) |
---|
2137 | |
---|
2138 | (defun declare-lambda (obj) |
---|
2139 | (let* ((g (symbol-name (gensym))) |
---|
2140 | (*print-level* nil) |
---|
2141 | (*print-length* nil) |
---|
2142 | (s (%format nil "~S" obj)) |
---|
2143 | (*code* *static-code*)) |
---|
2144 | (declare-field g +lisp-object+) |
---|
2145 | (emit 'ldc |
---|
2146 | (pool-string s)) |
---|
2147 | (emit-invokestatic +lisp-class+ |
---|
2148 | "readObjectFromString" |
---|
2149 | "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;" |
---|
2150 | 0) |
---|
2151 | (emit-invokestatic +lisp-class+ |
---|
2152 | "coerceToFunction" |
---|
2153 | "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" |
---|
2154 | 0) |
---|
2155 | (emit 'putstatic |
---|
2156 | *this-class* |
---|
2157 | g |
---|
2158 | +lisp-object+) |
---|
2159 | (setf *static-code* *code*) |
---|
2160 | g)) |
---|
2161 | |
---|
2162 | (defun declare-local-function (local-function) |
---|
2163 | (let* ((g (symbol-name (gensym))) |
---|
2164 | (classfile (local-function-classfile local-function)) |
---|
2165 | (*code* *static-code*)) |
---|
2166 | (declare-field g +lisp-object+) |
---|
2167 | (emit 'ldc |
---|
2168 | (pool-string (file-namestring classfile))) |
---|
2169 | (emit-invokestatic +lisp-class+ |
---|
2170 | "loadCompiledFunction" |
---|
2171 | "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;" |
---|
2172 | 0) |
---|
2173 | (emit 'putstatic |
---|
2174 | *this-class* |
---|
2175 | g |
---|
2176 | +lisp-object+) |
---|
2177 | (setf *static-code* *code*) |
---|
2178 | g)) |
---|
2179 | |
---|
2180 | (defun declare-string (string) |
---|
2181 | (let ((g (gethash string *declared-strings*))) |
---|
2182 | (unless g |
---|
2183 | (let ((*code* *static-code*)) |
---|
2184 | (setf g (symbol-name (gensym))) |
---|
2185 | (declare-field g +lisp-simple-string+) |
---|
2186 | (emit 'new +lisp-simple-string-class+) |
---|
2187 | (emit 'dup) |
---|
2188 | (emit 'ldc (pool-string string)) |
---|
2189 | (emit-invokespecial +lisp-simple-string-class+ |
---|
2190 | "<init>" |
---|
2191 | "(Ljava/lang/String;)V" |
---|
2192 | -2) |
---|
2193 | (emit 'putstatic |
---|
2194 | *this-class* |
---|
2195 | g |
---|
2196 | +lisp-simple-string+) |
---|
2197 | (setf *static-code* *code*) |
---|
2198 | (setf (gethash string *declared-strings*) g))) |
---|
2199 | g)) |
---|
2200 | |
---|
2201 | (defun compile-constant (form &key (target *val*) representation) |
---|
2202 | (unless target |
---|
2203 | (return-from compile-constant)) |
---|
2204 | (when (eq representation :unboxed-fixnum) |
---|
2205 | (cond |
---|
2206 | ((fixnump form) |
---|
2207 | (emit-push-constant-int form) |
---|
2208 | (emit-move-from-stack target) |
---|
2209 | (return-from compile-constant)) |
---|
2210 | (t |
---|
2211 | (assert nil)))) |
---|
2212 | (cond ((numberp form) |
---|
2213 | (if (fixnump form) |
---|
2214 | (let* ((n form) |
---|
2215 | (translations '(( 0 . "ZERO") |
---|
2216 | ( 1 . "ONE") |
---|
2217 | ( 2 . "TWO") |
---|
2218 | ( 3 . "THREE") |
---|
2219 | (-1 . "MINUS_ONE"))) |
---|
2220 | (translation (cdr (assoc n translations)))) |
---|
2221 | (if translation |
---|
2222 | (emit 'getstatic |
---|
2223 | +lisp-fixnum-class+ |
---|
2224 | translation |
---|
2225 | +lisp-fixnum+) |
---|
2226 | (emit 'getstatic |
---|
2227 | *this-class* |
---|
2228 | (declare-fixnum n) |
---|
2229 | +lisp-fixnum+))) |
---|
2230 | (emit 'getstatic |
---|
2231 | *this-class* |
---|
2232 | (declare-object-as-string form) |
---|
2233 | +lisp-object+))) |
---|
2234 | ((stringp form) |
---|
2235 | (if *compile-file-truename* |
---|
2236 | (emit 'getstatic |
---|
2237 | *this-class* |
---|
2238 | (declare-string form) |
---|
2239 | +lisp-simple-string+) |
---|
2240 | (emit 'getstatic |
---|
2241 | *this-class* |
---|
2242 | (declare-object form) |
---|
2243 | +lisp-object+))) |
---|
2244 | ((vectorp form) |
---|
2245 | (if *compile-file-truename* |
---|
2246 | (emit 'getstatic |
---|
2247 | *this-class* |
---|
2248 | (declare-object-as-string form) |
---|
2249 | +lisp-object+) |
---|
2250 | (emit 'getstatic |
---|
2251 | *this-class* |
---|
2252 | (declare-object form) |
---|
2253 | +lisp-object+))) |
---|
2254 | ((characterp form) |
---|
2255 | (emit 'getstatic |
---|
2256 | *this-class* |
---|
2257 | (declare-object-as-string form) |
---|
2258 | +lisp-object+)) |
---|
2259 | ((or (classp form) (hash-table-p form) (typep form 'generic-function)) |
---|
2260 | (emit 'getstatic |
---|
2261 | *this-class* |
---|
2262 | (declare-object form) |
---|
2263 | +lisp-object+)) |
---|
2264 | ((pathnamep form) |
---|
2265 | (let ((g (if *compile-file-truename* |
---|
2266 | (declare-object-as-string form) |
---|
2267 | (declare-object form)))) |
---|
2268 | (emit 'getstatic |
---|
2269 | *this-class* |
---|
2270 | g |
---|
2271 | +lisp-object+))) |
---|
2272 | ((packagep form) |
---|
2273 | (let ((g (if *compile-file-truename* |
---|
2274 | (declare-package form) |
---|
2275 | (declare-object form)))) |
---|
2276 | (emit 'getstatic |
---|
2277 | *this-class* |
---|
2278 | g |
---|
2279 | +lisp-object+))) |
---|
2280 | (t |
---|
2281 | (if *compile-file-truename* |
---|
2282 | (error "COMPILE-CONSTANT unhandled case ~S" form) |
---|
2283 | (emit 'getstatic |
---|
2284 | *this-class* |
---|
2285 | (declare-object form) |
---|
2286 | +lisp-object+)))) |
---|
2287 | (emit-move-from-stack target)) |
---|
2288 | |
---|
2289 | (defparameter unary-operators (make-hash-table :test 'eq)) |
---|
2290 | |
---|
2291 | (defun define-unary-operator (operator translation) |
---|
2292 | (setf (gethash operator unary-operators) translation)) |
---|
2293 | |
---|
2294 | (define-unary-operator '1+ "incr") |
---|
2295 | (define-unary-operator '1- "decr") |
---|
2296 | (define-unary-operator 'ABS "ABS") |
---|
2297 | (define-unary-operator 'ATOM "ATOM") |
---|
2298 | (define-unary-operator 'BIT-VECTOR-P "BIT_VECTOR_P") |
---|
2299 | (define-unary-operator 'CADR "cadr") |
---|
2300 | (define-unary-operator 'CAR "car") |
---|
2301 | (define-unary-operator 'CDDR "cddr") |
---|
2302 | (define-unary-operator 'CDR "cdr") |
---|
2303 | (define-unary-operator 'CHARACTERP "CHARACTERP") |
---|
2304 | (define-unary-operator 'CLASS-OF "classOf") |
---|
2305 | (define-unary-operator 'COMPLEXP "COMPLEXP") |
---|
2306 | (define-unary-operator 'CONSTANTP "CONSTANTP") |
---|
2307 | (define-unary-operator 'DENOMINATOR "DENOMINATOR") |
---|
2308 | (define-unary-operator 'ENDP "ENDP") |
---|
2309 | (define-unary-operator 'EVENP "EVENP") |
---|
2310 | (define-unary-operator 'FIRST "car") |
---|
2311 | (define-unary-operator 'FLOATP "FLOATP") |
---|
2312 | (define-unary-operator 'INTEGERP "INTEGERP") |
---|
2313 | (define-unary-operator 'LENGTH "LENGTH") |
---|
2314 | (define-unary-operator 'LISTP "LISTP") |
---|
2315 | (define-unary-operator 'MINUSP "MINUSP") |
---|
2316 | (define-unary-operator 'NREVERSE "nreverse") |
---|
2317 | (define-unary-operator 'NUMBERP "NUMBERP") |
---|
2318 | (define-unary-operator 'NUMERATOR "NUMERATOR") |
---|
2319 | (define-unary-operator 'ODDP "ODDP") |
---|
2320 | (define-unary-operator 'PLUSP "PLUSP") |
---|
2321 | (define-unary-operator 'RATIONALP "RATIONALP") |
---|
2322 | (define-unary-operator 'REALP "REALP") |
---|
2323 | (define-unary-operator 'REST "cdr") |
---|
2324 | (define-unary-operator 'SECOND "cadr") |
---|
2325 | (define-unary-operator 'SIMPLE-STRING-P "SIMPLE_STRING_P") |
---|
2326 | (define-unary-operator 'STRING "STRING") |
---|
2327 | (define-unary-operator 'STRINGP "STRINGP") |
---|
2328 | (define-unary-operator 'SYMBOLP "SYMBOLP") |
---|
2329 | (define-unary-operator 'VECTORP "VECTORP") |
---|
2330 | (define-unary-operator 'ZEROP "ZEROP") |
---|
2331 | |
---|
2332 | (defun compile-function-call-1 (fun args target representation) |
---|
2333 | (let ((arg (first args))) |
---|
2334 | (when (eq fun '1+) |
---|
2335 | (return-from compile-function-call-1 (compile-plus (list '+ 1 arg) |
---|
2336 | :target target |
---|
2337 | :representation representation))) |
---|
2338 | (let ((s (gethash fun unary-operators))) |
---|
2339 | (cond (s |
---|
2340 | (compile-form arg :target :stack) |
---|
2341 | (maybe-emit-clear-values arg) |
---|
2342 | (emit-invoke-method s target representation) |
---|
2343 | t) |
---|
2344 | ((eq fun 'LIST) |
---|
2345 | (emit 'new +lisp-cons-class+) |
---|
2346 | (emit 'dup) |
---|
2347 | (compile-form arg :target :stack) |
---|
2348 | (maybe-emit-clear-values arg) |
---|
2349 | (emit-invokespecial +lisp-cons-class+ |
---|
2350 | "<init>" |
---|
2351 | "(Lorg/armedbear/lisp/LispObject;)V" |
---|
2352 | -2) |
---|
2353 | t) |
---|
2354 | (t |
---|
2355 | nil))))) |
---|
2356 | |
---|
2357 | (defparameter binary-operators (make-hash-table :test 'eq)) |
---|
2358 | |
---|
2359 | (defun define-binary-operator (operator translation) |
---|
2360 | (setf (gethash operator binary-operators) translation)) |
---|
2361 | |
---|
2362 | (define-binary-operator 'eql "EQL") |
---|
2363 | (define-binary-operator 'equal "EQUAL") |
---|
2364 | (define-binary-operator '+ "add") |
---|
2365 | (define-binary-operator '- "subtract") |
---|
2366 | (define-binary-operator '/ "divideBy") |
---|
2367 | (define-binary-operator '* "multiplyBy") |
---|
2368 | (define-binary-operator '< "IS_LT") |
---|
2369 | (define-binary-operator '<= "IS_LE") |
---|
2370 | (define-binary-operator '> "IS_GT") |
---|
2371 | (define-binary-operator '>= "IS_GE") |
---|
2372 | (define-binary-operator ' = "IS_E") |
---|
2373 | (define-binary-operator '/= "IS_NE") |
---|
2374 | (define-binary-operator 'mod "MOD") |
---|
2375 | (define-binary-operator 'ash "ash") |
---|
2376 | (define-binary-operator 'logand "logand") |
---|
2377 | (define-binary-operator 'aref "AREF") |
---|
2378 | (define-binary-operator 'sys::simple-typep "typep") |
---|
2379 | (define-binary-operator 'rplaca "RPLACA") |
---|
2380 | (define-binary-operator 'rplacd "RPLACD") |
---|
2381 | (define-binary-operator 'sys::%rplaca "_RPLACA") |
---|
2382 | (define-binary-operator 'sys::%rplacd "_RPLACD") |
---|
2383 | |
---|
2384 | (defun compile-binary-operation (op args target representation) |
---|
2385 | ;; (dformat t "compile-binary-operation op = ~S representation = ~S~%" |
---|
2386 | ;; op representation) |
---|
2387 | (compile-form (first args) :target :stack) |
---|
2388 | (compile-form (second args) :target :stack) |
---|
2389 | (unless (and (single-valued-p (first args)) |
---|
2390 | (single-valued-p (second args))) |
---|
2391 | (emit-clear-values)) |
---|
2392 | (emit-invokevirtual +lisp-object-class+ |
---|
2393 | op |
---|
2394 | "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" |
---|
2395 | -1) |
---|
2396 | (when (eq representation :unboxed-fixnum) |
---|
2397 | (emit-unbox-fixnum)) |
---|
2398 | (emit-move-from-stack target)) |
---|
2399 | |
---|
2400 | (defun compile-function-call-2 (op args target representation) |
---|
2401 | (let ((translation (gethash op binary-operators)) |
---|
2402 | (first (first args)) |
---|
2403 | (second (second args))) |
---|
2404 | (if translation |
---|
2405 | (compile-binary-operation translation args target representation) |
---|
2406 | (case op |
---|
2407 | (EQ |
---|
2408 | (compile-form first :target :stack) |
---|
2409 | (compile-form second :target :stack) |
---|
2410 | (unless (and (single-valued-p first) |
---|
2411 | (single-valued-p second)) |
---|
2412 | (emit-clear-values)) |
---|
2413 | (let ((label1 (gensym)) |
---|
2414 | (label2 (gensym))) |
---|
2415 | (emit 'if_acmpeq `,label1) |
---|
2416 | (emit-push-nil) |
---|
2417 | (emit 'goto `,label2) |
---|
2418 | (emit 'label `,label1) |
---|
2419 | (emit-push-t) |
---|
2420 | (emit 'label `,label2)) |
---|
2421 | (emit-move-from-stack target) |
---|
2422 | t) |
---|
2423 | (LIST |
---|
2424 | (compile-form first :target :stack) |
---|
2425 | (compile-form second :target :stack) |
---|
2426 | (unless (and (single-valued-p first) |
---|
2427 | (single-valued-p second)) |
---|
2428 | (emit-clear-values)) |
---|
2429 | (emit-invokestatic +lisp-class+ |
---|
2430 | "list2" |
---|
2431 | "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/Cons;" |
---|
2432 | -1) |
---|
2433 | (emit-move-from-stack target) |
---|
2434 | t) |
---|
2435 | (SYS::%STRUCTURE-REF |
---|
2436 | (when (fixnump second) |
---|
2437 | (compile-form first :target :stack) |
---|
2438 | (maybe-emit-clear-values first) |
---|
2439 | (emit 'sipush second) |
---|
2440 | (emit-invokevirtual +lisp-object-class+ |
---|
2441 | "getSlotValue" |
---|
2442 | "(I)Lorg/armedbear/lisp/LispObject;" |
---|
2443 | -1) |
---|
2444 | (when (eq representation :unboxed-fixnum) |
---|
2445 | (emit-unbox-fixnum)) |
---|
2446 | (emit-move-from-stack target representation) |
---|
2447 | t)) |
---|
2448 | (t |
---|
2449 | nil))))) |
---|
2450 | |
---|
2451 | (defun fixnum-or-unboxed-variable-p (arg) |
---|
2452 | (or (fixnump arg) |
---|
2453 | (unboxed-fixnum-variable arg))) |
---|
2454 | |
---|
2455 | (defun emit-push-int (arg) |
---|
2456 | (if (fixnump arg) |
---|
2457 | (emit-push-constant-int arg) |
---|
2458 | (let ((variable (unboxed-fixnum-variable arg))) |
---|
2459 | (if variable |
---|
2460 | (emit 'iload (variable-register variable)) |
---|
2461 | (aver nil))))) |
---|
2462 | |
---|
2463 | (defun p2-eql (form &key (target *val*) representation) |
---|
2464 | ;; (dformat t "p2-eql form = ~S~%" form) |
---|
2465 | (unless (= (length form) 3) |
---|
2466 | (error "Wrong number of arguments for EQL.")) |
---|
2467 | (let ((arg1 (second form)) |
---|
2468 | (arg2 (third form))) |
---|
2469 | ;; (dformat t "arg1 = ~S~%" arg1) |
---|
2470 | ;; (dformat t "arg2 = ~S~%" arg2) |
---|
2471 | (cond |
---|
2472 | ((and (fixnum-or-unboxed-variable-p arg1) |
---|
2473 | (fixnum-or-unboxed-variable-p arg2)) |
---|
2474 | ;; (dformat t "p2-eql case 1~%") |
---|
2475 | (emit-push-int arg1) |
---|
2476 | (emit-push-int arg2) |
---|
2477 | (let ((label1 (gensym)) |
---|
2478 | (label2 (gensym))) |
---|
2479 | (emit 'if_icmpeq `,label1) |
---|
2480 | (emit-push-nil) |
---|
2481 | (emit 'goto `,label2) |
---|
2482 | (emit 'label `,label1) |
---|
2483 | (emit-push-t) |
---|
2484 | (emit 'label `,label2)) |
---|
2485 | (emit-move-from-stack target)) |
---|
2486 | ((fixnum-or-unboxed-variable-p arg1) |
---|
2487 | (emit-push-int arg1) |
---|
2488 | (compile-form arg2 :target :stack) |
---|
2489 | (maybe-emit-clear-values arg2) |
---|
2490 | (emit 'swap) |
---|
2491 | (emit-invokevirtual +lisp-object-class+ |
---|
2492 | "eql" |
---|
2493 | "(I)Z" |
---|
2494 | -1) |
---|
2495 | (let ((label1 (gensym)) |
---|
2496 | (label2 (gensym))) |
---|
2497 | (emit 'ifne `,label1) |
---|
2498 | (emit-push-nil) |
---|
2499 | (emit 'goto `,label2) |
---|
2500 | (emit 'label `,label1) |
---|
2501 | (emit-push-t) |
---|
2502 | (emit 'label `,label2)) |
---|
2503 | (emit-move-from-stack target)) |
---|
2504 | ((fixnum-or-unboxed-variable-p arg2) |
---|
2505 | (compile-form arg1 :target :stack) |
---|
2506 | (maybe-emit-clear-values arg1) |
---|
2507 | (emit-push-int arg2) |
---|
2508 | (emit-invokevirtual +lisp-object-class+ |
---|
2509 | "eql" |
---|
2510 | "(I)Z" |
---|
2511 | -1) |
---|
2512 | (let ((label1 (gensym)) |
---|
2513 | (label2 (gensym))) |
---|
2514 | (emit 'ifne `,label1) |
---|
2515 | (emit-push-nil) |
---|
2516 | (emit 'goto `,label2) |
---|
2517 | (emit 'label `,label1) |
---|
2518 | (emit-push-t) |
---|
2519 | (emit 'label `,label2)) |
---|
2520 | (emit-move-from-stack target)) |
---|
2521 | (t |
---|
2522 | ;; (dformat t "p2-eql case 3~%") |
---|
2523 | (compile-form arg1 :target :stack) |
---|
2524 | (compile-form arg2 :target :stack) |
---|
2525 | (unless (and (single-valued-p arg1) |
---|
2526 | (single-valued-p arg2)) |
---|
2527 | (emit-clear-values)) |
---|
2528 | (emit-invokevirtual +lisp-object-class+ |
---|
2529 | "EQL" |
---|
2530 | "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" |
---|
2531 | -1) |
---|
2532 | (emit-move-from-stack target)))) |
---|
2533 | ) |
---|
2534 | |
---|
2535 | (defun compile-function-call-3 (op args target) |
---|
2536 | (case op |
---|
2537 | (LIST |
---|
2538 | (compile-form (first args) :target :stack) |
---|
2539 | (compile-form (second args) :target :stack) |
---|
2540 | (compile-form (third args) :target :stack) |
---|
2541 | (unless (every 'single-valued-p args) |
---|
2542 | (emit-clear-values)) |
---|
2543 | (emit-invokestatic +lisp-class+ |
---|
2544 | "list3" |
---|
2545 | "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/Cons;" |
---|
2546 | -2) |
---|
2547 | (emit-move-from-stack target) |
---|
2548 | t) |
---|
2549 | (SYS::%STRUCTURE-SET |
---|
2550 | (when (fixnump (second args)) |
---|
2551 | (compile-form (first args) :target :stack) |
---|
2552 | (maybe-emit-clear-values (first args)) |
---|
2553 | (emit 'sipush (second args)) |
---|
2554 | (compile-form (third args) :target :stack) |
---|
2555 | (maybe-emit-clear-values (third args)) |
---|
2556 | (emit-invokevirtual +lisp-object-class+ |
---|
2557 | "setSlotValue" |
---|
2558 | "(ILorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" |
---|
2559 | -2) |
---|
2560 | (emit-move-from-stack target) |
---|
2561 | t)) |
---|
2562 | (t |
---|
2563 | nil))) |
---|
2564 | |
---|
2565 | (defvar *toplevel-defuns* nil) |
---|
2566 | |
---|
2567 | (defsubst notinline-p (name) |
---|
2568 | (declare (optimize speed)) |
---|
2569 | (eq (get name '%inline) 'NOTINLINE)) |
---|
2570 | |
---|
2571 | (defun inline-ok (name) |
---|
2572 | (declare (optimize speed)) |
---|
2573 | (cond ((notinline-p name) |
---|
2574 | nil) |
---|
2575 | ((sys:built-in-function-p name) |
---|
2576 | t) |
---|
2577 | ((memq name *toplevel-defuns*) |
---|
2578 | t) |
---|
2579 | (t |
---|
2580 | nil))) |
---|
2581 | |
---|
2582 | (defun unsafe-p (args) |
---|
2583 | (cond ((node-p args) |
---|
2584 | (unsafe-p (node-form args))) |
---|
2585 | ((atom args) |
---|
2586 | nil) |
---|
2587 | (t |
---|
2588 | (case (car args) |
---|
2589 | (QUOTE |
---|
2590 | nil) |
---|
2591 | (LAMBDA |
---|
2592 | nil) |
---|
2593 | ((RETURN-FROM GO CATCH THROW UNWIND-PROTECT BLOCK) |
---|
2594 | t) |
---|
2595 | (t |
---|
2596 | (dolist (arg args) |
---|
2597 | (when (unsafe-p arg) |
---|
2598 | (return t)))))))) |
---|
2599 | |
---|
2600 | (defun rewrite-function-call (form) |
---|
2601 | (let ((args (cdr form))) |
---|
2602 | (if (unsafe-p args) |
---|
2603 | (let ((syms ()) |
---|
2604 | (lets ())) |
---|
2605 | ;; Preserve the order of evaluation of the arguments! |
---|
2606 | (dolist (arg args) |
---|
2607 | (if (constantp arg) |
---|
2608 | (push arg syms) |
---|
2609 | (let ((sym (gensym))) |
---|
2610 | (push sym syms) |
---|
2611 | (push (list sym arg) lets)))) |
---|
2612 | (list 'LET* (nreverse lets) (list* (car form) (nreverse syms)))) |
---|
2613 | form))) |
---|
2614 | |
---|
2615 | (defun process-args (args) |
---|
2616 | (let ((numargs (length args))) |
---|
2617 | (when (plusp numargs) |
---|
2618 | (let ((must-clear-values nil)) |
---|
2619 | (cond ((<= numargs 4) |
---|
2620 | (dolist (arg args) |
---|
2621 | (compile-form arg :target :stack) |
---|
2622 | (unless must-clear-values |
---|
2623 | (unless (single-valued-p arg) |
---|
2624 | (setf must-clear-values t))))) |
---|
2625 | (t |
---|
2626 | (emit 'sipush numargs) |
---|
2627 | (emit 'anewarray "org/armedbear/lisp/LispObject") |
---|
2628 | (let ((i 0)) |
---|
2629 | (dolist (arg args) |
---|
2630 | (emit 'dup) |
---|
2631 | (emit 'sipush i) |
---|
2632 | (compile-form arg :target :stack) |
---|
2633 | (emit 'aastore) ; store value in array |
---|
2634 | (unless must-clear-values |
---|
2635 | (unless (single-valued-p arg) |
---|
2636 | (setf must-clear-values t))) |
---|
2637 | (incf i))))) |
---|
2638 | (when must-clear-values |
---|
2639 | (emit-clear-values)))))) |
---|
2640 | |
---|
2641 | (defun emit-call-execute (numargs) |
---|
2642 | (let ((descriptor |
---|
2643 | (case numargs |
---|
2644 | (0 "()Lorg/armedbear/lisp/LispObject;") |
---|
2645 | (1 "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;") |
---|
2646 | (2 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;") |
---|
2647 | (3 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;") |
---|
2648 | (4 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;") |
---|
2649 | (t "([Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"))) |
---|
2650 | (stack-effect (if (< numargs 5) |
---|
2651 | (- numargs) |
---|
2652 | -1))) |
---|
2653 | (emit-invokevirtual +lisp-object-class+ "execute" descriptor stack-effect))) |
---|
2654 | |
---|
2655 | (defun emit-call-thread-execute (numargs) |
---|
2656 | (let ((descriptor |
---|
2657 | (case numargs |
---|
2658 | (0 "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;") |
---|
2659 | (1 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;") |
---|
2660 | (2 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;") |
---|
2661 | (3 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;") |
---|
2662 | (4 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;") |
---|
2663 | (t "(Lorg/armedbear/lisp/LispObject;[Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"))) |
---|
2664 | (stack-effect (if (< numargs 5) |
---|
2665 | (- (1+ numargs)) |
---|
2666 | -2))) |
---|
2667 | (emit-invokevirtual +lisp-thread-class+ "execute" descriptor stack-effect))) |
---|
2668 | |
---|
2669 | (defun compile-function-call (form target representation) |
---|
2670 | (let ((op (car form)) |
---|
2671 | (args (cdr form))) |
---|
2672 | (unless (symbolp op) |
---|
2673 | (error "COMPILE-FUNCTION-CALL ~S is not a symbol" op)) |
---|
2674 | (when (find-local-function op) |
---|
2675 | (return-from compile-function-call (compile-local-function-call form target))) |
---|
2676 | (let ((numargs (length args))) |
---|
2677 | (case (length args) |
---|
2678 | (1 |
---|
2679 | (when (compile-function-call-1 op args target representation) |
---|
2680 | (return-from compile-function-call))) |
---|
2681 | (2 |
---|
2682 | (when (compile-function-call-2 op args target representation) |
---|
2683 | (return-from compile-function-call))) |
---|
2684 | (3 |
---|
2685 | (when (compile-function-call-3 op args target) |
---|
2686 | (return-from compile-function-call)))) |
---|
2687 | (unless (> *speed* *debug*) |
---|
2688 | (emit-push-current-thread)) |
---|
2689 | (cond |
---|
2690 | ((eq op (compiland-name *current-compiland*)) ; recursive call |
---|
2691 | (emit 'aload 0)) ; this |
---|
2692 | ((inline-ok op) |
---|
2693 | (emit 'getstatic |
---|
2694 | *this-class* |
---|
2695 | (declare-function op) |
---|
2696 | +lisp-object+)) |
---|
2697 | ((null (symbol-package op)) |
---|
2698 | (let ((g (if *compile-file-truename* |
---|
2699 | (declare-object-as-string op) |
---|
2700 | (declare-object op)))) |
---|
2701 | (emit 'getstatic |
---|
2702 | *this-class* |
---|
2703 | g |
---|
2704 | +lisp-object+))) |
---|
2705 | (t |
---|
2706 | (emit 'getstatic |
---|
2707 | *this-class* |
---|
2708 | (declare-symbol op) |
---|
2709 | +lisp-symbol+))) |
---|
2710 | (process-args args) |
---|
2711 | (if (> *speed* *debug*) |
---|
2712 | (emit-call-execute numargs) |
---|
2713 | (emit-call-thread-execute numargs)) |
---|
2714 | (when (eq representation :unboxed-fixnum) |
---|
2715 | (emit-unbox-fixnum)) |
---|
2716 | (emit-move-from-stack target)))) |
---|
2717 | |
---|
2718 | (defun compile-call (args) |
---|
2719 | (let ((numargs (length args))) |
---|
2720 | (cond ((> *speed* *debug*) |
---|
2721 | (process-args args) |
---|
2722 | (emit-call-execute numargs)) |
---|
2723 | (t |
---|
2724 | (emit-push-current-thread) |
---|
2725 | (emit 'swap) ; Stack: thread function |
---|
2726 | (process-args args) |
---|
2727 | (emit-call-thread-execute numargs))))) |
---|
2728 | |
---|
2729 | (define-source-transform funcall (&whole form fun &rest args) |
---|
2730 | (cond ((> *debug* *speed*) |
---|
2731 | form) |
---|
2732 | ((and (consp fun) |
---|
2733 | (eq (car fun) 'FUNCTION) |
---|
2734 | (symbolp (cadr fun))) |
---|
2735 | `(,(cadr fun) ,@args)) |
---|
2736 | ((and (consp fun) |
---|
2737 | (eq (car fun) 'QUOTE)) |
---|
2738 | (let ((sym (cadr fun))) |
---|
2739 | (if (and (symbolp sym) |
---|
2740 | (eq (symbol-package sym) (find-package "CL")) |
---|
2741 | (not (special-operator-p sym)) |
---|
2742 | (not (macro-function sym))) |
---|
2743 | `(,(cadr fun) ,@args) |
---|
2744 | form))) |
---|
2745 | (t |
---|
2746 | form))) |
---|
2747 | |
---|
2748 | (defun compile-funcall (form &key (target *val*) representation) |
---|
2749 | (unless (> (length form) 1) |
---|
2750 | (compiler-style-warn "Wrong number of arguments for ~A." (car form)) |
---|
2751 | (compile-function-call form target representation)) |
---|
2752 | (when (> *debug* *speed*) |
---|
2753 | (return-from compile-funcall (compile-function-call form target representation))) |
---|
2754 | (compile-form (cadr form) :target :stack) |
---|
2755 | (maybe-emit-clear-values (cadr form)) |
---|
2756 | (compile-call (cddr form)) |
---|
2757 | (emit-move-from-stack target)) |
---|
2758 | |
---|
2759 | (defun compile-local-function-call (form target) |
---|
2760 | (dformat t "compile-local-function-call~%") |
---|
2761 | (let* ((op (car form)) |
---|
2762 | (args (cdr form)) |
---|
2763 | (local-function (find-local-function op))) |
---|
2764 | (cond |
---|
2765 | ((eq (local-function-compiland local-function) *current-compiland*) |
---|
2766 | (emit 'aload_0)) |
---|
2767 | ((local-function-variable local-function) |
---|
2768 | ;; LABELS |
---|
2769 | (dformat t "compile-local-function-call LABELS case~%") |
---|
2770 | (emit 'var-ref (local-function-variable local-function) :stack)) |
---|
2771 | (t |
---|
2772 | (let* ((g (if *compile-file-truename* |
---|
2773 | (declare-local-function local-function) |
---|
2774 | (declare-object (local-function-function local-function))))) |
---|
2775 | (emit 'getstatic |
---|
2776 | *this-class* |
---|
2777 | g |
---|
2778 | +lisp-object+)))) ; Stack: template-function |
---|
2779 | |
---|
2780 | (when *closure-variables* |
---|
2781 | (emit 'checkcast +lisp-ctf-class+)) |
---|
2782 | |
---|
2783 | (when *closure-variables* |
---|
2784 | ;; First arg is closure variable array. |
---|
2785 | (aver (not (null (compiland-closure-register *current-compiland*)))) |
---|
2786 | (emit 'aload (compiland-closure-register *current-compiland*))) |
---|
2787 | (cond |
---|
2788 | ((> (length args) 4) |
---|
2789 | (emit-push-constant-int (length args)) |
---|
2790 | (emit 'anewarray "org/armedbear/lisp/LispObject") |
---|
2791 | (let ((i 0) |
---|
2792 | (must-clear-values nil)) |
---|
2793 | (dolist (arg args) |
---|
2794 | (emit 'dup) |
---|
2795 | (emit 'sipush i) |
---|
2796 | (compile-form arg :target :stack) |
---|
2797 | (emit 'aastore) ; store value in array |
---|
2798 | (unless must-clear-values |
---|
2799 | (unless (single-valued-p arg) |
---|
2800 | (setf must-clear-values t))) |
---|
2801 | (incf i)) |
---|
2802 | (when must-clear-values |
---|
2803 | (emit-clear-values)))) ; array left on stack here |
---|
2804 | (t |
---|
2805 | (let ((must-clear-values nil)) |
---|
2806 | (dolist (arg args) |
---|
2807 | (compile-form arg :target :stack) |
---|
2808 | (unless must-clear-values |
---|
2809 | (unless (single-valued-p arg) |
---|
2810 | (setf must-clear-values t)))) |
---|
2811 | (when must-clear-values |
---|
2812 | (emit-clear-values))))) ; args left on stack here |
---|
2813 | |
---|
2814 | (if *closure-variables* |
---|
2815 | (case (length args) |
---|
2816 | (0 |
---|
2817 | (emit-invokevirtual +lisp-ctf-class+ |
---|
2818 | "execute" |
---|
2819 | "([Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" |
---|
2820 | -1)) |
---|
2821 | (1 |
---|
2822 | (emit-invokevirtual +lisp-ctf-class+ |
---|
2823 | "execute" |
---|
2824 | "([Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" |
---|
2825 | -2)) |
---|
2826 | (2 |
---|
2827 | (emit-invokevirtual +lisp-ctf-class+ |
---|
2828 | "execute" |
---|
2829 | "([Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" |
---|
2830 | -3)) |
---|
2831 | (3 |
---|
2832 | (emit-invokevirtual +lisp-ctf-class+ |
---|
2833 | "execute" |
---|
2834 | "([Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" |
---|
2835 | -4)) |
---|
2836 | (4 |
---|
2837 | (emit-invokevirtual +lisp-ctf-class+ |
---|
2838 | "execute" |
---|
2839 | "([Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" |
---|
2840 | -5)) |
---|
2841 | (t |
---|
2842 | (emit-invokevirtual +lisp-ctf-class+ |
---|
2843 | "execute" |
---|
2844 | "([Lorg/armedbear/lisp/LispObject;[Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" |
---|
2845 | -2))) |
---|
2846 | ;; No closure variables. |
---|
2847 | (case (length args) |
---|
2848 | (0 |
---|
2849 | (emit-invokevirtual +lisp-object-class+ |
---|
2850 | "execute" |
---|
2851 | "()Lorg/armedbear/lisp/LispObject;" |
---|
2852 | 0)) |
---|
2853 | (1 |
---|
2854 | (emit-invokevirtual +lisp-object-class+ |
---|
2855 | "execute" |
---|
2856 | "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" |
---|
2857 | -1)) |
---|
2858 | (2 |
---|
2859 | (emit-invokevirtual +lisp-object-class+ |
---|
2860 | "execute" |
---|
2861 | "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" |
---|
2862 | -2)) |
---|
2863 | (3 |
---|
2864 | (emit-invokevirtual +lisp-object-class+ |
---|
2865 | "execute" |
---|
2866 | "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" |
---|
2867 | -3)) |
---|
2868 | (4 |
---|
2869 | (emit-invokevirtual +lisp-object-class+ |
---|
2870 | "execute" |
---|
2871 | "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" |
---|
2872 | -4)) |
---|
2873 | (t |
---|
2874 | (emit-invokevirtual +lisp-object-class+ |
---|
2875 | "execute" |
---|
2876 | "([Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" |
---|
2877 | -1)))) |
---|
2878 | (cond ((null target) |
---|
2879 | (emit 'pop) |
---|
2880 | (maybe-emit-clear-values form)) |
---|
2881 | ((eq target :stack)) |
---|
2882 | ((fixnump target) |
---|
2883 | (emit 'astore target)) |
---|
2884 | (t |
---|
2885 | (%format t "line 1876~%") |
---|
2886 | (aver nil))))) |
---|
2887 | |
---|
2888 | (defparameter java-predicates (make-hash-table :test 'eq)) |
---|
2889 | |
---|
2890 | (defun define-java-predicate (predicate translation) |
---|
2891 | (setf (gethash predicate java-predicates) translation)) |
---|
2892 | |
---|
2893 | (define-java-predicate 'CHARACTERP "characterp") |
---|
2894 | (define-java-predicate 'CONSTANTP "constantp") |
---|
2895 | (define-java-predicate 'ENDP "endp") |
---|
2896 | (define-java-predicate 'EVENP "evenp") |
---|
2897 | (define-java-predicate 'FLOATP "floatp") |
---|
2898 | (define-java-predicate 'INTEGERP "integerp") |
---|
2899 | (define-java-predicate 'LISTP "listp") |
---|
2900 | (define-java-predicate 'MINUSP "minusp") |
---|
2901 | (define-java-predicate 'NUMBERP "numberp") |
---|
2902 | (define-java-predicate 'ODDP "oddp") |
---|
2903 | (define-java-predicate 'PLUSP "plusp") |
---|
2904 | (define-java-predicate 'RATIONALP "rationalp") |
---|
2905 | (define-java-predicate 'REALP "realp") |
---|
2906 | (define-java-predicate 'STRINGP "stringp") |
---|
2907 | (define-java-predicate 'SPECIAL-VARIABLE-P "isSpecialVariable") |
---|
2908 | (define-java-predicate 'VECTORP "vectorp") |
---|
2909 | (define-java-predicate 'ZEROP "zerop") |
---|
2910 | |
---|
2911 | (defun compile-test-2 (form negatep) |
---|
2912 | (let* ((op (car form)) |
---|
2913 | (args (cdr form)) |
---|
2914 | (arg (car args)) |
---|
2915 | variable) |
---|
2916 | (when (memq op '(NOT NULL)) |
---|
2917 | (return-from compile-test-2 (compile-test arg (not negatep)))) |
---|
2918 | (when (setf variable (unboxed-fixnum-variable arg)) |
---|
2919 | (case op |
---|
2920 | (MINUSP |
---|
2921 | (dformat t "compile-test-2 minusp case~%") |
---|
2922 | (aver (variable-register variable)) |
---|
2923 | (emit 'iload (variable-register variable)) |
---|
2924 | (return-from compile-test-2 (if negatep 'iflt 'ifge)) |
---|
2925 | ) |
---|
2926 | )) |
---|
2927 | (when (eq op 'SYMBOLP) |
---|
2928 | (process-args args) |
---|
2929 | (emit 'instanceof +lisp-symbol-class+) |
---|
2930 | (return-from compile-test-2 (if negatep 'ifne 'ifeq))) |
---|
2931 | (when (eq op 'FIXNUMP) |
---|
2932 | (process-args args) |
---|
2933 | (emit 'instanceof +lisp-fixnum-class+) |
---|
2934 | (return-from compile-test-2 (if negatep 'ifne 'ifeq))) |
---|
2935 | (when (eq op 'CONSP) |
---|
2936 | (process-args args) |
---|
2937 | (emit 'instanceof +lisp-cons-class+) |
---|
2938 | (return-from compile-test-2 (if negatep 'ifne 'ifeq))) |
---|
2939 | (when (eq op 'ATOM) |
---|
2940 | (process-args args) |
---|
2941 | (emit 'instanceof +lisp-cons-class+) |
---|
2942 | (return-from compile-test-2 (if negatep 'ifeq 'ifne))) |
---|
2943 | (let ((s (gethash op java-predicates))) |
---|
2944 | (when s |
---|
2945 | (process-args args) |
---|
2946 | (emit-invokevirtual +lisp-object-class+ |
---|
2947 | s |
---|
2948 | "()Z" |
---|
2949 | 0) |
---|
2950 | (return-from compile-test-2 (if negatep 'ifne 'ifeq))))) |
---|
2951 | ;; Otherwise... |
---|
2952 | (compile-form form :target :stack) |
---|
2953 | (maybe-emit-clear-values form) |
---|
2954 | (emit-push-nil) |
---|
2955 | (if negatep 'if_acmpne 'if_acmpeq)) |
---|
2956 | |
---|
2957 | (defun p2-numeric-comparison (form &key (target *val*) representation) |
---|
2958 | (let ((op (car form)) |
---|
2959 | (args (cdr form))) |
---|
2960 | (case (length args) |
---|
2961 | (2 |
---|
2962 | (let ((first (first args)) |
---|
2963 | (second (second args)) |
---|
2964 | var1 var2) |
---|
2965 | (cond |
---|
2966 | ((and (fixnump first) (fixnump second)) |
---|
2967 | (dformat t "p2-numeric-comparison form = ~S~%" form) |
---|
2968 | (if (funcall op first second) |
---|
2969 | (emit-push-t) |
---|
2970 | (emit-push-nil)) |
---|
2971 | (return-from p2-numeric-comparison)) |
---|
2972 | ((fixnump second) |
---|
2973 | (dformat t "p2-numeric-comparison form = ~S~%" form) |
---|
2974 | (compile-form (car args) :target :stack) |
---|
2975 | (unless (single-valued-p first) |
---|
2976 | (emit-clear-values)) |
---|
2977 | (emit-push-constant-int second) |
---|
2978 | (emit-invokevirtual +lisp-object-class+ |
---|
2979 | (case op |
---|
2980 | (< "isLessThan") |
---|
2981 | (<= "isLessThanOrEqualTo") |
---|
2982 | (> "isGreaterThan") |
---|
2983 | (>= "isGreaterThanOrEqualTo") |
---|
2984 | (= "isEqualTo") |
---|
2985 | (/= "isNotEqualTo")) |
---|
2986 | "(I)Z" |
---|
2987 | -1) |
---|
2988 | ;; Java boolean on stack here |
---|
2989 | (let ((LABEL1 (gensym)) |
---|
2990 | (LABEL2 (gensym))) |
---|
2991 | (emit 'ifeq LABEL1) |
---|
2992 | (emit-push-t) |
---|
2993 | (emit 'goto LABEL2) |
---|
2994 | (label LABEL1) |
---|
2995 | (emit-push-nil) |
---|
2996 | (label LABEL2) |
---|
2997 | (emit-move-from-stack target)) |
---|
2998 | (return-from p2-numeric-comparison)) |
---|
2999 | ((and (setf var1 (unboxed-fixnum-variable first)) |
---|
3000 | (setf var2 (unboxed-fixnum-variable second))) |
---|
3001 | (dformat t "p2-numeric-comparison both unboxed var case form = ~S~%" form) |
---|
3002 | (let ((LABEL1 (gensym)) |
---|
3003 | (LABEL2 (gensym))) |
---|
3004 | (emit 'iload (variable-register var1)) |
---|
3005 | (emit 'iload (variable-register var2)) |
---|
3006 | (emit (case op |
---|
3007 | (< 'if_icmpge) |
---|
3008 | (<= 'if_icmpgt) |
---|
3009 | (> 'if_icmple) |
---|
3010 | (>= 'if_icmplt) |
---|
3011 | (= 'if_icmpne) |
---|
3012 | (/= 'if_icmpeq)) |
---|
3013 | LABEL1) |
---|
3014 | (emit-push-t) |
---|
3015 | (emit 'goto LABEL2) |
---|
3016 | (label LABEL1) |
---|
3017 | (emit-push-nil) |
---|
3018 | (label LABEL2) |
---|
3019 | (emit-move-from-stack target) |
---|
3020 | (return-from p2-numeric-comparison)) |
---|
3021 | ) |
---|
3022 | ) ; cond |
---|
3023 | )))) |
---|
3024 | ;; Still here? |
---|
3025 | (compile-function-call form target representation) |
---|
3026 | ) |
---|
3027 | |
---|
3028 | (defun compile-test-3 (form negatep) |
---|
3029 | ;; (dformat t "compile-test-3 form = ~S~%" form) |
---|
3030 | (let ((op (car form)) |
---|
3031 | (args (cdr form))) |
---|
3032 | (when (eq op 'EQ) |
---|
3033 | (process-args args) |
---|
3034 | (return-from compile-test-3 (if negatep 'if_acmpeq 'if_acmpne))) |
---|
3035 | (let* ((arg1 (first args)) |
---|
3036 | (arg2 (second args)) |
---|
3037 | (var1 (unboxed-fixnum-variable arg1)) |
---|
3038 | (var2 (unboxed-fixnum-variable arg2))) |
---|
3039 | (when (memq op '(< <= > >= = /=)) |
---|
3040 | (when (and (arg-is-fixnum-p arg1) |
---|
3041 | (arg-is-fixnum-p arg2)) |
---|
3042 | (emit-push-int arg1) |
---|
3043 | (emit-push-int arg2) |
---|
3044 | (case op |
---|
3045 | (< |
---|
3046 | (return-from compile-test-3 (if negatep 'if_icmplt 'if_icmpge))) |
---|
3047 | (<= |
---|
3048 | (return-from compile-test-3 (if negatep 'if_icmple 'if_icmpgt))) |
---|
3049 | (> |
---|
3050 | (return-from compile-test-3 (if negatep 'if_icmpgt 'if_icmple))) |
---|
3051 | (>= |
---|
3052 | (return-from compile-test-3 (if negatep 'if_icmpge 'if_icmplt))) |
---|
3053 | (= |
---|
3054 | (return-from compile-test-3 (if negatep 'if_icmpeq 'if_icmpne))) |
---|
3055 | (/= |
---|
3056 | (return-from compile-test-3 (if negatep 'if_icmpne 'if_icmpeq))) |
---|
3057 | )) |
---|
3058 | |
---|
3059 | ;; Otherwise... |
---|
3060 | (when (arg-is-fixnum-p arg2) |
---|
3061 | (compile-form arg1 :target :stack) |
---|
3062 | (maybe-emit-clear-values arg1) |
---|
3063 | (emit-push-int arg2) |
---|
3064 | (emit-invokevirtual +lisp-object-class+ |
---|
3065 | (case op |
---|
3066 | (< "isLessThan") |
---|
3067 | (<= "isLessThanOrEqualTo") |
---|
3068 | (> "isGreaterThan") |
---|
3069 | (>= "isGreaterThanOrEqualTo") |
---|
3070 | (= "isEqualTo") |
---|
3071 | (/= "isNotEqualTo")) |
---|
3072 | "(I)Z" |
---|
3073 | -1) |
---|
3074 | (return-from compile-test-3 (if negatep 'ifne 'ifeq)))) |
---|
3075 | |
---|
3076 | (when (eq op '<) |
---|
3077 | (when var1 |
---|
3078 | (dformat t "compile-test-3 unboxed fixnum var1 comparison case~%") |
---|
3079 | (aver (variable-register var1)) |
---|
3080 | (emit 'iload (variable-register var1)) |
---|
3081 | (compile-form arg2 :target :stack) |
---|
3082 | (emit 'swap) |
---|
3083 | (emit-invokevirtual +lisp-object-class+ |
---|
3084 | "isGreaterThan" |
---|
3085 | "(I)Z" |
---|
3086 | -1) |
---|
3087 | (return-from compile-test-3 (if negatep 'ifne 'ifeq))))) |
---|
3088 | |
---|
3089 | (let ((s (cdr (assq op |
---|
3090 | '((= . "isEqualTo") |
---|
3091 | (/= . "isNotEqualTo") |
---|
3092 | (< . "isLessThan") |
---|
3093 | (<= . "isLessThanOrEqualTo") |
---|
3094 | (> . "isGreaterThan") |
---|
3095 | (>= . "isGreaterThanOrEqualTo") |
---|
3096 | (EQL . "eql") |
---|
3097 | (EQUAL . "equal") |
---|
3098 | (EQUALP . "equalp")))))) |
---|
3099 | (when s |
---|
3100 | (let ((first (first args)) |
---|
3101 | (second (second args)) |
---|
3102 | variable) |
---|
3103 | (cond |
---|
3104 | ((fixnump second) |
---|
3105 | (compile-form first :target :stack) |
---|
3106 | (maybe-emit-clear-values first) |
---|
3107 | (emit-push-constant-int second) |
---|
3108 | (emit-invokevirtual +lisp-object-class+ s "(I)Z" -1)) |
---|
3109 | ((setf variable (unboxed-fixnum-variable second)) |
---|
3110 | (compile-form first :target :stack) |
---|
3111 | (maybe-emit-clear-values first) |
---|
3112 | (aver (variable-register variable)) |
---|
3113 | (emit 'iload (variable-register variable)) |
---|
3114 | (emit-invokevirtual +lisp-object-class+ s "(I)Z" -1)) |
---|
3115 | (t |
---|
3116 | (process-args args) |
---|
3117 | (emit-invokevirtual +lisp-object-class+ |
---|
3118 | s |
---|
3119 | "(Lorg/armedbear/lisp/LispObject;)Z" |
---|
3120 | -1))) |
---|
3121 | (return-from compile-test-3 (if negatep 'ifne 'ifeq)))))) |
---|
3122 | |
---|
3123 | ;; Otherwise... |
---|
3124 | (compile-form form :target :stack) |
---|
3125 | (maybe-emit-clear-values form) |
---|
3126 | (emit-push-nil) |
---|
3127 | (if negatep 'if_acmpne 'if_acmpeq)) |
---|
3128 | |
---|
3129 | (defun compile-test (form negatep) |
---|
3130 | ;; Use a Java boolean if possible. |
---|
3131 | (when (and (consp form) |
---|
3132 | (not (special-operator-p (car form)))) |
---|
3133 | (case (length form) |
---|
3134 | (2 |
---|
3135 | (return-from compile-test (compile-test-2 form negatep))) |
---|
3136 | (3 |
---|
3137 | (return-from compile-test (compile-test-3 form negatep))))) |
---|
3138 | ;; Otherwise... |
---|
3139 | (compile-form form :target :stack) |
---|
3140 | (maybe-emit-clear-values form) |
---|
3141 | (emit-push-nil) |
---|
3142 | (if negatep 'if_acmpne 'if_acmpeq)) |
---|
3143 | |
---|
3144 | (defun compile-if (form &key (target *val*) representation) |
---|
3145 | ;; (dformat t "compile-if form = ~S~%" form) |
---|
3146 | (let* ((test (second form)) |
---|
3147 | (consequent (third form)) |
---|
3148 | (alternate (fourth form)) |
---|
3149 | (LABEL1 (gensym)) |
---|
3150 | (LABEL2 (gensym))) |
---|
3151 | (cond ((eq test t) |
---|
3152 | (compile-form consequent :target target :representation representation)) |
---|
3153 | ((null test) |
---|
3154 | (compile-form alternate :target target :representation representation)) |
---|
3155 | ((numberp test) |
---|
3156 | (compile-form consequent :target target :representation representation)) |
---|
3157 | (t |
---|
3158 | (emit (compile-test test nil) LABEL1) |
---|
3159 | (compile-form consequent :target target) |
---|
3160 | (emit 'goto LABEL2) |
---|
3161 | (label LABEL1) |
---|
3162 | (compile-form alternate :target target) |
---|
3163 | (label LABEL2))))) |
---|
3164 | |
---|
3165 | (defun compile-multiple-value-list (form &key (target *val*) representation) |
---|
3166 | ;; Added Dec 9 2004 7:52 PM |
---|
3167 | (emit-clear-values) |
---|
3168 | |
---|
3169 | (compile-form (second form) :target :stack) |
---|
3170 | (emit-invokestatic +lisp-class+ |
---|
3171 | "multipleValueList" |
---|
3172 | "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" |
---|
3173 | 0) |
---|
3174 | (emit-move-from-stack target)) |
---|
3175 | |
---|
3176 | (defun compile-multiple-value-prog1 (form &key (target *val*) representation) |
---|
3177 | (let ((first-subform (cadr form)) |
---|
3178 | (subforms (cddr form)) |
---|
3179 | (result-register (allocate-register)) |
---|
3180 | (values-register (allocate-register))) |
---|
3181 | |
---|
3182 | ;; Added Dec 9 2004 3:46 AM |
---|
3183 | ;; Make sure there are no leftover values from previous calls. |
---|
3184 | (emit-clear-values) |
---|
3185 | |
---|
3186 | (compile-form first-subform :target result-register) |
---|
3187 | ;; Save multiple values returned by first subform. |
---|
3188 | (emit-push-current-thread) |
---|
3189 | (emit 'getfield +lisp-thread-class+ "_values" "[Lorg/armedbear/lisp/LispObject;") |
---|
3190 | (emit 'astore values-register) |
---|
3191 | (dolist (subform subforms) |
---|
3192 | (compile-form subform :target nil)) |
---|
3193 | ;; Restore multiple values returned by first subform. |
---|
3194 | (emit-push-current-thread) |
---|
3195 | (emit 'aload values-register) |
---|
3196 | (emit 'putfield +lisp-thread-class+ "_values" "[Lorg/armedbear/lisp/LispObject;") |
---|
3197 | ;; Result. |
---|
3198 | (emit 'aload result-register) |
---|
3199 | (emit-move-from-stack target))) |
---|
3200 | |
---|
3201 | (defun compile-multiple-value-call (form &key (target *val*) representation) |
---|
3202 | (case (length form) |
---|
3203 | (1 |
---|
3204 | (error "Wrong number of arguments for MULTIPLE-VALUE-CALL.")) |
---|
3205 | (2 |
---|
3206 | (compile-form (second form) :target :stack) |
---|
3207 | (emit-invokestatic +lisp-class+ |
---|
3208 | "coerceToFunction" |
---|
3209 | "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" |
---|
3210 | 0) |
---|
3211 | (emit-invokevirtual +lisp-object-class+ |
---|
3212 | "execute" |
---|
3213 | "()Lorg/armedbear/lisp/LispObject;" |
---|
3214 | 0) |
---|
3215 | (emit-move-from-stack target)) |
---|
3216 | (3 |
---|
3217 | (let* ((*register* *register*) |
---|
3218 | (function-register (allocate-register))) |
---|
3219 | (compile-form (second form) :target function-register) |
---|
3220 | (compile-form (third form) :target :stack) |
---|
3221 | (emit 'aload function-register) |
---|
3222 | (emit-push-current-thread) |
---|
3223 | (emit-invokestatic +lisp-class+ |
---|
3224 | "multipleValueCall1" |
---|
3225 | "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispThread;)Lorg/armedbear/lisp/LispObject;" |
---|
3226 | -2) |
---|
3227 | (emit-move-from-stack target))) |
---|
3228 | (t |
---|
3229 | ;; The general case. |
---|
3230 | (let* ((*register* *register*) |
---|
3231 | (function-register (allocate-register)) |
---|
3232 | (values-register (allocate-register))) |
---|
3233 | (compile-form (second form) :target :stack) |
---|
3234 | (emit-invokestatic +lisp-class+ |
---|
3235 | "coerceToFunction" |
---|
3236 | "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" |
---|
3237 | 0) |
---|
3238 | (emit-move-from-stack function-register) |
---|
3239 | (emit 'aconst_null) |
---|
3240 | (emit 'astore values-register) |
---|
3241 | (dolist (values-form (cddr form)) |
---|
3242 | (compile-form values-form :target :stack) |
---|
3243 | (emit-push-current-thread) |
---|
3244 | (emit 'swap) |
---|
3245 | (emit 'aload values-register) |
---|
3246 | (emit-invokevirtual +lisp-thread-class+ |
---|
3247 | "accumulateValues" |
---|
3248 | "(Lorg/armedbear/lisp/LispObject;[Lorg/armedbear/lisp/LispObject;)[Lorg/armedbear/lisp/LispObject;" |
---|
3249 | -2) |
---|
3250 | (emit 'astore values-register) |
---|
3251 | (maybe-emit-clear-values values-form)) |
---|
3252 | (emit 'aload function-register) |
---|
3253 | (emit 'aload values-register) |
---|
3254 | (emit-invokevirtual +lisp-object-class+ |
---|
3255 | "execute" |
---|
3256 | "([Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" |
---|
3257 | -1) |
---|
3258 | (emit-move-from-stack target))))) |
---|
3259 | |
---|
3260 | ;; Generates code to bind variable to value at top of runtime stack. |
---|
3261 | (defun compile-binding (variable) |
---|
3262 | (cond ((variable-register variable) |
---|
3263 | (emit 'astore (variable-register variable))) |
---|
3264 | ((variable-special-p variable) |
---|
3265 | (emit-push-current-thread) |
---|
3266 | (emit 'swap) |
---|
3267 | (emit 'getstatic |
---|
3268 | *this-class* |
---|
3269 | (declare-symbol (variable-name variable)) |
---|
3270 | +lisp-symbol+) |
---|
3271 | (emit 'swap) |
---|
3272 | (emit-invokevirtual +lisp-thread-class+ |
---|
3273 | "bindSpecial" |
---|
3274 | "(Lorg/armedbear/lisp/Symbol;Lorg/armedbear/lisp/LispObject;)V" |
---|
3275 | -3)) |
---|
3276 | ((variable-closure-index variable) |
---|
3277 | (emit 'aload (compiland-closure-register *current-compiland*)) |
---|
3278 | (emit 'swap) ; array value |
---|
3279 | (emit-push-constant-int (variable-closure-index variable)) |
---|
3280 | (emit 'swap) ; array index value |
---|
3281 | (emit 'aastore)) |
---|
3282 | (t |
---|
3283 | (aver nil)))) |
---|
3284 | |
---|
3285 | (defun p2-m-v-b-node (block target) |
---|
3286 | (let* ((*blocks* (cons block *blocks*)) |
---|
3287 | (*register* *register*) |
---|
3288 | (form (block-form block)) |
---|
3289 | (*visible-variables* *visible-variables*) |
---|
3290 | (specials ()) |
---|
3291 | (vars (second form)) |
---|
3292 | (bind-special-p nil) |
---|
3293 | (variables (block-vars block))) |
---|
3294 | (dolist (variable variables) |
---|
3295 | (let ((special-p (variable-special-p variable))) |
---|
3296 | (cond (special-p |
---|
3297 | (setf bind-special-p t)) |
---|
3298 | (t |
---|
3299 | ;; (setf (variable-index variable) (length (context-vars *context*))) |
---|
3300 | (unless (variable-closure-index variable) |
---|
3301 | (setf (variable-register variable) (allocate-register))) |
---|
3302 | ;; (add-variable-to-context variable) |
---|
3303 | )))) |
---|
3304 | ;; If we're going to bind any special variables... |
---|
3305 | (when bind-special-p |
---|
3306 | ;; Save current dynamic environment. |
---|
3307 | (setf (block-environment-register block) (allocate-register)) |
---|
3308 | (emit-push-current-thread) |
---|
3309 | (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" +lisp-binding+) |
---|
3310 | (emit 'astore (block-environment-register block))) |
---|
3311 | |
---|
3312 | ;; Added Dec 9 2004 3:46 AM |
---|
3313 | ;; Make sure there are no leftover values from previous calls. |
---|
3314 | (emit-clear-values) |
---|
3315 | |
---|
3316 | ;; Bind the variables. |
---|
3317 | (aver (= (length vars) (length variables))) |
---|
3318 | (cond ((= (length vars) 1) |
---|
3319 | (compile-form (third form) :target :stack) |
---|
3320 | (maybe-emit-clear-values (third form)) |
---|
3321 | (compile-binding (car variables))) |
---|
3322 | (t |
---|
3323 | (let* ((*register* *register*) |
---|
3324 | (result-register (allocate-register)) |
---|
3325 | (values-register (allocate-register)) |
---|
3326 | (LABEL1 (gensym)) |
---|
3327 | (LABEL2 (gensym))) |
---|
3328 | ;; Store primary value from values form in result register. |
---|
3329 | (compile-form (third form) :target result-register) |
---|
3330 | ;; Store values from values form in values register. |
---|
3331 | (emit-push-current-thread) |
---|
3332 | (emit 'getfield +lisp-thread-class+ "_values" "[Lorg/armedbear/lisp/LispObject;") |
---|
3333 | (emit-move-from-stack values-register) |
---|
3334 | ;; Did we get just one value? |
---|
3335 | (emit 'aload values-register) |
---|
3336 | (emit 'ifnull LABEL1) |
---|
3337 | ;; Reaching here, we have multiple values (or no values at all). We need |
---|
3338 | ;; the slow path if we have more variables than values. |
---|
3339 | (emit 'aload values-register) |
---|
3340 | (emit 'arraylength) |
---|
3341 | (emit 'bipush (length vars)) |
---|
3342 | (emit 'if_icmplt LABEL1) |
---|
3343 | ;; Reaching here, we have enough values for all the variables. We can use |
---|
3344 | ;; the values we have. This is the fast path. |
---|
3345 | (emit 'aload values-register) |
---|
3346 | (emit 'goto LABEL2) |
---|
3347 | (label LABEL1) |
---|
3348 | (emit-push-current-thread) |
---|
3349 | (emit 'aload result-register) |
---|
3350 | (emit 'bipush (length vars)) |
---|
3351 | (emit-invokevirtual +lisp-thread-class+ |
---|
3352 | "getValues" |
---|
3353 | "(Lorg/armedbear/lisp/LispObject;I)[Lorg/armedbear/lisp/LispObject;" |
---|
3354 | -2) |
---|
3355 | ;; Values array is now on the stack at runtime. |
---|
3356 | (label LABEL2) |
---|
3357 | (let ((index 0)) |
---|
3358 | (dolist (variable variables) |
---|
3359 | (when (< index (1- (length vars))) |
---|
3360 | (emit 'dup)) |
---|
3361 | (emit 'bipush index) |
---|
3362 | (incf index) |
---|
3363 | (emit 'aaload) |
---|
3364 | ;; Value is on the runtime stack at this point. |
---|
3365 | (compile-binding variable))) |
---|
3366 | (maybe-emit-clear-values (third form))))) |
---|
3367 | ;; Make the variables visible for the body forms. |
---|
3368 | (dolist (variable variables) |
---|
3369 | (push variable *visible-variables*) |
---|
3370 | ;; (push variable *all-variables*) |
---|
3371 | ) |
---|
3372 | ;; Body. |
---|
3373 | (compile-progn-body (cdddr form) target) |
---|
3374 | (when bind-special-p |
---|
3375 | ;; Restore dynamic environment. |
---|
3376 | (emit 'aload *thread*) |
---|
3377 | (emit 'aload (block-environment-register block)) |
---|
3378 | (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" +lisp-binding+)))) |
---|
3379 | |
---|
3380 | (defun p2-let/let*-node (block target) |
---|
3381 | (let* ((*blocks* (cons block *blocks*)) |
---|
3382 | (*register* *register*) |
---|
3383 | (form (block-form block)) |
---|
3384 | (*visible-variables* *visible-variables*) |
---|
3385 | (specialp nil)) |
---|
3386 | ;; Are we going to bind any special variables? |
---|
3387 | (dolist (variable (block-vars block)) |
---|
3388 | (when (variable-special-p variable) |
---|
3389 | (setf specialp t) |
---|
3390 | (return))) |
---|
3391 | ;; If so... |
---|
3392 | (when specialp |
---|
3393 | ;; Save current dynamic environment. |
---|
3394 | (setf (block-environment-register block) (allocate-register)) |
---|
3395 | (emit-push-current-thread) |
---|
3396 | (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" +lisp-binding+) |
---|
3397 | (emit 'astore (block-environment-register block))) |
---|
3398 | (ecase (car form) |
---|
3399 | (LET |
---|
3400 | (p2-let-bindings block)) |
---|
3401 | (LET* |
---|
3402 | (p2-let*-bindings block))) |
---|
3403 | ;; Make declarations of free specials visible. |
---|
3404 | (dolist (variable (block-free-specials block)) |
---|
3405 | (push variable *visible-variables*)) |
---|
3406 | ;; Body of LET/LET*. |
---|
3407 | (compile-progn-body (cddr form) target) |
---|
3408 | (when specialp |
---|
3409 | ;; Restore dynamic environment. |
---|
3410 | (emit 'aload *thread*) |
---|
3411 | (emit 'aload (block-environment-register block)) |
---|
3412 | (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" +lisp-binding+)))) |
---|
3413 | |
---|
3414 | (defun p2-let-bindings (block) |
---|
3415 | (dolist (variable (block-vars block)) |
---|
3416 | (unless (variable-special-p variable) |
---|
3417 | (unless (variable-closure-index variable) |
---|
3418 | (setf (variable-register variable) (allocate-register))))) |
---|
3419 | (let ((*register* *register*) |
---|
3420 | (must-clear-values nil)) |
---|
3421 | ;; Evaluate each initform. If the variable being bound is special, allocate |
---|
3422 | ;; a temporary register for the result; LET bindings must be done in |
---|
3423 | ;; parallel, so we can't modify any specials until all the initforms have |
---|
3424 | ;; been evaluated. Note that we can't just push the values on the stack |
---|
3425 | ;; because we'll lose JVM stack consistency if there is a non-local |
---|
3426 | ;; transfer of control from one of the initforms. |
---|
3427 | (dolist (variable (block-vars block)) |
---|
3428 | (dformat t "variable = ~S writes = ~S~%" (variable-name variable) (variable-writes variable)) |
---|
3429 | (let ((initform (variable-initform variable))) |
---|
3430 | (cond (initform |
---|
3431 | (cond |
---|
3432 | ((and *trust-user-type-declarations* |
---|
3433 | (variable-register variable) |
---|
3434 | (variable-declared-type variable) |
---|
3435 | (subtypep (variable-declared-type variable) 'FIXNUM)) |
---|
3436 | (dformat t "p2-let-bindings declared fixnum case: ~S~%" |
---|
3437 | (variable-name variable)) |
---|
3438 | (setf (variable-representation variable) :unboxed-fixnum) |
---|
3439 | (compile-form initform :target :stack :representation :unboxed-fixnum)) |
---|
3440 | ((and (variable-register variable) |
---|
3441 | (eql (variable-writes variable) 0) |
---|
3442 | (subtypep (derive-type initform) 'FIXNUM)) |
---|
3443 | (dformat t "p2-let-bindings read-only fixnum case: ~S~%" |
---|
3444 | (variable-name variable)) |
---|
3445 | (setf (variable-representation variable) :unboxed-fixnum) |
---|
3446 | (compile-form initform :target :stack :representation :unboxed-fixnum)) |
---|
3447 | (t |
---|
3448 | (compile-form initform :target :stack))) |
---|
3449 | (unless must-clear-values |
---|
3450 | (unless (single-valued-p initform) |
---|
3451 | (setf must-clear-values t)))) |
---|
3452 | (t |
---|
3453 | (emit-push-nil))) |
---|
3454 | (cond |
---|
3455 | ((variable-special-p variable) |
---|
3456 | (emit-move-from-stack (setf (variable-temp-register variable) (allocate-register)))) |
---|
3457 | ((eq (variable-representation variable) :unboxed-fixnum) |
---|
3458 | (emit 'istore (variable-register variable))) |
---|
3459 | (t |
---|
3460 | (compile-binding variable))))) |
---|
3461 | (when must-clear-values |
---|
3462 | (emit-clear-values)) |
---|
3463 | ;; Now that all the initforms have been evaluated, move the results from |
---|
3464 | ;; the temporary registers (if any) to their proper destinations. |
---|
3465 | (dolist (variable (block-vars block)) |
---|
3466 | (when (variable-temp-register variable) |
---|
3467 | (aver (variable-special-p variable)) |
---|
3468 | (emit 'aload (variable-temp-register variable)) |
---|
3469 | (compile-binding variable)))) |
---|
3470 | ;; Now make the variables visible. |
---|
3471 | (dolist (variable (block-vars block)) |
---|
3472 | (push variable *visible-variables*))) |
---|
3473 | |
---|
3474 | (defun p2-let*-bindings (block) |
---|
3475 | (let ((must-clear-values nil)) |
---|
3476 | ;; Generate code to evaluate initforms and bind variables. |
---|
3477 | (dolist (variable (block-vars block)) |
---|
3478 | (let* ((initform (variable-initform variable)) |
---|
3479 | (boundp nil)) |
---|
3480 | (cond |
---|
3481 | ((and (variable-special-p variable) |
---|
3482 | (eq initform (variable-name variable))) |
---|
3483 | (emit-push-current-thread) |
---|
3484 | (emit 'getstatic |
---|
3485 | *this-class* |
---|
3486 | (declare-symbol (variable-name variable)) |
---|
3487 | +lisp-symbol+) |
---|
3488 | (emit-invokevirtual +lisp-thread-class+ |
---|
3489 | "bindSpecialToCurrentValue" |
---|
3490 | "(Lorg/armedbear/lisp/Symbol;)V" |
---|
3491 | -2) |
---|
3492 | (setf boundp t)) |
---|
3493 | (initform |
---|
3494 | (cond |
---|
3495 | ((and *trust-user-type-declarations* |
---|
3496 | ;; (not *use-locals-vector*) |
---|
3497 | (null (variable-closure-index variable)) |
---|
3498 | (not (variable-special-p variable)) |
---|
3499 | (variable-declared-type variable) |
---|
3500 | (subtypep (variable-declared-type variable) 'FIXNUM)) |
---|
3501 | (dformat t "p2-let*-bindings declared fixnum case~%") |
---|
3502 | (setf (variable-representation variable) :unboxed-fixnum) |
---|
3503 | (compile-form initform :target :stack :representation :unboxed-fixnum) |
---|
3504 | (setf (variable-register variable) (allocate-register)) |
---|
3505 | (emit 'istore (variable-register variable)) |
---|
3506 | (setf boundp t)) |
---|
3507 | ((and ;;(not *use-locals-vector*) |
---|
3508 | (null (variable-closure-index variable)) |
---|
3509 | (not (variable-special-p variable)) |
---|
3510 | (eql (variable-writes variable) 0) |
---|
3511 | (subtypep (derive-type initform) 'FIXNUM)) |
---|
3512 | (dformat t "p2-let*-bindings read-only fixnum case: ~S~%" |
---|
3513 | (variable-name variable)) |
---|
3514 | (setf (variable-representation variable) :unboxed-fixnum) |
---|
3515 | (compile-form initform :target :stack :representation :unboxed-fixnum) |
---|
3516 | (setf (variable-register variable) (allocate-register)) |
---|
3517 | (emit 'istore (variable-register variable)) |
---|
3518 | (setf boundp t)) |
---|
3519 | (t |
---|
3520 | (compile-form initform :target :stack))) |
---|
3521 | (unless must-clear-values |
---|
3522 | (unless (single-valued-p initform) |
---|
3523 | (setf must-clear-values t)))) |
---|
3524 | (t |
---|
3525 | (emit-push-nil))) |
---|
3526 | (unless (variable-special-p variable) |
---|
3527 | (unless (or (variable-closure-index variable) (variable-register variable)) |
---|
3528 | (setf (variable-register variable) (allocate-register)))) |
---|
3529 | (push variable *visible-variables*) |
---|
3530 | (unless boundp |
---|
3531 | (compile-binding variable)))) |
---|
3532 | (when must-clear-values |
---|
3533 | (emit-clear-values)))) |
---|
3534 | |
---|
3535 | ;; Returns list of declared specials. |
---|
3536 | (defun process-special-declarations (forms) |
---|
3537 | (let ((specials ())) |
---|
3538 | (dolist (form forms) |
---|
3539 | (unless (and (consp form) (eq (car form) 'declare)) |
---|
3540 | (return)) |
---|
3541 | (let ((decls (cdr form))) |
---|
3542 | (dolist (decl decls) |
---|
3543 | (when (eq (car decl) 'special) |
---|
3544 | (setf specials (append (cdr decl) specials)))))) |
---|
3545 | specials)) |
---|
3546 | |
---|
3547 | (defun compile-locally (form &key (target *val*) representation) |
---|
3548 | (let ((*visible-variables* *visible-variables*) |
---|
3549 | (specials (process-special-declarations (cdr form)))) |
---|
3550 | (dolist (var specials) |
---|
3551 | (push (make-variable :name var :special-p t) *visible-variables*)) |
---|
3552 | (cond ((null (cdr form)) |
---|
3553 | (when target |
---|
3554 | (emit-push-nil) |
---|
3555 | (emit-move-from-stack target))) |
---|
3556 | (t |
---|
3557 | (do ((forms (cdr form) (cdr forms))) |
---|
3558 | ((null forms)) |
---|
3559 | (compile-form (car forms) :target (if (cdr forms) nil target))))))) |
---|
3560 | |
---|
3561 | (defun find-tag (name) |
---|
3562 | (dolist (tag *visible-tags*) |
---|
3563 | (when (eql name (tag-name tag)) |
---|
3564 | (return tag)))) |
---|
3565 | |
---|
3566 | (defun p2-tagbody-node (block target) |
---|
3567 | (let* ((*blocks* (cons block *blocks*)) |
---|
3568 | (*visible-tags* *visible-tags*) |
---|
3569 | (*register* *register*) |
---|
3570 | (form (block-form block)) |
---|
3571 | (body (cdr form)) |
---|
3572 | (local-tags ()) |
---|
3573 | (BEGIN-BLOCK (gensym)) |
---|
3574 | (END-BLOCK (gensym)) |
---|
3575 | (EXIT (gensym)) |
---|
3576 | environment-register |
---|
3577 | (must-clear-values nil)) |
---|
3578 | ;; Scan for tags. |
---|
3579 | (dolist (subform body) |
---|
3580 | (when (or (symbolp subform) (integerp subform)) |
---|
3581 | (let* ((tag (make-tag :name subform :label (gensym) :block block))) |
---|
3582 | (push tag local-tags) |
---|
3583 | (push tag *visible-tags*)))) |
---|
3584 | |
---|
3585 | ;; FIXME Pass 1 doesn't detect all non-local GOs! (HANDLER-CASE.17) |
---|
3586 | ;; So we do this unconditionally for now... |
---|
3587 | (when (or t (block-non-local-go-p block)) |
---|
3588 | (setf environment-register (allocate-register)) |
---|
3589 | (emit-push-current-thread) |
---|
3590 | (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" +lisp-binding+) |
---|
3591 | (emit 'astore environment-register)) |
---|
3592 | |
---|
3593 | (label BEGIN-BLOCK) |
---|
3594 | (do* ((rest body (cdr rest)) |
---|
3595 | (subform (car rest) (car rest))) |
---|
3596 | ((null rest)) |
---|
3597 | (cond ((or (symbolp subform) (integerp subform)) |
---|
3598 | (let ((tag (find-tag subform))) |
---|
3599 | (unless tag |
---|
3600 | (error "COMPILE-TAGBODY: tag not found: ~S~%" subform)) |
---|
3601 | (label (tag-label tag)))) |
---|
3602 | (t |
---|
3603 | (when (and (null (cdr rest)) ;; Last subform. |
---|
3604 | (consp subform) |
---|
3605 | (eq (car subform) 'GO)) |
---|
3606 | (maybe-generate-interrupt-check)) |
---|
3607 | (compile-form subform :target nil) |
---|
3608 | (unless must-clear-values |
---|
3609 | (unless (single-valued-p subform) |
---|
3610 | (setf must-clear-values t)))))) |
---|
3611 | (label END-BLOCK) |
---|
3612 | (emit 'goto EXIT) |
---|
3613 | (when (block-non-local-go-p block) |
---|
3614 | ; We need a handler to catch non-local GOs. |
---|
3615 | (let* ((HANDLER (gensym)) |
---|
3616 | (*register* *register*) |
---|
3617 | (go-register (allocate-register)) |
---|
3618 | (tag-register (allocate-register))) |
---|
3619 | (label HANDLER) |
---|
3620 | ;; The Go object is on the runtime stack. Stack depth is 1. |
---|
3621 | (emit 'dup) |
---|
3622 | (emit 'astore go-register) |
---|
3623 | ;; Get the tag. |
---|
3624 | (emit 'checkcast +lisp-go-class+) |
---|
3625 | (emit 'getfield +lisp-go-class+ "tag" +lisp-object+) ; Stack depth is still 1. |
---|
3626 | (emit 'astore tag-register) |
---|
3627 | |
---|
3628 | (dolist (tag local-tags) |
---|
3629 | (let ((NEXT (gensym))) |
---|
3630 | (emit 'aload tag-register) |
---|
3631 | (emit 'getstatic |
---|
3632 | *this-class* |
---|
3633 | (if *compile-file-truename* |
---|
3634 | (declare-object-as-string (tag-label tag)) |
---|
3635 | (declare-object (tag-label tag))) |
---|
3636 | +lisp-object+) |
---|
3637 | |
---|
3638 | (emit 'if_acmpne NEXT) ;; Jump if not EQ. |
---|
3639 | ;; Restore dynamic environment. |
---|
3640 | (emit-push-current-thread) |
---|
3641 | (aver (fixnump environment-register)) |
---|
3642 | (emit 'aload environment-register) |
---|
3643 | (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" +lisp-binding+) |
---|
3644 | (emit 'goto (tag-label tag)) |
---|
3645 | (label NEXT))) |
---|
3646 | ;; Not found. Re-throw Go. |
---|
3647 | (emit 'aload go-register) |
---|
3648 | (emit 'athrow) |
---|
3649 | |
---|
3650 | ;; Finally... |
---|
3651 | (push (make-handler :from BEGIN-BLOCK |
---|
3652 | :to END-BLOCK |
---|
3653 | :code HANDLER |
---|
3654 | :catch-type (pool-class +lisp-go-class+)) |
---|
3655 | *handlers*))) |
---|
3656 | (label EXIT) |
---|
3657 | (when must-clear-values |
---|
3658 | ;; (dformat t "p2-tagbody-node calling emit-clear-values~%") |
---|
3659 | (emit-clear-values)) |
---|
3660 | ;; TAGBODY returns NIL. |
---|
3661 | (when target |
---|
3662 | (emit-push-nil) |
---|
3663 | (emit-move-from-stack target)))) |
---|
3664 | |
---|
3665 | (defun compile-go (form &key target representation) |
---|
3666 | (let* ((name (cadr form)) |
---|
3667 | (tag (find-tag name))) |
---|
3668 | (unless tag |
---|
3669 | (error "COMPILE-GO: tag not found: ~S" name)) |
---|
3670 | (cond ((eq (tag-compiland tag) *current-compiland*) |
---|
3671 | ;; Local case. |
---|
3672 | (let ((tag-block (tag-block tag)) |
---|
3673 | (register nil)) |
---|
3674 | ;; Does the GO leave an enclosing UNWIND-PROTECT? |
---|
3675 | (let ((protected |
---|
3676 | (dolist (enclosing-block *blocks*) |
---|
3677 | (when (eq enclosing-block tag-block) |
---|
3678 | (return nil)) |
---|
3679 | (when (equal (block-name enclosing-block) '(UNWIND-PROTECT)) |
---|
3680 | (return t))))) |
---|
3681 | (when protected |
---|
3682 | (error "COMPILE-GO: enclosing UNWIND-PROTECT"))) |
---|
3683 | (dolist (block *blocks*) |
---|
3684 | (if (eq block tag-block) |
---|
3685 | (return) |
---|
3686 | (setf register (or (block-environment-register block) register)))) |
---|
3687 | (when register |
---|
3688 | ;; Restore dynamic environment. |
---|
3689 | (emit 'aload *thread*) |
---|
3690 | (emit 'aload register) |
---|
3691 | (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" +lisp-binding+))) |
---|
3692 | (maybe-generate-interrupt-check) ;; FIXME not exactly right, but better than nothing |
---|
3693 | (emit 'goto (tag-label tag))) |
---|
3694 | (t |
---|
3695 | ;; Non-local GO. |
---|
3696 | (emit 'new +lisp-go-class+) |
---|
3697 | (emit 'dup) |
---|
3698 | (compile-form `',(tag-label tag) :target :stack) ; Tag. |
---|
3699 | (emit-invokespecial +lisp-go-class+ |
---|
3700 | "<init>" |
---|
3701 | "(Lorg/armedbear/lisp/LispObject;)V" |
---|
3702 | -2) |
---|
3703 | (emit 'athrow) |
---|
3704 | ;; Following code will not be reached, but is needed for JVM stack |
---|
3705 | ;; consistency. |
---|
3706 | (when target |
---|
3707 | (emit-push-nil) |
---|
3708 | (emit-move-from-stack target)))))) |
---|
3709 | |
---|
3710 | (defun compile-atom (form &key (target *val*) representation) |
---|
3711 | (unless (= (length form) 2) |
---|
3712 | (error "Wrong number of arguments for ATOM.")) |
---|
3713 | (compile-form (cadr form) :target :stack) |
---|
3714 | (maybe-emit-clear-values (cadr form)) |
---|
3715 | (emit 'instanceof +lisp-cons-class+) |
---|
3716 | (let ((LABEL1 (gensym)) |
---|
3717 | (LABEL2 (gensym))) |
---|
3718 | (emit 'ifeq LABEL1) |
---|
3719 | (emit-push-nil) |
---|
3720 | (emit 'goto LABEL2) |
---|
3721 | (label LABEL1) |
---|
3722 | (emit-push-t) |
---|
3723 | (label LABEL2) |
---|
3724 | (emit-move-from-stack target))) |
---|
3725 | |
---|
3726 | (defun contains-return (form) |
---|
3727 | (if (atom form) |
---|
3728 | (if (node-p form) |
---|
3729 | (contains-return (node-form form)) |
---|
3730 | nil) |
---|
3731 | (case (car form) |
---|
3732 | (QUOTE |
---|
3733 | nil) |
---|
3734 | (RETURN-FROM |
---|
3735 | t) |
---|
3736 | (t |
---|
3737 | (dolist (subform form) |
---|
3738 | (when (contains-return subform) |
---|
3739 | (return t))))))) |
---|
3740 | |
---|
3741 | (defun compile-block (form &key (target *val*) representation) |
---|
3742 | ;; (format t "compile-block ~S~%" (cadr form)) |
---|
3743 | ;; This shouldn't be called, now that we have pass 1. |
---|
3744 | ;; (assert nil) |
---|
3745 | (let ((block (make-block-node :form form |
---|
3746 | :name (cadr form) |
---|
3747 | :target target))) |
---|
3748 | (compile-block-node block target) |
---|
3749 | )) |
---|
3750 | |
---|
3751 | (defun compile-block-node (block target) |
---|
3752 | ;; (dformat t "COMPILE-BLOCK-NODE ~S block-return-p = ~S~%" |
---|
3753 | ;; (block-name block) (block-return-p block)) |
---|
3754 | (unless (block-node-p block) |
---|
3755 | (%format t "type-of block = ~S~%" (type-of block)) |
---|
3756 | (aver (block-node-p block))) |
---|
3757 | (let* ((*blocks* (cons block *blocks*)) |
---|
3758 | (*register* *register*)) |
---|
3759 | (setf (block-target block) target) |
---|
3760 | (when (block-return-p block) |
---|
3761 | ;; Save current dynamic environment. |
---|
3762 | (setf (block-environment-register block) (allocate-register)) |
---|
3763 | (emit-push-current-thread) |
---|
3764 | (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" +lisp-binding+) |
---|
3765 | (emit 'astore (block-environment-register block))) |
---|
3766 | (setf (block-catch-tag block) (gensym)) |
---|
3767 | (let* ((*register* *register*) |
---|
3768 | (BEGIN-BLOCK (gensym)) |
---|
3769 | (END-BLOCK (gensym)) |
---|
3770 | (BLOCK-EXIT (block-exit block))) |
---|
3771 | (label BEGIN-BLOCK) ; Start of protected range. |
---|
3772 | ;; Implicit PROGN. |
---|
3773 | (compile-progn-body (cddr (block-form block)) target) |
---|
3774 | (label END-BLOCK) ; End of protected range. |
---|
3775 | (emit 'goto BLOCK-EXIT) ; Jump over handler (if any). |
---|
3776 | (when (block-non-local-return-p block) |
---|
3777 | ; We need a handler to catch non-local RETURNs. |
---|
3778 | (let ((HANDLER (gensym)) |
---|
3779 | (RETHROW (gensym))) |
---|
3780 | (label HANDLER) |
---|
3781 | ;; The Return object is on the runtime stack. Stack depth is 1. |
---|
3782 | (emit 'dup) ; Stack depth is 2. |
---|
3783 | (emit 'getfield +lisp-return-class+ "tag" +lisp-object+) ; Still 2. |
---|
3784 | (compile-form `',(block-catch-tag block) :target :stack) ; Tag. Stack depth is 3. |
---|
3785 | ;; If it's not the tag we're looking for... |
---|
3786 | (emit 'if_acmpne RETHROW) ; Stack depth is 1. |
---|
3787 | (emit 'getfield +lisp-return-class+ "result" +lisp-object+) |
---|
3788 | (emit-move-from-stack target) ; Stack depth is 0. |
---|
3789 | (emit 'goto BLOCK-EXIT) |
---|
3790 | (label RETHROW) |
---|
3791 | ;; Not the tag we're looking for. |
---|
3792 | (emit 'athrow) |
---|
3793 | ;; Finally... |
---|
3794 | (push (make-handler :from BEGIN-BLOCK |
---|
3795 | :to END-BLOCK |
---|
3796 | :code HANDLER |
---|
3797 | :catch-type (pool-class +lisp-return-class+)) |
---|
3798 | *handlers*))) |
---|
3799 | (label BLOCK-EXIT)) |
---|
3800 | (when (block-environment-register block) |
---|
3801 | ;; We saved the dynamic environment above. Restore it now. |
---|
3802 | (emit 'aload *thread*) |
---|
3803 | (emit 'aload (block-environment-register block)) |
---|
3804 | (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" +lisp-binding+)))) |
---|
3805 | |
---|
3806 | (defun compile-return-from (form &key (target *val*) representation) |
---|
3807 | (let* ((name (second form)) |
---|
3808 | (result-form (third form)) |
---|
3809 | (block (find-block name))) |
---|
3810 | (cond |
---|
3811 | ((null block) |
---|
3812 | (error "No block named ~S is currently visible." name)) |
---|
3813 | ((eq (block-compiland block) *current-compiland*) |
---|
3814 | ;; Local case. Is the RETURN nested inside an UNWIND-PROTECT which |
---|
3815 | ;; is inside the block we're returning from? |
---|
3816 | (let ((protected |
---|
3817 | (dolist (enclosing-block *blocks*) |
---|
3818 | (when (eq enclosing-block block) |
---|
3819 | (return nil)) |
---|
3820 | (when (equal (block-name enclosing-block) '(UNWIND-PROTECT)) |
---|
3821 | (return t))))) |
---|
3822 | (when protected |
---|
3823 | (error "COMPILE-RETURN-FROM: enclosing UNWIND-PROTECT"))) |
---|
3824 | |
---|
3825 | ;; Added Dec 9 2004 7:28 AM |
---|
3826 | ;; (dformat t "compile-return-from calling emit-clear-values~%") |
---|
3827 | (emit-clear-values) |
---|
3828 | |
---|
3829 | (compile-form result-form :target (block-target block)) |
---|
3830 | (emit 'goto (block-exit block))) |
---|
3831 | (t |
---|
3832 | ;; Non-local RETURN. |
---|
3833 | (setf (block-non-local-return-p block) t) |
---|
3834 | (emit 'new +lisp-return-class+) |
---|
3835 | (emit 'dup) |
---|
3836 | (compile-form `',(block-catch-tag block) :target :stack) ; Tag. |
---|
3837 | |
---|
3838 | ;; Added Dec 9 2004 7:28 AM |
---|
3839 | (emit-clear-values) |
---|
3840 | |
---|
3841 | (compile-form (third form) :target :stack) ; Result. |
---|
3842 | (emit-invokespecial +lisp-return-class+ |
---|
3843 | "<init>" |
---|
3844 | "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)V" |
---|
3845 | -3) |
---|
3846 | (emit 'athrow) |
---|
3847 | ;; Following code will not be reached, but is needed for JVM stack |
---|
3848 | ;; consistency. |
---|
3849 | (when target |
---|
3850 | (emit-push-nil) |
---|
3851 | (emit-move-from-stack target)))))) |
---|
3852 | |
---|
3853 | (defun compile-cons (form &key (target *val*) representation) |
---|
3854 | (unless (check-args form 2) |
---|
3855 | (compile-function-call form target representation) |
---|
3856 | (return-from compile-cons)) |
---|
3857 | (emit 'new +lisp-cons-class+) |
---|
3858 | (emit 'dup) |
---|
3859 | (process-args (cdr form)) |
---|
3860 | (emit-invokespecial "org/armedbear/lisp/Cons" |
---|
3861 | "<init>" |
---|
3862 | "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)V" |
---|
3863 | -3) |
---|
3864 | (emit-move-from-stack target)) |
---|
3865 | |
---|
3866 | (defun compile-progn-body (body target) |
---|
3867 | (cond ((null body) |
---|
3868 | (when target |
---|
3869 | (emit-push-nil) |
---|
3870 | (emit-move-from-stack target))) |
---|
3871 | (t |
---|
3872 | (let ((must-clear-values nil)) |
---|
3873 | (do* ((forms body (cdr forms)) |
---|
3874 | (form (car forms) (car forms))) |
---|
3875 | ((null forms)) |
---|
3876 | (when (null (cdr forms)) |
---|
3877 | ;; Last form. |
---|
3878 | (when must-clear-values |
---|
3879 | (emit-clear-values))) |
---|
3880 | (compile-form form :target (if (cdr forms) nil target)) |
---|
3881 | (unless (null (cdr forms)) |
---|
3882 | (unless must-clear-values |
---|
3883 | (unless (single-valued-p form) |
---|
3884 | ;; (dformat t "compile-progn-body not single-valued: ~S~%" form) |
---|
3885 | (setf must-clear-values t))))))))) |
---|
3886 | |
---|
3887 | (defun compile-progn (form &key (target *val*) representation) |
---|
3888 | (compile-progn-body (cdr form) target) |
---|
3889 | (when (eq representation :unboxed-fixnum) |
---|
3890 | (emit-unbox-fixnum))) |
---|
3891 | |
---|
3892 | (defun compile-quote (form &key (target *val*) representation) |
---|
3893 | (let ((obj (second form))) |
---|
3894 | (cond ((null obj) |
---|
3895 | (when target |
---|
3896 | (emit-push-nil) |
---|
3897 | (emit-move-from-stack target))) |
---|
3898 | ((symbolp obj) |
---|
3899 | (if (symbol-package obj) |
---|
3900 | (let ((g (declare-symbol obj))) |
---|
3901 | (emit 'getstatic |
---|
3902 | *this-class* |
---|
3903 | g |
---|
3904 | +lisp-symbol+)) |
---|
3905 | ;; An uninterned symbol. |
---|
3906 | (let ((g (if *compile-file-truename* |
---|
3907 | (declare-object-as-string obj) |
---|
3908 | (declare-object obj)))) |
---|
3909 | (emit 'getstatic |
---|
3910 | *this-class* |
---|
3911 | g |
---|
3912 | +lisp-object+))) |
---|
3913 | (emit-move-from-stack target)) |
---|
3914 | ((listp obj) |
---|
3915 | (let ((g (if *compile-file-truename* |
---|
3916 | (declare-object-as-string obj) |
---|
3917 | (declare-object obj)))) |
---|
3918 | (emit 'getstatic |
---|
3919 | *this-class* |
---|
3920 | g |
---|
3921 | +lisp-object+) |
---|
3922 | (emit-move-from-stack target))) |
---|
3923 | ((constantp obj) |
---|
3924 | (compile-constant obj :target target)) |
---|
3925 | (t |
---|
3926 | (error "COMPILE-QUOTE: unsupported case: ~S" form))))) |
---|
3927 | |
---|
3928 | (defun compile-rplacd (form &key (target *val*) representation) |
---|
3929 | (let ((args (cdr form))) |
---|
3930 | (unless (= (length args) 2) |
---|
3931 | (error "wrong number of arguments for RPLACD")) |
---|
3932 | (compile-form (first args) :target :stack) |
---|
3933 | (when target |
---|
3934 | (emit 'dup)) |
---|
3935 | (compile-form (second args) :target :stack) |
---|
3936 | (emit-invokevirtual +lisp-object-class+ |
---|
3937 | "setCdr" |
---|
3938 | "(Lorg/armedbear/lisp/LispObject;)V" |
---|
3939 | -2) |
---|
3940 | (when target |
---|
3941 | (emit-move-from-stack target)))) |
---|
3942 | |
---|
3943 | (defun compile-declare (form &key target representation) |
---|
3944 | (when target |
---|
3945 | (emit-push-nil) |
---|
3946 | (emit-move-from-stack target))) |
---|
3947 | |
---|
3948 | (defun p2-local-function (compiland local-function) |
---|
3949 | (let* ((name (compiland-name compiland)) |
---|
3950 | (arglist (cadr (compiland-lambda-expression compiland))) |
---|
3951 | form |
---|
3952 | function |
---|
3953 | classfile) |
---|
3954 | (when (or (memq '&optional arglist) |
---|
3955 | (memq '&key arglist)) |
---|
3956 | (let ((state nil)) |
---|
3957 | (dolist (arg arglist) |
---|
3958 | (cond ((memq arg lambda-list-keywords) |
---|
3959 | (setf state arg)) |
---|
3960 | ((memq state '(&optional &key)) |
---|
3961 | (when (and (consp arg) |
---|
3962 | (not (constantp (second arg)))) |
---|
3963 | (error "P2-LOCAL-FUNCTION: can't handle optional argument with non-constant initform."))))))) |
---|
3964 | (setf form (compiland-lambda-expression compiland)) |
---|
3965 | (setf classfile (if *compile-file-truename* |
---|
3966 | (sys::next-classfile-name) |
---|
3967 | (prog1 |
---|
3968 | (%format nil "local-~D.class" *child-count*) |
---|
3969 | (incf *child-count*)))) |
---|
3970 | (setf (compiland-classfile compiland) classfile) |
---|
3971 | (let ((*current-compiland* compiland) |
---|
3972 | (*speed* *speed*) |
---|
3973 | (*safety* *safety*) |
---|
3974 | (*debug* *debug*)) |
---|
3975 | (p2-compiland compiland)) |
---|
3976 | (when (null *compile-file-truename*) |
---|
3977 | (setf function (sys:load-compiled-function classfile))) |
---|
3978 | (cond (local-function |
---|
3979 | (setf (local-function-classfile local-function) classfile) |
---|
3980 | (let ((g (if *compile-file-truename* |
---|
3981 | (declare-local-function local-function) |
---|
3982 | (declare-object function)))) |
---|
3983 | (emit 'getstatic |
---|
3984 | *this-class* |
---|
3985 | g |
---|
3986 | +lisp-object+) |
---|
3987 | (emit 'var-set (local-function-variable local-function)))) |
---|
3988 | (t |
---|
3989 | (push (make-local-function :name name |
---|
3990 | :function function |
---|
3991 | :classfile classfile) |
---|
3992 | *local-functions*))))) |
---|
3993 | |
---|
3994 | (defun p2-flet (form &key (target *val*) representation) |
---|
3995 | (let ((*local-functions* *local-functions*) |
---|
3996 | (compilands (cadr form)) |
---|
3997 | (body (cddr form))) |
---|
3998 | (dolist (compiland compilands) |
---|
3999 | (p2-local-function compiland nil)) |
---|
4000 | (do ((forms body (cdr forms))) |
---|
4001 | ((null forms)) |
---|
4002 | (compile-form (car forms) :target (if (cdr forms) nil target))))) |
---|
4003 | |
---|
4004 | (defun p2-labels (form &key target representation) |
---|
4005 | (let ((*local-functions* *local-functions*) |
---|
4006 | (local-functions (cadr form)) |
---|
4007 | (body (cddr form))) |
---|
4008 | (dolist (local-function local-functions) |
---|
4009 | (push local-function *local-functions*) |
---|
4010 | (push (local-function-variable local-function) *visible-variables*)) |
---|
4011 | (dolist (local-function local-functions) |
---|
4012 | (let ((variable (local-function-variable local-function))) |
---|
4013 | (aver (null (variable-register variable))) |
---|
4014 | (unless (variable-closure-index variable) |
---|
4015 | (setf (variable-register variable) (allocate-register))) |
---|
4016 | (setf (variable-index variable) nil))) |
---|
4017 | (dolist (local-function local-functions) |
---|
4018 | (p2-local-function (local-function-compiland local-function) local-function)) |
---|
4019 | (do ((forms body (cdr forms))) |
---|
4020 | ((null forms)) |
---|
4021 | (compile-form (car forms) :target (if (cdr forms) nil target))))) |
---|
4022 | |
---|
4023 | (defun contains-symbol (symbol form) |
---|
4024 | (cond ((node-p form) |
---|
4025 | (contains-symbol symbol (node-form form))) |
---|
4026 | ((atom form) |
---|
4027 | (eq form symbol)) |
---|
4028 | (t |
---|
4029 | (or (contains-symbol symbol (car form)) |
---|
4030 | (contains-symbol symbol (cdr form)))))) |
---|
4031 | |
---|
4032 | (defun contains-go (form) |
---|
4033 | (cond ((node-p form) |
---|
4034 | (contains-go (node-form form))) |
---|
4035 | ((atom form) |
---|
4036 | nil) |
---|
4037 | (t |
---|
4038 | (case (car form) |
---|
4039 | (QUOTE |
---|
4040 | nil) |
---|
4041 | (GO |
---|
4042 | t) |
---|
4043 | (t |
---|
4044 | (dolist (subform form) |
---|
4045 | (when (contains-go subform) |
---|
4046 | (return t)))))))) |
---|
4047 | |
---|
4048 | (defun p2-lambda (compiland target) |
---|
4049 | (let* ((lambda-list (cadr (compiland-lambda-expression compiland)))) |
---|
4050 | (when (or (memq '&optional lambda-list) |
---|
4051 | (memq '&key lambda-list)) |
---|
4052 | (let ((state nil)) |
---|
4053 | (dolist (arg lambda-list) |
---|
4054 | (cond ((memq arg lambda-list-keywords) |
---|
4055 | (setf state arg)) |
---|
4056 | ((memq state '(&optional &key)) |
---|
4057 | (when (and (consp arg) |
---|
4058 | (not (constantp (second arg)))) |
---|
4059 | (error "P2-LAMBDA: can't handle optional argument with non-constant initform."))))))) |
---|
4060 | (cond (*compile-file-truename* |
---|
4061 | |
---|
4062 | (setf (compiland-classfile compiland) (sys::next-classfile-name)) |
---|
4063 | |
---|
4064 | (let ((*current-compiland* compiland) |
---|
4065 | (*speed* *speed*) |
---|
4066 | (*safety* *safety*) |
---|
4067 | (*debug* *debug*) |
---|
4068 | compiled-function) |
---|
4069 | (p2-compiland compiland)) |
---|
4070 | |
---|
4071 | (let* ((local-function (make-local-function :classfile (compiland-classfile compiland))) |
---|
4072 | (g (declare-local-function local-function))) |
---|
4073 | (emit 'getstatic |
---|
4074 | *this-class* |
---|
4075 | g |
---|
4076 | +lisp-object+)) |
---|
4077 | |
---|
4078 | ;; ) |
---|
4079 | ) |
---|
4080 | (t |
---|
4081 | (setf (compiland-classfile compiland) |
---|
4082 | (prog1 |
---|
4083 | (%format nil "local-~D.class" *child-count*) |
---|
4084 | (incf *child-count*))) |
---|
4085 | (let ((*current-compiland* compiland) |
---|
4086 | (*speed* *speed*) |
---|
4087 | (*safety* *safety*) |
---|
4088 | (*debug* *debug*) |
---|
4089 | compiled-function) |
---|
4090 | (p2-compiland compiland) |
---|
4091 | (setf compiled-function |
---|
4092 | (sys:load-compiled-function (compiland-classfile compiland))) |
---|
4093 | (emit 'getstatic |
---|
4094 | *this-class* |
---|
4095 | (declare-object compiled-function) |
---|
4096 | +lisp-object+)))) |
---|
4097 | (cond |
---|
4098 | ((null *closure-variables*)) ; Nothing to do. |
---|
4099 | ((compiland-closure-register *current-compiland*) |
---|
4100 | (emit 'aload (compiland-closure-register *current-compiland*)) |
---|
4101 | (emit-invokestatic +lisp-class+ |
---|
4102 | "makeCompiledClosure" |
---|
4103 | "(Lorg/armedbear/lisp/LispObject;[Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" |
---|
4104 | -1) |
---|
4105 | (emit 'checkcast "org/armedbear/lisp/CompiledClosure") |
---|
4106 | ) ; Stack: compiled-closure |
---|
4107 | (t |
---|
4108 | ;; Shouldn't happen. |
---|
4109 | (aver (progn 'unexpected nil)) |
---|
4110 | (emit-push-constant-int 0) |
---|
4111 | (emit 'anewarray "org/armedbear/lisp/LispObject"))) |
---|
4112 | (emit-move-from-stack target))) |
---|
4113 | |
---|
4114 | (defun p2-function (form &key (target *val*) representation) |
---|
4115 | (let ((name (second form)) |
---|
4116 | (local-function)) |
---|
4117 | (cond |
---|
4118 | ((symbolp name) |
---|
4119 | (cond |
---|
4120 | ((setf local-function (find-local-function name)) |
---|
4121 | (when (eq (local-function-compiland local-function) *current-compiland*) |
---|
4122 | (emit 'aload 0) ; this |
---|
4123 | (emit-move-from-stack target) |
---|
4124 | (return-from p2-function)) |
---|
4125 | (if (local-function-variable local-function) |
---|
4126 | (emit 'var-ref (local-function-variable local-function) :stack) |
---|
4127 | (let ((g (if *compile-file-truename* |
---|
4128 | (declare-local-function local-function) |
---|
4129 | (declare-object (local-function-function local-function))))) |
---|
4130 | (emit 'getstatic |
---|
4131 | *this-class* |
---|
4132 | g |
---|
4133 | +lisp-object+))) ; Stack: template-function |
---|
4134 | (cond |
---|
4135 | ((null *closure-variables*)) ; Nothing to do. |
---|
4136 | ((compiland-closure-register *current-compiland*) |
---|
4137 | (emit 'aload (compiland-closure-register *current-compiland*)) |
---|
4138 | (emit-invokestatic +lisp-class+ |
---|
4139 | "makeCompiledClosure" |
---|
4140 | "(Lorg/armedbear/lisp/LispObject;[Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" |
---|
4141 | -1)) ; Stack: compiled-closure |
---|
4142 | (t |
---|
4143 | (aver (progn 'unexpected nil)))) |
---|
4144 | (emit-move-from-stack target)) |
---|
4145 | ((inline-ok name) |
---|
4146 | (emit 'getstatic |
---|
4147 | *this-class* |
---|
4148 | (declare-function name) |
---|
4149 | +lisp-object+) |
---|
4150 | (emit-move-from-stack target)) |
---|
4151 | (t |
---|
4152 | (emit 'getstatic |
---|
4153 | *this-class* |
---|
4154 | (declare-symbol name) |
---|
4155 | +lisp-symbol+) |
---|
4156 | (emit-invokevirtual +lisp-object-class+ |
---|
4157 | "getSymbolFunctionOrDie" |
---|
4158 | "()Lorg/armedbear/lisp/LispObject;" |
---|
4159 | 0) |
---|
4160 | (emit-move-from-stack target)))) |
---|
4161 | ((and (consp name) (eq (car name) 'SETF)) |
---|
4162 | ; FIXME Need to check for NOTINLINE declaration! |
---|
4163 | (cond |
---|
4164 | ((member name *toplevel-defuns* :test #'equal) |
---|
4165 | (emit 'getstatic |
---|
4166 | *this-class* |
---|
4167 | (declare-setf-function name) |
---|
4168 | +lisp-object+) |
---|
4169 | (emit-move-from-stack target)) |
---|
4170 | ((and (null *compile-file-truename*) |
---|
4171 | (fdefinition name)) |
---|
4172 | (emit 'getstatic |
---|
4173 | *this-class* |
---|
4174 | (declare-object (fdefinition name)) |
---|
4175 | +lisp-object+) |
---|
4176 | (emit-move-from-stack target)) |
---|
4177 | (t |
---|
4178 | (emit 'getstatic |
---|
4179 | *this-class* |
---|
4180 | (declare-symbol (cadr name)) |
---|
4181 | +lisp-symbol+) |
---|
4182 | (emit-invokevirtual +lisp-symbol-class+ |
---|
4183 | "getSymbolSetfFunctionOrDie" |
---|
4184 | "()Lorg/armedbear/lisp/LispObject;" |
---|
4185 | 0) |
---|
4186 | (emit-move-from-stack target)))) |
---|
4187 | ((compiland-p name) |
---|
4188 | (p2-lambda name target)) |
---|
4189 | (t |
---|
4190 | (error "p2-function: unsupported case: ~S" form))))) |
---|
4191 | |
---|
4192 | (defun p2-ash (form &key (target *val*) representation) |
---|
4193 | (dformat t "p2-ash form = ~S representation = ~S~%" form representation) |
---|
4194 | (unless (check-args form 2) |
---|
4195 | (compile-function-call form target representation) |
---|
4196 | (return-from p2-ash)) |
---|
4197 | (let* ((args (cdr form)) |
---|
4198 | (len (length args)) |
---|
4199 | (arg1 (first args)) |
---|
4200 | (arg2 (second args)) |
---|
4201 | (var1 (unboxed-fixnum-variable arg1)) |
---|
4202 | (var2 (unboxed-fixnum-variable arg2))) |
---|
4203 | (cond |
---|
4204 | ((and (numberp arg1) (numberp arg2)) |
---|
4205 | (dformat t "p2-ash case 1~%") |
---|
4206 | (compile-constant (ash arg1 arg2) |
---|
4207 | :target target |
---|
4208 | :representation representation)) |
---|
4209 | ((and var1 (fixnump arg2) (< 0 arg2 32)) |
---|
4210 | (dformat t "p2-ash case 2~%") |
---|
4211 | (case representation |
---|
4212 | (:unboxed-fixnum |
---|
4213 | (emit-push-int var1) |
---|
4214 | (emit-push-constant-int arg2) |
---|
4215 | (emit 'ishl)) |
---|
4216 | (t |
---|
4217 | (emit-push-int var1) |
---|
4218 | (emit 'i2l) |
---|
4219 | (emit-push-constant-int arg2) |
---|
4220 | (emit 'lshl) |
---|
4221 | (emit-box-long))) |
---|
4222 | (emit-move-from-stack target representation)) |
---|
4223 | ((and var1 (fixnump arg2) (< -32 arg2 0)) |
---|
4224 | (dformat t "p2-ash case 3~%") |
---|
4225 | (unless (eq representation :unboxed-fixnum) |
---|
4226 | (emit 'new +lisp-fixnum-class+) |
---|
4227 | (emit 'dup)) |
---|
4228 | (emit-push-int var1) |
---|
4229 | (emit-push-constant-int (- arg2)) |
---|
4230 | (emit 'ishr) |
---|
4231 | (unless (eq representation :unboxed-fixnum) |
---|
4232 | (emit-invokespecial +lisp-fixnum-class+ "<init>" "(I)V" -2)) |
---|
4233 | (emit-move-from-stack target representation)) |
---|
4234 | (var2 |
---|
4235 | (dformat t "p2-ash case 4~%") |
---|
4236 | (compile-form arg1 :target :stack) |
---|
4237 | (maybe-emit-clear-values arg1) |
---|
4238 | (emit 'iload (variable-register var2)) |
---|
4239 | (emit-invokevirtual +lisp-object-class+ |
---|
4240 | "ash" |
---|
4241 | "(I)Lorg/armedbear/lisp/LispObject;" |
---|
4242 | -1) |
---|
4243 | (when (eq representation :unboxed-fixnum) |
---|
4244 | (emit-unbox-fixnum)) |
---|
4245 | (emit-move-from-stack target representation)) |
---|
4246 | ((fixnump arg2) |
---|
4247 | (dformat t "p2-ash case 5~%") |
---|
4248 | (compile-form arg1 :target :stack) |
---|
4249 | (maybe-emit-clear-values arg1) |
---|
4250 | (emit-push-constant-int arg2) |
---|
4251 | (emit-invokevirtual +lisp-object-class+ |
---|
4252 | "ash" |
---|
4253 | "(I)Lorg/armedbear/lisp/LispObject;" |
---|
4254 | -1) |
---|
4255 | (when (eq representation :unboxed-fixnum) |
---|
4256 | (emit-unbox-fixnum)) |
---|
4257 | (emit-move-from-stack target representation)) |
---|
4258 | (t |
---|
4259 | (dformat t "p2-ash case 6~%") |
---|
4260 | (compile-function-call form target representation))))) |
---|
4261 | |
---|
4262 | (defun p2-logand (form &key (target *val*) representation) |
---|
4263 | (let* ((args (cdr form)) |
---|
4264 | (len (length args))) |
---|
4265 | (when (= len 2) |
---|
4266 | (let* ((arg1 (first args)) |
---|
4267 | (arg2 (second args)) |
---|
4268 | (var1 (unboxed-fixnum-variable arg1))) |
---|
4269 | (dformat t "p2-logand var1 = ~S~%" var1) |
---|
4270 | (dformat t "p2-logand type-of arg2 is ~S~%" (type-of arg2)) |
---|
4271 | (cond |
---|
4272 | ((and (integerp arg1) (integerp arg2)) |
---|
4273 | (dformat t "p2-logand case 1~%") |
---|
4274 | (compile-constant (logand arg1 arg2) :target target :representation representation) |
---|
4275 | (return-from p2-logand t)) |
---|
4276 | ((and (fixnump arg2) (zerop arg2)) |
---|
4277 | (dformat t "p2-logand case 2~%") |
---|
4278 | (compile-constant 0 :target target :representation representation) |
---|
4279 | (return-from p2-logand t)) |
---|
4280 | ((and var1 (fixnump arg2)) |
---|
4281 | (dformat t "p2-logand case 3~%") |
---|
4282 | (unless (eq representation :unboxed-fixnum) |
---|
4283 | (emit 'new +lisp-fixnum-class+) |
---|
4284 | (emit 'dup)) |
---|
4285 | (emit 'iload (variable-register var1)) |
---|
4286 | (emit-push-constant-int arg2) |
---|
4287 | (emit 'iand) |
---|
4288 | (unless (eq representation :unboxed-fixnum) |
---|
4289 | (emit-invokespecial +lisp-fixnum-class+ "<init>" "(I)V" -2)) |
---|
4290 | (emit-move-from-stack target representation) |
---|
4291 | (return-from p2-logand t)) |
---|
4292 | ((fixnump arg2) |
---|
4293 | (dformat t "p2-logand case 4~%") |
---|
4294 | (let ((type (derive-type arg1))) |
---|
4295 | (dformat t "p2-logand arg1 derived type = ~S~%" type) |
---|
4296 | (cond |
---|
4297 | ((subtypep type 'fixnum) |
---|
4298 | (dformat t "p2-logand case 4a~%") |
---|
4299 | (unless (eq representation :unboxed-fixnum) |
---|
4300 | (emit 'new +lisp-fixnum-class+) |
---|
4301 | (emit 'dup)) |
---|
4302 | (compile-form arg1 :target :stack :representation :unboxed-fixnum) |
---|
4303 | (maybe-emit-clear-values arg1) |
---|
4304 | (emit-push-constant-int arg2) |
---|
4305 | (emit 'iand) |
---|
4306 | (unless (eq representation :unboxed-fixnum) |
---|
4307 | (emit-invokespecial +lisp-fixnum-class+ "<init>" "(I)V" -2)) |
---|
4308 | (emit-move-from-stack target representation)) |
---|
4309 | (t |
---|
4310 | (dformat t "p2-logand case 4b~%") |
---|
4311 | (compile-form arg1 :target :stack) |
---|
4312 | (maybe-emit-clear-values arg1) |
---|
4313 | (emit-push-constant-int arg2) |
---|
4314 | (emit-invokevirtual +lisp-object-class+ |
---|
4315 | "logand" |
---|
4316 | "(I)Lorg/armedbear/lisp/LispObject;" |
---|
4317 | -1) |
---|
4318 | (when (eq representation :unboxed-fixnum) |
---|
4319 | (emit-unbox-fixnum)) |
---|
4320 | (emit-move-from-stack target representation)))) |
---|
4321 | (return-from p2-logand t)))))) |
---|
4322 | (dformat t "p2-logand default case~%") |
---|
4323 | (compile-function-call form target representation)) |
---|
4324 | |
---|
4325 | (defun derive-type (form) |
---|
4326 | (cond |
---|
4327 | ((fixnump form) |
---|
4328 | (return-from derive-type 'fixnum)) |
---|
4329 | ((unboxed-fixnum-variable form) |
---|
4330 | (return-from derive-type 'fixnum)) |
---|
4331 | ((consp form) |
---|
4332 | (let ((op (first form))) |
---|
4333 | (case op |
---|
4334 | (ASH |
---|
4335 | (dformat t "derive-type ASH case form = ~S~%" form) |
---|
4336 | (let* ((arg1 (second form)) |
---|
4337 | (var1 (unboxed-fixnum-variable arg1)) |
---|
4338 | (arg2 (third form))) |
---|
4339 | (dformat t "derive-type ASH case var1 = ~S~%" var1) |
---|
4340 | (when (and var1 (fixnump arg2) (minusp arg2)) |
---|
4341 | (return-from derive-type 'FIXNUM)))) |
---|
4342 | (THE |
---|
4343 | (dformat t "derive-type THE case form = ~S~%" form) |
---|
4344 | (when (subtypep (second form) 'FIXNUM) |
---|
4345 | (dformat t "derive-type THE case form = ~S returning FIXNUM~%" form) |
---|
4346 | (return-from derive-type 'FIXNUM)) |
---|
4347 | ))))) |
---|
4348 | t) |
---|
4349 | |
---|
4350 | (defun compile-length (form &key (target *val*) representation) |
---|
4351 | (check-args form 1) |
---|
4352 | (let ((arg (cadr form))) |
---|
4353 | (compile-form arg :target :stack) |
---|
4354 | (maybe-emit-clear-values arg) |
---|
4355 | (cond |
---|
4356 | ((eq representation :unboxed-fixnum) |
---|
4357 | (emit-invokevirtual +lisp-object-class+ |
---|
4358 | "length" |
---|
4359 | "()I" |
---|
4360 | 0)) |
---|
4361 | (t |
---|
4362 | (emit-invokevirtual +lisp-object-class+ |
---|
4363 | "LENGTH" |
---|
4364 | "()Lorg/armedbear/lisp/LispObject;" |
---|
4365 | 0))) |
---|
4366 | (emit-move-from-stack target representation))) |
---|
4367 | |
---|
4368 | (defun compile-nth (form &key (target *val*) representation) |
---|
4369 | (unless (check-args form 2) |
---|
4370 | (compile-function-call form target representation) |
---|
4371 | (return-from compile-nth)) |
---|
4372 | (let ((index-form (second form)) |
---|
4373 | (list-form (third form))) |
---|
4374 | (compile-form index-form :target :stack :representation :unboxed-fixnum) |
---|
4375 | (compile-form list-form :target :stack) |
---|
4376 | (unless (and (single-valued-p index-form) |
---|
4377 | (single-valued-p list-form)) |
---|
4378 | (emit-clear-values)) |
---|
4379 | (emit 'swap) |
---|
4380 | (emit-invokevirtual +lisp-object-class+ |
---|
4381 | "NTH" |
---|
4382 | "(I)Lorg/armedbear/lisp/LispObject;" |
---|
4383 | -1) |
---|
4384 | (when (eq representation :unboxed-fixnum) |
---|
4385 | (emit-unbox-fixnum)) |
---|
4386 | (emit-move-from-stack target representation))) |
---|
4387 | |
---|
4388 | (defun compile-plus (form &key (target *val*) representation) |
---|
4389 | (case (length form) |
---|
4390 | (3 |
---|
4391 | (let* ((args (cdr form)) |
---|
4392 | (arg1 (first args)) |
---|
4393 | (arg2 (second args)) |
---|
4394 | (var1 (unboxed-fixnum-variable arg1)) |
---|
4395 | (var2 (unboxed-fixnum-variable arg2))) |
---|
4396 | (cond |
---|
4397 | ((and (numberp arg1) (numberp arg2)) |
---|
4398 | (compile-constant (+ arg1 arg2) |
---|
4399 | :target target |
---|
4400 | :representation representation)) |
---|
4401 | ((and var1 var2) |
---|
4402 | (dformat t "compile-plus case 1~%") |
---|
4403 | (dformat t "target = ~S representation = ~S~%" target representation) |
---|
4404 | (aver (variable-register var1)) |
---|
4405 | (aver (variable-register var2)) |
---|
4406 | (when target |
---|
4407 | (cond |
---|
4408 | ((eq representation :unboxed-fixnum) |
---|
4409 | (emit-push-int var1) |
---|
4410 | (emit-push-int arg2) |
---|
4411 | (emit 'iadd)) |
---|
4412 | (t |
---|
4413 | (emit 'iload (variable-register var1)) |
---|
4414 | (emit 'i2l) |
---|
4415 | (emit 'iload (variable-register var2)) |
---|
4416 | (emit 'i2l) |
---|
4417 | (emit 'ladd) |
---|
4418 | (emit-box-long))) |
---|
4419 | (emit-move-from-stack target representation))) |
---|
4420 | ((and var1 (fixnump arg2)) |
---|
4421 | (dformat t "compile-plus case 2~%") |
---|
4422 | (aver (variable-register var1)) |
---|
4423 | (cond |
---|
4424 | ((eq representation :unboxed-fixnum) |
---|
4425 | (emit-push-int var1) |
---|
4426 | (emit-push-int arg2) |
---|
4427 | (emit 'iadd)) |
---|
4428 | (t |
---|
4429 | (emit-push-int var1) |
---|
4430 | (emit 'i2l) |
---|
4431 | (emit-push-int arg2) |
---|
4432 | (emit 'i2l) |
---|
4433 | (emit 'ladd) |
---|
4434 | (emit-box-long))) |
---|
4435 | (emit-move-from-stack target representation)) |
---|
4436 | ((and (fixnump arg1) var2) |
---|
4437 | (dformat t "compile-plus case 3~%") |
---|
4438 | (aver (variable-register var2)) |
---|
4439 | (cond |
---|
4440 | ((eq representation :unboxed-fixnum) |
---|
4441 | (emit-push-int arg1) |
---|
4442 | (emit-push-int var2) |
---|
4443 | (emit 'iadd)) |
---|
4444 | (t |
---|
4445 | (emit-push-int arg1) |
---|
4446 | (emit 'i2l) |
---|
4447 | (emit-push-int var2) |
---|
4448 | (emit 'i2l) |
---|
4449 | (emit 'ladd) |
---|
4450 | (emit-box-long))) |
---|
4451 | (emit-move-from-stack target representation)) |
---|
4452 | ((eql arg1 1) |
---|
4453 | (dformat t "compile-plus case 4~%") |
---|
4454 | (compile-form arg2 :target :stack) |
---|
4455 | (maybe-emit-clear-values arg2) |
---|
4456 | (emit-invoke-method "incr" target representation)) |
---|
4457 | ((eql arg2 1) |
---|
4458 | (dformat t "compile-plus case 5~%") |
---|
4459 | (compile-form arg1 :target :stack) |
---|
4460 | (maybe-emit-clear-values arg1) |
---|
4461 | (emit-invoke-method "incr" target representation)) |
---|
4462 | ((arg-is-fixnum-p arg1) |
---|
4463 | (dformat t "compile-plus case 6~%") |
---|
4464 | (emit-push-int arg1) |
---|
4465 | (compile-form arg2 :target :stack) |
---|
4466 | (maybe-emit-clear-values arg2) |
---|
4467 | (emit 'swap) |
---|
4468 | (emit-invokevirtual +lisp-object-class+ |
---|
4469 | "add" |
---|
4470 | "(I)Lorg/armedbear/lisp/LispObject;" |
---|
4471 | -1) |
---|
4472 | (when (eq representation :unboxed-fixnum) |
---|
4473 | (emit-unbox-fixnum)) |
---|
4474 | (emit-move-from-stack target representation)) |
---|
4475 | ((arg-is-fixnum-p arg2) |
---|
4476 | (dformat t "compile-plus case 7~%") |
---|
4477 | (compile-form arg1 :target :stack) |
---|
4478 | (maybe-emit-clear-values arg1) |
---|
4479 | (emit-push-int arg2) |
---|
4480 | (emit-invokevirtual +lisp-object-class+ |
---|
4481 | "add" |
---|
4482 | "(I)Lorg/armedbear/lisp/LispObject;" |
---|
4483 | -1) |
---|
4484 | (when (eq representation :unboxed-fixnum) |
---|
4485 | (emit-unbox-fixnum)) |
---|
4486 | (emit-move-from-stack target representation)) |
---|
4487 | (t |
---|
4488 | (dformat t "compile-plus case 8~%") |
---|
4489 | (compile-binary-operation "add" args target representation))))) |
---|
4490 | (4 |
---|
4491 | (dformat t "compile-plus case 9~%") |
---|
4492 | ;; (+ a b c) => (+ (+ a b) c) |
---|
4493 | (let ((new-form `(+ (+ ,(second form) ,(third form)) ,(fourth form)))) |
---|
4494 | (dformat t "form = ~S~%" form) |
---|
4495 | (dformat t "new-form = ~S~%" new-form) |
---|
4496 | (compile-plus new-form :target target :representation representation))) |
---|
4497 | (t |
---|
4498 | (dformat t "compile-plus case 10~%") |
---|
4499 | (compile-function-call form target representation)))) |
---|
4500 | |
---|
4501 | (defun compile-minus (form &key (target *val*) representation) |
---|
4502 | (case (length form) |
---|
4503 | (3 |
---|
4504 | (let* ((args (cdr form)) |
---|
4505 | (arg1 (first args)) |
---|
4506 | (arg2 (second args)) |
---|
4507 | (var1 (unboxed-fixnum-variable arg1)) |
---|
4508 | (var2 (unboxed-fixnum-variable arg2))) |
---|
4509 | (cond |
---|
4510 | ((and (numberp arg1) (numberp arg2)) |
---|
4511 | (compile-constant (- arg1 arg2) |
---|
4512 | :target target |
---|
4513 | :representation representation)) |
---|
4514 | ((and var1 var2) |
---|
4515 | (dformat t "compile-minus case 1~%") |
---|
4516 | (aver (variable-register var1)) |
---|
4517 | (aver (variable-register var2)) |
---|
4518 | (when target |
---|
4519 | (cond |
---|
4520 | ((eq representation :unboxed-fixnum) |
---|
4521 | (emit 'iload (variable-register var1)) |
---|
4522 | (emit 'iload (variable-register var2)) |
---|
4523 | (emit 'isub)) |
---|
4524 | (t |
---|
4525 | (emit 'iload (variable-register var1)) |
---|
4526 | (emit 'i2l) |
---|
4527 | (emit 'iload (variable-register var2)) |
---|
4528 | (emit 'i2l) |
---|
4529 | (emit 'lsub) |
---|
4530 | (emit-box-long))) |
---|
4531 | (emit-move-from-stack target representation))) |
---|
4532 | ((and var1 (fixnump arg2)) |
---|
4533 | (dformat t "compile-minus case 2~%") |
---|
4534 | (aver (variable-register var1)) |
---|
4535 | (cond |
---|
4536 | ((eq representation :unboxed-fixnum) |
---|
4537 | (emit-push-int var1) |
---|
4538 | (emit-push-int arg2) |
---|
4539 | (emit 'isub)) |
---|
4540 | (t |
---|
4541 | (emit-push-int var1) |
---|
4542 | (emit 'i2l) |
---|
4543 | (emit-push-int arg2) |
---|
4544 | (emit 'i2l) |
---|
4545 | (emit 'lsub) |
---|
4546 | (emit-box-long))) |
---|
4547 | (emit-move-from-stack target representation)) |
---|
4548 | ((and (fixnump arg1) var2) |
---|
4549 | (dformat t "compile-minus case 3~%") |
---|
4550 | (aver (variable-register var2)) |
---|
4551 | (cond |
---|
4552 | ((eq representation :unboxed-fixnum) |
---|
4553 | (emit-push-int arg1) |
---|
4554 | (emit-push-int var2) |
---|
4555 | (emit 'isub)) |
---|
4556 | (t |
---|
4557 | (emit-push-int arg1) |
---|
4558 | (emit 'i2l) |
---|
4559 | (emit-push-int var2) |
---|
4560 | (emit 'i2l) |
---|
4561 | (emit 'lsub) |
---|
4562 | (emit-box-long))) |
---|
4563 | (emit-move-from-stack target representation)) |
---|
4564 | ((eql arg2 1) |
---|
4565 | (dformat t "compile-minus case 5~%") |
---|
4566 | (compile-form arg1 :target :stack) |
---|
4567 | (maybe-emit-clear-values arg2) |
---|
4568 | (emit-invoke-method "decr" target representation)) |
---|
4569 | ((arg-is-fixnum-p arg2) |
---|
4570 | (dformat t "compile-minus case 7~%") |
---|
4571 | (compile-form arg1 :target :stack) |
---|
4572 | (maybe-emit-clear-values arg1) |
---|
4573 | (emit-push-int arg2) |
---|
4574 | (emit-invokevirtual +lisp-object-class+ |
---|
4575 | "subtract" |
---|
4576 | "(I)Lorg/armedbear/lisp/LispObject;" |
---|
4577 | -1) |
---|
4578 | (when (eq representation :unboxed-fixnum) |
---|
4579 | (emit-unbox-fixnum)) |
---|
4580 | (emit-move-from-stack target representation)) |
---|
4581 | (t |
---|
4582 | (dformat t "compile-minus case 8~%") |
---|
4583 | (compile-binary-operation "subtract" args target representation))))) |
---|
4584 | (4 |
---|
4585 | (dformat t "compile-minus case 9~%") |
---|
4586 | ;; (- a b c) => (- (- a b) c) |
---|
4587 | (let ((new-form `(- (- ,(second form) ,(third form)) ,(fourth form)))) |
---|
4588 | (dformat t "form = ~S~%" form) |
---|
4589 | (dformat t "new-form = ~S~%" new-form) |
---|
4590 | (compile-minus new-form :target target :representation representation))) |
---|
4591 | (t |
---|
4592 | (dformat t "compile-minus case 10~%") |
---|
4593 | (compile-function-call form target representation)))) |
---|
4594 | |
---|
4595 | (defun compile-schar (form &key (target *val*) representation) |
---|
4596 | (unless (= (length form) 3) |
---|
4597 | (error 'program-error |
---|
4598 | :format-control "Wrong number of arguments for ~S." |
---|
4599 | :format-arguments (list (car form)))) |
---|
4600 | (compile-form (second form) :target :stack) |
---|
4601 | (compile-form (third form) :target :stack :representation :unboxed-fixnum) |
---|
4602 | (unless (and (single-valued-p (second form)) |
---|
4603 | (single-valued-p (third form))) |
---|
4604 | (emit-clear-values)) |
---|
4605 | (emit-invokevirtual +lisp-object-class+ |
---|
4606 | "SCHAR" |
---|
4607 | "(I)Lorg/armedbear/lisp/LispObject;" |
---|
4608 | -1) |
---|
4609 | (emit-move-from-stack target)) |
---|
4610 | |
---|
4611 | (defun compile-aref (form &key (target *val*) representation) |
---|
4612 | ;; (dformat t "compile-aref form = ~S~%" form) |
---|
4613 | (unless (= (length form) 3) |
---|
4614 | (return-from compile-aref (compile-function-call form target representation))) |
---|
4615 | (compile-form (second form) :target :stack) |
---|
4616 | (compile-form (third form) :target :stack :representation :unboxed-fixnum) |
---|
4617 | (unless (and (single-valued-p (second form)) |
---|
4618 | (single-valued-p (third form))) |
---|
4619 | (emit-clear-values)) |
---|
4620 | (emit-invokevirtual +lisp-object-class+ |
---|
4621 | "AREF" |
---|
4622 | "(I)Lorg/armedbear/lisp/LispObject;" |
---|
4623 | -1) |
---|
4624 | (emit-move-from-stack target)) |
---|
4625 | |
---|
4626 | (defun compile-not/null (form &key (target *val*) representation) |
---|
4627 | (unless (= (length form) 2) |
---|
4628 | (error 'program-error |
---|
4629 | :format-control "Wrong number of arguments for ~S." |
---|
4630 | :format-arguments (list (car form)))) |
---|
4631 | (let ((arg (second form))) |
---|
4632 | ;; (dformat t "arg = ~S~%" arg) |
---|
4633 | (cond ((null arg) |
---|
4634 | (emit-push-t)) |
---|
4635 | ((and (constantp arg) (not (block-node-p arg))) |
---|
4636 | ;; (dformat t "compile-not/null constantp case~%") |
---|
4637 | (emit-push-nil)) |
---|
4638 | ((and (consp arg) |
---|
4639 | (memq (car arg) '(NOT NULL))) |
---|
4640 | (compile-form (second arg) :target :stack) |
---|
4641 | (maybe-emit-clear-values (second arg)) |
---|
4642 | (emit-push-nil) |
---|
4643 | (let ((label1 (gensym)) |
---|
4644 | (label2 (gensym))) |
---|
4645 | (emit 'if_acmpeq `,label1) |
---|
4646 | (emit-push-t) |
---|
4647 | (emit 'goto `,label2) |
---|
4648 | (emit 'label `,label1) |
---|
4649 | (emit-push-nil) |
---|
4650 | (emit 'label `,label2))) |
---|
4651 | (t |
---|
4652 | (compile-form arg :target :stack) |
---|
4653 | (maybe-emit-clear-values arg) |
---|
4654 | (emit-push-nil) |
---|
4655 | (let ((label1 (gensym)) |
---|
4656 | (label2 (gensym))) |
---|
4657 | (emit 'if_acmpeq `,label1) |
---|
4658 | (emit-push-nil) |
---|
4659 | (emit 'goto `,label2) |
---|
4660 | (emit 'label `,label1) |
---|
4661 | (emit-push-t) |
---|
4662 | (emit 'label `,label2))))) |
---|
4663 | (emit-move-from-stack target)) |
---|
4664 | |
---|
4665 | (defun compile-values (form &key (target *val*) representation) |
---|
4666 | (let ((args (cdr form))) |
---|
4667 | (case (length args) |
---|
4668 | (1 |
---|
4669 | (let ((arg (first args))) |
---|
4670 | (compile-form arg :target target) |
---|
4671 | (unless (single-valued-p arg) |
---|
4672 | (emit-clear-values)))) |
---|
4673 | (2 |
---|
4674 | (emit-push-current-thread) |
---|
4675 | (let ((arg1 (first args)) |
---|
4676 | (arg2 (second args))) |
---|
4677 | (cond ((and (eq arg1 t) |
---|
4678 | (eq arg2 t)) |
---|
4679 | (emit-push-t) |
---|
4680 | (emit 'dup)) |
---|
4681 | ((and (eq arg1 nil) |
---|
4682 | (eq arg2 nil)) |
---|
4683 | (emit-push-nil) |
---|
4684 | (emit 'dup)) |
---|
4685 | (t |
---|
4686 | (compile-form arg1 :target :stack) |
---|
4687 | (compile-form arg2 :target :stack)))) |
---|
4688 | (emit-invokevirtual +lisp-thread-class+ |
---|
4689 | "setValues" |
---|
4690 | "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" |
---|
4691 | -2) |
---|
4692 | (emit-move-from-stack target)) |
---|
4693 | (3 |
---|
4694 | (emit-push-current-thread) |
---|
4695 | (dolist (arg args) |
---|
4696 | (compile-form arg :target :stack)) |
---|
4697 | (emit-invokevirtual +lisp-thread-class+ |
---|
4698 | "setValues" |
---|
4699 | "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" |
---|
4700 | -3) |
---|
4701 | (emit-move-from-stack target)) |
---|
4702 | (t |
---|
4703 | (compile-function-call form target representation))))) |
---|
4704 | |
---|
4705 | (defun compile-special-reference (name target representation) |
---|
4706 | (emit 'getstatic |
---|
4707 | *this-class* |
---|
4708 | (declare-symbol name) |
---|
4709 | +lisp-symbol+) |
---|
4710 | (emit-push-current-thread) |
---|
4711 | (emit-invokevirtual +lisp-symbol-class+ |
---|
4712 | "symbolValue" |
---|
4713 | "(Lorg/armedbear/lisp/LispThread;)Lorg/armedbear/lisp/LispObject;" |
---|
4714 | -1) |
---|
4715 | (when (eq representation :unboxed-fixnum) |
---|
4716 | (emit-unbox-fixnum)) |
---|
4717 | (emit-move-from-stack target representation)) |
---|
4718 | |
---|
4719 | (defun compile-variable-reference (name target representation) |
---|
4720 | (dformat t "compile-variable-reference ~S~%" name) |
---|
4721 | (let ((variable (find-visible-variable name))) |
---|
4722 | (cond |
---|
4723 | ((null variable) |
---|
4724 | (when (and (special-variable-p name) |
---|
4725 | (constantp name)) |
---|
4726 | (let ((value (symbol-value name))) |
---|
4727 | (when (or (null *compile-file-truename*) |
---|
4728 | ;; FIXME File compilation doesn't support all constant |
---|
4729 | ;; types yet. |
---|
4730 | (stringp value) |
---|
4731 | (numberp value) |
---|
4732 | (packagep value)) |
---|
4733 | (compile-constant value :target target :representation representation) |
---|
4734 | (return-from compile-variable-reference)))) |
---|
4735 | (unless (special-variable-p name) |
---|
4736 | (unless (memq name *undefined-variables*) |
---|
4737 | (compiler-warn "Undefined variable ~S" name) |
---|
4738 | (push name *undefined-variables*))) |
---|
4739 | (compile-special-reference name target representation)) |
---|
4740 | ((eq (variable-representation variable) :unboxed-fixnum) |
---|
4741 | (dformat t "compile-variable-reference unboxed-fixnum case~%") |
---|
4742 | (cond |
---|
4743 | ((eq representation :unboxed-fixnum) |
---|
4744 | (aver (variable-register variable)) |
---|
4745 | (emit 'iload (variable-register variable))) |
---|
4746 | (t |
---|
4747 | (dformat t "compile-variable-reference constructing boxed fixnum for ~S~%" |
---|
4748 | name) |
---|
4749 | (emit 'new +lisp-fixnum-class+) |
---|
4750 | (emit 'dup) |
---|
4751 | (aver (variable-register variable)) |
---|
4752 | (emit 'iload (variable-register variable)) |
---|
4753 | (emit-invokespecial +lisp-fixnum-class+ "<init>" "(I)V" -2))) |
---|
4754 | (emit-move-from-stack target representation)) |
---|
4755 | (t |
---|
4756 | ;; (dformat t "compile-variable-reference name = ~S representation = ~S~%" |
---|
4757 | ;; name representation) |
---|
4758 | (dformat t "compile-variable-reference ~S closure index = ~S~%" |
---|
4759 | name (variable-closure-index variable)) |
---|
4760 | (emit 'var-ref variable target representation))))) |
---|
4761 | |
---|
4762 | (defun rewrite-setq (form) |
---|
4763 | (let ((expr (third form))) |
---|
4764 | (if (unsafe-p expr) |
---|
4765 | (let ((sym (gensym))) |
---|
4766 | (list 'LET (list (list sym expr)) (list 'SETQ (second form) sym))) |
---|
4767 | form))) |
---|
4768 | |
---|
4769 | (defun compile-setq (form &key (target *val*) representation) |
---|
4770 | ;; (dformat t "compile-setq form = ~S target = ~S representation = ~S~%" |
---|
4771 | ;; form target representation) |
---|
4772 | (unless (= (length form) 3) |
---|
4773 | (return-from compile-setq (compile-form (precompiler::precompile-setq form) |
---|
4774 | :target target))) |
---|
4775 | (let ((expansion (macroexpand (second form)))) |
---|
4776 | (unless (eq expansion (second form)) |
---|
4777 | (compile-form (list 'SETF expansion (third form))) |
---|
4778 | (return-from compile-setq))) |
---|
4779 | (let* ((name (second form)) |
---|
4780 | (value-form (third form)) |
---|
4781 | (variable (find-visible-variable name))) |
---|
4782 | (cond ((or (null variable) |
---|
4783 | (variable-special-p variable)) |
---|
4784 | (let ((new-form (rewrite-setq form))) |
---|
4785 | (when (neq new-form form) |
---|
4786 | (return-from compile-setq (compile-form (p1 new-form) :target target)))) |
---|
4787 | (emit-push-current-thread) |
---|
4788 | (emit 'getstatic |
---|
4789 | *this-class* |
---|
4790 | (declare-symbol name) |
---|
4791 | +lisp-symbol+) |
---|
4792 | (compile-form value-form :target :stack) |
---|
4793 | (maybe-emit-clear-values value-form) |
---|
4794 | (emit-invokevirtual +lisp-thread-class+ |
---|
4795 | "setSpecialVariable" |
---|
4796 | "(Lorg/armedbear/lisp/Symbol;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" |
---|
4797 | -2) |
---|
4798 | (emit-move-from-stack target)) |
---|
4799 | ((and (eq (variable-representation variable) :unboxed-fixnum) |
---|
4800 | (or (equal value-form (list '1+ (variable-name variable))) |
---|
4801 | (equal value-form (list '+ (variable-name variable) 1)) |
---|
4802 | (equal value-form (list '+ 1 (variable-name variable))))) |
---|
4803 | (dformat t "compile-setq incf unboxed-fixnum case~%") |
---|
4804 | (emit 'iinc (variable-register variable) 1) |
---|
4805 | (when target |
---|
4806 | (dformat t "compile-setq constructing boxed fixnum for ~S~%" |
---|
4807 | (variable-name variable)) |
---|
4808 | (emit 'new +lisp-fixnum-class+) |
---|
4809 | (emit 'dup) |
---|
4810 | (aver (variable-register variable)) |
---|
4811 | (emit 'iload (variable-register variable)) |
---|
4812 | (emit-invokespecial +lisp-fixnum-class+ "<init>" "(I)V" -2) |
---|
4813 | (emit-move-from-stack target))) |
---|
4814 | ((eq (variable-representation variable) :unboxed-fixnum) |
---|
4815 | (dformat t "compile-setq unboxed-fixnum case value-form = ~S~%" value-form) |
---|
4816 | (compile-form value-form :target :stack) |
---|
4817 | (maybe-emit-clear-values value-form) |
---|
4818 | (when target |
---|
4819 | (emit 'dup)) |
---|
4820 | (emit-unbox-fixnum) |
---|
4821 | (emit 'istore (variable-register variable)) |
---|
4822 | (when target |
---|
4823 | (emit-move-from-stack target)) |
---|
4824 | ) |
---|
4825 | (t |
---|
4826 | (compile-form value-form :target :stack) |
---|
4827 | (maybe-emit-clear-values value-form) |
---|
4828 | (when target |
---|
4829 | (emit 'dup)) |
---|
4830 | (emit 'var-set variable) |
---|
4831 | (when target |
---|
4832 | (when (eq representation :unboxed-fixnum) |
---|
4833 | (emit-unbox-fixnum)) |
---|
4834 | (emit-move-from-stack target)))))) |
---|
4835 | |
---|
4836 | (defun p2-the (form &key (target *val*) representation) |
---|
4837 | (compile-form (third form) :target target :representation representation)) |
---|
4838 | |
---|
4839 | (defun compile-catch (form &key (target *val*) representation) |
---|
4840 | (when (= (length form) 2) ; (catch 'foo) |
---|
4841 | (when target |
---|
4842 | (emit-push-nil) |
---|
4843 | (emit-move-from-stack target)) |
---|
4844 | (return-from compile-catch)) |
---|
4845 | (let* ((*register* *register*) |
---|
4846 | (tag-register (allocate-register)) |
---|
4847 | (label1 (gensym)) |
---|
4848 | (label2 (gensym)) |
---|
4849 | (label3 (gensym)) |
---|
4850 | (label4 (gensym)) |
---|
4851 | (label5 (gensym))) |
---|
4852 | (compile-form (second form) :target tag-register) ; Tag. |
---|
4853 | (emit-push-current-thread) |
---|
4854 | (emit 'aload tag-register) |
---|
4855 | (emit-invokevirtual +lisp-thread-class+ |
---|
4856 | "pushCatchTag" |
---|
4857 | "(Lorg/armedbear/lisp/LispObject;)V" |
---|
4858 | -2) ; Stack depth is 0. |
---|
4859 | (emit 'label label1) ; Start of protected range. |
---|
4860 | ;; Implicit PROGN. |
---|
4861 | (compile-progn-body (cddr form) target) |
---|
4862 | (emit 'label label2) ; End of protected range. |
---|
4863 | (emit 'goto label5) ; Jump over handlers. |
---|
4864 | (emit 'label label3) ; Start of handler for THROW. |
---|
4865 | ;; The Throw object is on the runtime stack. Stack depth is 1. |
---|
4866 | (emit 'dup) ; Stack depth is 2. |
---|
4867 | (emit 'getfield +lisp-throw-class+ "tag" +lisp-object+) ; Still 2. |
---|
4868 | (emit 'aload tag-register) ; Stack depth is 3. |
---|
4869 | ;; If it's not the tag we're looking for, we branch to the start of the |
---|
4870 | ;; catch-all handler, which will do a re-throw. |
---|
4871 | (emit 'if_acmpne label4) |
---|