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