Context Navigation

jvm.lisp @ 8627

Visit:

Last change on this file since 8627 was 8627, checked in by piso, 17 years ago
WRITE-UTF8
File size: 238.8 KB

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