Context Navigation

ppc2.lisp @ 1407

Visit:

Last change on this file since 1407 was 1407, checked in by gb, 16 years ago
U32/natural changes, start handling 64-bit register copies.
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 345.8 KB

Line
1	;;;--Mode: LISP; Package: CCL --
2	;;;
3	;;; Copyright (C) 1994-2001 Digitool, Inc
4	;;; This file is part of OpenMCL.
5	;;;
6	;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7	;;; License , known as the LLGPL and distributed with OpenMCL as the
8	;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL,
9	;;; which is distributed with OpenMCL as the file "LGPL". Where these
10	;;; conflict, the preamble takes precedence.
11	;;;
12	;;; OpenMCL is referenced in the preamble as the "LIBRARY."
13	;;;
14	;;; The LLGPL is also available online at
15	;;; http://opensource.franz.com/preamble.html
16
17	(eval-when (:compile-toplevel :execute)
18	(require "NXENV")
19	(require "PPCENV"))
20
21	(eval-when (:load-toplevel :execute :compile-toplevel)
22	(require "PPC-BACKEND"))
23
24	(defparameter ppc2-debug-mask 0)
25	(defconstant ppc2-debug-verbose-bit 0)
26	(defconstant ppc2-debug-vinsns-bit 1)
27	(defconstant ppc2-debug-lcells-bit 2)
28	(defparameter ppc2-target-lcell-size 0)
29	(defparameter ppc2-target-node-size 0)
30	(defparameter ppc2-target-fixnum-shift 0)
31	(defparameter ppc2-target-bits-in-word 0)
32
33
34	(defun ppc2-lookup-target-uvector-subtag (name)
35	(or (cdr (assoc name (arch::target-uvector-subtags (backend-target-arch target-backend))))
36	(nx-error "Type ~s not supported on target ~s"
37	name (backend-target-arch-name target-backend))))
38
39	(defun ppc2-target-uvector-subtag-name (subtag)
40	(or (car (rassoc subtag (arch::target-uvector-subtags (backend-target-arch target-backend))))
41	(nx-error "Subtag ~s not native on target ~s"
42	subtag (backend-target-arch-name target-backend))))
43
44	(defun ppc2-immediate-operand (x)
45	(if (eq (acode-operator x) (%nx1-operator immediate))
46	(cadr x)
47	(error "~&Bug: not an immediate: ~s" x)))
48
49	(defmacro with-ppc-p2-declarations (declsform &body body)
50	`(let* ((ppc2-tail-allow ppc2-tail-allow)
51	(ppc2-reckless ppc2-reckless)
52	(ppc2-open-code-inline ppc2-open-code-inline)
53	(ppc2-trust-declarations ppc2-trust-declarations))
54	(ppc2-decls ,declsform)
55	,@body))
56
57
58	(defmacro with-ppc-local-vinsn-macros ((segvar &optional vreg-var xfer-var) &body body)
59	(declare (ignorable xfer-var))
60	(let* ((template-name-var (gensym))
61	(template-temp (gensym))
62	(args-var (gensym))
63	(labelnum-var (gensym))
64	(retvreg-var (gensym))
65	(label-var (gensym)))
66	`(macrolet ((! (,template-name-var &rest ,args-var)
67	(let* ((,template-temp (get-vinsn-template-cell ,template-name-var (backend-p2-vinsn-templates target-backend))))
68	(unless ,template-temp
69	(warn "VINSN \"~A\" not defined" ,template-name-var))
70	`(%emit-vinsn ,',segvar ',,template-name-var (backend-p2-vinsn-templates target-backend) ,@,args-var))))
71	(macrolet ((<- (,retvreg-var)
72	`(ppc2-copy-register ,',segvar ,',vreg-var ,,retvreg-var))
73	(@ (,labelnum-var)
74	`(backend-gen-label ,',segvar ,,labelnum-var))
75	(-> (,label-var)
76	`(! jump (aref backend-labels ,,label-var)))
77	(^ (&rest branch-args)
78	`(ppc2-branch ,',segvar ,',xfer-var ,',vreg-var ,@branch-args))
79	(? (&key (class :gpr)
80	(mode :lisp))
81	(let* ((class-val
82	(ecase class
83	(:gpr hard-reg-class-gpr)
84	(:fpr hard-reg-class-fpr)
85	(:crf hard-reg-class-crf)))
86	(mode-val
87	(if (eq class :gpr)
88	(gpr-mode-name-value mode)
89	(if (eq class :fpr)
90	(if (eq mode :single-float)
91	hard-reg-class-fpr-mode-single
92	hard-reg-class-fpr-mode-double)
93	0))))
94	`(make-unwired-lreg nil
95	:class ,class-val
96	:mode ,mode-val)))
97	($ (reg &key (class :gpr) (mode :lisp))
98	(let* ((class-val
99	(ecase class
100	(:gpr hard-reg-class-gpr)
101	(:fpr hard-reg-class-fpr)
102	(:crf hard-reg-class-crf)))
103	(mode-val
104	(if (eq class :gpr)
105	(gpr-mode-name-value mode)
106	(if (eq class :fpr)
107	(if (eq mode :single-float)
108	hard-reg-class-fpr-mode-single
109	hard-reg-class-fpr-mode-double)
110	0))))
111	`(make-wired-lreg ,reg
112	:class ,class-val
113	:mode ,mode-val))))
114	,@body))))
115
116
117
118
119
120
121
122
123
124
125
126
127	(defvar ppc-current-context-annotation nil)
128	(defvar ppc2-woi nil)
129	(defvar ppc2-open-code-inline nil)
130	(defvar ppc2-register-restore-count 0)
131	(defvar ppc2-register-restore-ea nil)
132	(defvar ppc2-compiler-register-save-label nil)
133	(defvar ppc2-valid-register-annotations 0)
134	(defvar ppc2-register-annotation-types nil)
135	(defvar ppc2-register-ea-annotations nil)
136
137	(defparameter ppc2-tail-call-aliases
138	()
139	#\| '((%call-next-method . (%tail-call-next-method . 1))) \|#
140
141	)
142
143	(defvar ppc2-popreg-labels nil)
144	(defvar ppc2-popj-labels nil)
145	(defvar ppc2-valret-labels nil)
146	(defvar ppc2-nilret-labels nil)
147
148	(defvar ppc2-icode nil)
149	(defvar ppc2-undo-stack nil)
150	(defvar ppc2-undo-because nil)
151
152
153	(defvar ppc2-cur-afunc nil)
154	(defvar ppc2-vstack 0)
155	(defvar ppc2-cstack 0)
156	(defvar ppc2-undo-count 0)
157	(defvar ppc2-returning-values nil)
158	(defvar ppc2-vcells nil)
159	(defvar ppc2-fcells nil)
160	(defvar ppc2-entry-vsp-saved-p nil)
161
162	(defvar ppc2-entry-label nil)
163	(defvar ppc2-tail-label nil)
164	(defvar ppc2-tail-allow t)
165	(defvar ppc2-reckless nil)
166	(defvar ppc2-trust-declarations nil)
167	(defvar ppc2-entry-vstack nil)
168	(defvar ppc2-fixed-nargs nil)
169	(defvar ppc2-need-nargs t)
170
171	(defparameter ppc2-inhibit-register-allocation nil)
172	(defvar ppc2-record-symbols nil)
173	(defvar ppc2-recorded-symbols nil)
174
175	(defvar ppc2-result-reg ppc::arg_z)
176
177
178
179
180
181	(declaim (fixnum ppc2-vstack ppc2-cstack))
182
183
184
185
186	;;; Before any defppc2's, make the ppc2-specials vector.
187
188	(defvar ppc2-all-lcells ())
189
190
191
192
193
194	(defun ppc2-free-lcells ()
195	(without-interrupts
196	(let* ((prev (pool.data lcell-freelist)))
197	(dolist (r ppc2-all-lcells)
198	(setf (lcell-kind r) prev
199	prev r))
200	(setf (pool.data lcell-freelist) prev)
201	(setq ppc2-all-lcells nil))))
202
203	(defun ppc2-note-lcell (c)
204	(push c ppc2-all-lcells)
205	c)
206
207	(defvar ppc2-top-vstack-lcell ())
208	(defvar ppc2-bottom-vstack-lcell ())
209
210	(defun ppc2-new-lcell (kind parent width attributes info)
211	(ppc2-note-lcell (make-lcell kind parent width attributes info)))
212
213	(defun ppc2-new-vstack-lcell (kind width attributes info)
214	(setq ppc2-top-vstack-lcell (ppc2-new-lcell kind ppc2-top-vstack-lcell width attributes info)))
215
216	(defun ppc2-reserve-vstack-lcells (n)
217	(dotimes (i n) (ppc2-new-vstack-lcell :reserved ppc2-target-lcell-size 0 nil)))
218
219	(defun ppc2-vstack-mark-top ()
220	(ppc2-new-lcell :tos ppc2-top-vstack-lcell 0 0 nil))
221
222	;;; Alist mapping VARs to lcells/lregs
223	(defvar ppc2-var-cells ())
224
225	(defun ppc2-note-var-cell (var cell)
226	;(format t "~& ~s -> ~s" (var-name var) cell)
227	(push (cons var cell) ppc2-var-cells))
228
229	(defun ppc2-note-top-cell (var)
230	(ppc2-note-var-cell var ppc2-top-vstack-lcell))
231
232	(defun ppc2-lookup-var-cell (var)
233	(or (cdr (assq var ppc2-var-cells))
234	(and nil (warn "Cell not found for ~s" (var-name var)))))
235
236	(defun ppc2-collect-lcells (kind &optional (bottom ppc2-bottom-vstack-lcell) (top ppc2-top-vstack-lcell))
237	(do* ((res ())
238	(cell top (lcell-parent cell)))
239	((eq cell bottom) res)
240	(if (null cell)
241	(error "Horrible compiler bug.")
242	(if (eq (lcell-kind cell) kind)
243	(push cell res)))))
244
245
246
247
248	;;; ensure that lcell's offset matches what we expect it to.
249	;;; For bootstrapping.
250
251	(defun ppc2-ensure-lcell-offset (c expected)
252	(if c (= (calc-lcell-offset c) expected) (zerop expected)))
253
254	(defun ppc2-check-lcell-depth (&optional (context "wherever"))
255	(when (logbitp ppc2-debug-verbose-bit ppc2-debug-mask)
256	(let* ((depth (calc-lcell-depth ppc2-top-vstack-lcell)))
257	(or (= depth ppc2-vstack)
258	(warn "~a: lcell depth = ~d, vstack = ~d" context depth ppc2-vstack)))))
259
260	(defun ppc2-do-lexical-reference (seg vreg ea)
261	(when vreg
262	(with-ppc-local-vinsn-macros (seg vreg)
263	(if (memory-spec-p ea)
264	(ensuring-node-target (target vreg)
265	(progn
266	(ppc2-stack-to-register seg ea target)
267	(if (addrspec-vcell-p ea)
268	(! vcell-ref target target))))
269	(<- ea)))))
270
271	(defun ppc2-do-lexical-setq (seg vreg ea valreg)
272	(with-ppc-local-vinsn-macros (seg vreg)
273	(cond ((typep ea 'lreg)
274	(ppc2-copy-register seg ea valreg))
275	((addrspec-vcell-p ea) ; closed-over vcell
276	(ppc2-copy-register seg ppc::arg_z valreg)
277	(ppc2-stack-to-register seg ea ppc::arg_x)
278	(ppc2-copy-register seg ppc::arg_y ppc::rzero)
279	(! call-subprim-3 ppc::arg_z .SPgvset ppc::arg_x ppc::arg_y ppc::arg_z))
280	((memory-spec-p ea) ; vstack slot
281	(ppc2-register-to-stack seg valreg ea))
282	(t
283	(ppc2-copy-register seg ea valreg)))
284	(when vreg
285	(<- valreg))))
286
287	;;; ensure that next-method-var is heap-consed (if it's closed over.)
288	;;; it isn't ever setqed, is it ?
289	(defun ppc2-heap-cons-next-method-var (seg var)
290	(with-ppc-local-vinsn-macros (seg)
291	(when (eq (ash 1 $vbitclosed)
292	(logand (logior (ash 1 $vbitclosed)
293	(ash 1 $vbitcloseddownward))
294	(the fixnum (nx-var-bits var))))
295	(let* ((ea (var-ea var))
296	(arg ($ ppc::arg_z))
297	(result ($ ppc::arg_z)))
298	(ppc2-do-lexical-reference seg arg ea)
299	(ppc2-set-nargs seg 1)
300	(! ref-constant ($ ppc::fname) (backend-immediate-index (ppc2-symbol-entry-locative '%cons-magic-next-method-arg)))
301	(! call-known-symbol arg)
302	(ppc2-do-lexical-setq seg nil ea result)))))
303
304	(defun ppc2-reverse-cc (cc)
305	; NE NE EQ EQ LE GE LT GT GE LE GT LT MI PL PL MI
306	(%cdr (assq cc '((6 . 6) (7 . 7) (15 . 12) (13 . 14) (12 . 15) (14 . 13) (11 . 10) (10 . 11)))))
307
308	; NE NE EQ EQ LE GE LT GT GE LE GT LT MI PL PL MI
309	(defun ppc2-reverse-condition-keyword (k)
310	(cdr (assq k '((:ne . :ne) (:eq . :eq) (:le . :ge) (:lt . :gt) (:ge . :le) (:gt . :lt)))))
311
312
313
314
315	(defun acode-condition-to-ppc-cr-bit (cond)
316	(condition-to-ppc-cr-bit (cadr cond)))
317
318	(defun condition-to-ppc-cr-bit (cond)
319	(case cond
320	(:EQ (values ppc::ppc-eq-bit t))
321	(:NE (values ppc::ppc-eq-bit nil))
322	(:GT (values ppc::ppc-gt-bit t))
323	(:LE (values ppc::ppc-gt-bit nil))
324	(:LT (values ppc::ppc-lt-bit t))
325	(:GE (values ppc::ppc-lt-bit nil))))
326
327	;;; Generate the start and end bits for a RLWINM instruction that
328	;;; would be equivalent to to LOGANDing the constant with some value.
329	;;; Return (VALUES NIL NIL) if the constant contains more than one
330	;;; sequence of consecutive 1-bits, else bit indices.
331	;;; The caller generally wants to treat the constant as an (UNSIGNED-BYTE 32);
332	;;; since this uses LOGCOUNT and INTEGER-LENGTH to find the significant
333	;;; bits, it ensures that the constant is a (SIGNED-BYTE 32) that has
334	;;; the same least-significant 32 bits.
335	(defun ppc2-mask-bits (constant)
336	(if (< constant 0) (setq constant (logand #xffffffff constant)))
337	(if (= constant #xffffffff)
338	(values 0 31)
339	(if (zerop constant)
340	(values nil nil)
341	(let* ((signed (if (and (logbitp 31 constant)
342	(> constant 0))
343	(- constant (ash 1 32))
344	constant))
345	(count (logcount signed))
346	(len (integer-length signed))
347	(highbit (logbitp (the fixnum (1- len)) constant)))
348	(declare (fixnum count len))
349	(do* ((i 1 (1+ i))
350	(pos (- len 2) (1- pos)))
351	((= i count)
352	(let* ((start (- 32 len))
353	(end (+ count start)))
354	(declare (fixnum start end))
355	(if highbit
356	(values start (the fixnum (1- end)))
357	(values (logand 31 end)
358	(the fixnum (1- start))))))
359	(declare (fixnum i pos))
360	(unless (eq (logbitp pos constant) highbit)
361	(return (values nil nil))))))))
362
363
364	(defun ppc2-svars-for-vcells (vcells)
365	(dolist (cell vcells)
366	(rplaca cell (ensure-svar (car cell))))
367	vcells)
368
369	(defun ppc2-compile (afunc &optional lfun-maker lambda-form ppc2-record-symbols)
370	(progn
371	(when (eq lfun-maker t) (setq lfun-maker #'ppc2-xmake-function))
372	(dolist (a (afunc-inner-functions afunc))
373	(unless (afunc-lfun a)
374	(ppc2-compile a
375	(or (null lfun-maker) lfun-maker)
376	(if lambda-form
377	(afunc-lambdaform a))
378	ppc2-record-symbols))) ; always compile inner guys
379	(let* ((ppc2-cur-afunc afunc)
380	(ppc2-returning-values nil)
381	(ppc-current-context-annotation nil)
382	(ppc2-woi nil)
383	(next-lcell-id -1)
384	(ppc2-open-code-inline nil)
385	(ppc2-register-restore-count nil)
386	(ppc2-compiler-register-save-label nil)
387	(ppc2-valid-register-annotations 0)
388	(ppc2-register-ea-annotations (ppc2-make-stack 16))
389	(ppc2-register-restore-ea nil)
390	(ppc2-vstack 0)
391	(ppc2-cstack 0)
392	(ppc2-target-lcell-size (arch::target-lisp-node-size (backend-target-arch target-backend)))
393	(ppc2-target-fixnum-shift (arch::target-fixnum-shift (backend-target-arch target-backend)))
394	(ppc2-target-bits-in-word (arch::target-nbits-in-word (backend-target-arch target-backend)))
395	(ppc2-target-node-size ppc2-target-lcell-size)
396	(ppc2-all-lcells ())
397	(ppc2-top-vstack-lcell nil)
398	(ppc2-bottom-vstack-lcell (ppc2-new-vstack-lcell :bottom 0 0 nil))
399	(ppc2-var-cells nil)
400	(backend-vinsns (backend-p2-vinsn-templates target-backend))
401	(backend-node-regs ppc-node-regs)
402	(backend-node-temps ppc-temp-node-regs)
403	(available-backend-node-temps ppc-temp-node-regs)
404	(backend-imm-temps ppc-imm-regs)
405	(available-backend-imm-temps ppc-imm-regs)
406	(backend-crf-temps ppc-cr-fields)
407	(available-backend-crf-temps ppc-cr-fields)
408	(backend-fp-temps ppc-temp-fp-regs)
409	(available-backend-fp-temps ppc-temp-fp-regs)
410	(bits 0)
411	(logical-register-counter -1)
412	(backend-all-lregs ())
413
414	(ppc2-popj-labels nil)
415	(ppc2-popreg-labels nil)
416	(ppc2-valret-labels nil)
417	(ppc2-nilret-labels nil)
418	(ppc2-undo-count 0)
419	(backend-labels (ppc2-make-stack 64 target::subtag-simple-vector))
420	(ppc2-undo-stack (ppc2-make-stack 64 target::subtag-simple-vector))
421	(ppc2-undo-because (ppc2-make-stack 64))
422	(backend-immediates (ppc2-make-stack 64 target::subtag-simple-vector))
423	(ppc2-entry-label nil)
424	(ppc2-tail-label nil)
425	(ppc2-inhibit-register-allocation nil)
426	(ppc2-tail-allow t)
427	(ppc2-reckless nil)
428	(ppc2-trust-declarations t)
429	(ppc2-entry-vstack nil)
430	(ppc2-fixed-nargs nil)
431	(ppc2-need-nargs t)
432	(fname (afunc-name afunc))
433	(ppc2-entry-vsp-saved-p nil)
434	(ppc2-vcells (ppc2-svars-for-vcells (afunc-vcells afunc)))
435	(ppc2-fcells (afunc-fcells afunc))
436	ppc2-recorded-symbols)
437	(set-fill-pointer
438	backend-labels
439	(set-fill-pointer
440	ppc2-undo-stack
441	(set-fill-pointer
442	ppc2-undo-because
443	(set-fill-pointer
444	backend-immediates 0))))
445	(backend-get-next-label) ; start @ label 1, 0 is confused with NIL in compound cd
446	(with-dll-node-freelist (vinsns vinsn-freelist)
447	(unwind-protect
448	(progn
449	(setq bits (ppc2-form vinsns (make-wired-lreg ppc2-result-reg) $backend-return (afunc-acode afunc)))
450	(dotimes (i (length backend-immediates))
451	(let ((imm (aref backend-immediates i)))
452	(when (ppc2-symbol-locative-p imm) (aset backend-immediates i (car imm)))))
453	(optimize-vinsns vinsns)
454	(when (logbitp ppc2-debug-vinsns-bit ppc2-debug-mask)
455	(format t "~% vinsns for ~s (after generation)" (afunc-name afunc))
456	(do-dll-nodes (v vinsns) (format t "~&~s" v))
457	(format t "~%~%"))
458
459
460	(with-dll-node-freelist (lap-instructions lap-instruction-freelist)
461	(let* ((lap-labels nil))
462	(ppc2-expand-vinsns vinsns)
463	(if (logbitp $fbitnonnullenv (the fixnum (afunc-bits afunc)))
464	(setq bits (+ bits (ash 1 $lfbits-nonnullenv-bit))))
465	(let* ((function-debugging-info (afunc-lfun-info afunc)))
466	(when (or function-debugging-info lambda-form ppc2-record-symbols)
467	(if lambda-form (setq function-debugging-info
468	(list* 'function-lambda-expression lambda-form function-debugging-info)))
469	(if ppc2-record-symbols
470	(setq function-debugging-info (nconc (list 'function-symbol-map ppc2-recorded-symbols)
471	function-debugging-info)))
472	(setq bits (logior (ash 1 $lfbits-symmap-bit) bits))
473	(backend-new-immediate function-debugging-info)))
474	(if (or fname lambda-form ppc2-recorded-symbols)
475	(backend-new-immediate fname)
476	(setq bits (logior (ash -1 $lfbits-noname-bit) bits)))
477	(unless (afunc-parent afunc)
478	(ppc2-fixup-fwd-refs afunc))
479	(setf (afunc-all-vars afunc) nil)
480	(setf (afunc-argsword afunc) bits)
481	(let* ((regsave-label (if (typep ppc2-compiler-register-save-label 'vinsn-note)
482	(vinsn-label-info (vinsn-note-label ppc2-compiler-register-save-label))))
483	(regsave-reg (if regsave-label (- 32 ppc2-register-restore-count)))
484	(regsave-addr (if regsave-label (- ppc2-register-restore-ea))))
485	(when lfun-maker
486	(setf (afunc-lfun afunc)
487	(funcall lfun-maker
488	lap-instructions
489	lap-labels
490	backend-immediates
491	bits
492	regsave-label
493	regsave-reg
494	regsave-addr
495	(if (and fname (symbolp fname)) (symbol-name fname))))))
496	(ppc2-digest-symbols))))
497	(backend-remove-labels))))
498	afunc))
499
500	(defun ppc2-xmake-function (codeheader labels imms bits ppc-lap-regsave-label ppc-lap-regsave-reg ppc-lap-regsave-addr &optional traceback-string)
501	(let* ((lap-instructions codeheader)
502	(lap-labels labels)
503	(cross-compiling (not (eq host-backend target-backend)))
504	(numimms (length imms))
505	(function (%alloc-misc (+ numimms 2)
506	(if cross-compiling
507	target::subtag-xfunction
508	target::subtag-function))))
509	(dotimes (i numimms)
510	(setf (uvref function (1+ i)) (aref imms i)))
511	(setf (uvref function (+ numimms 1)) bits)
512	(let* ((maxpc (ppc-lap-encode-regsave-info (ppc-lap-do-labels)))
513	(traceback-size (traceback-fullwords traceback-string))
514	(prefix (arch::target-code-vector-prefix (backend-target-arch target-backend)))
515	(prefix-size (length prefix))
516	(code-vector (%alloc-misc (+ traceback-size (ash maxpc -2) prefix-size)
517	(if cross-compiling
518	target::subtag-xcode-vector
519	target::subtag-code-vector)))
520	(i prefix-size))
521	(dotimes (i prefix-size)
522	(setf (uvref code-vector i) (pop prefix)))
523	(ppc-lap-resolve-labels)
524	(do-dll-nodes (insn lap-instructions)
525	(ppc-lap-generate-instruction code-vector i insn)
526	(incf i))
527	(unless (eql 0 traceback-size)
528	(add-traceback-table code-vector i traceback-string))
529	(setf (uvref function 0) code-vector)
530	(%make-code-executable code-vector)
531	function)))
532
533
534	(defun ppc2-make-stack (size &optional (subtype target::subtag-s16-vector))
535	(make-uarray-1 subtype size t 0 nil nil nil nil t nil))
536
537	(defun ppc2-fixup-fwd-refs (afunc)
538	(dolist (f (afunc-inner-functions afunc))
539	(ppc2-fixup-fwd-refs f))
540	(let ((fwd-refs (afunc-fwd-refs afunc)))
541	(when fwd-refs
542	(let* ((v (afunc-lfun afunc))
543	(vlen (uvsize v)))
544	(declare (fixnum vlen))
545	(dolist (ref fwd-refs)
546	(let* ((ref-fun (afunc-lfun ref)))
547	(do* ((i 1 (1+ i)))
548	((= i vlen))
549	(declare (fixnum i))
550	(if (eq (%svref v i) ref)
551	(setf (%svref v i) ref-fun)))))))))
552
553	(defun ppc2-digest-symbols ()
554	(if ppc2-recorded-symbols
555	(let* ((symlist ppc2-recorded-symbols)
556	(len (length symlist))
557	(syms (make-array len))
558	(ptrs (make-array (%i+ (%i+ len len) len)))
559	(i -1)
560	(j -1))
561	(declare (fixnum i j))
562	(dolist (info symlist (progn (%rplaca symlist syms)
563	(%rplacd symlist ptrs)))
564	(flet ((label-address (note start-p sym)
565	(let* ((label (vinsn-note-label note))
566	(lap-label (if label (vinsn-label-info label))))
567	(if lap-label
568	(lap-label-address lap-label)
569	(error "Missing or bad ~s label: ~s"
570	(if start-p 'start 'end) sym)))))
571	(destructuring-bind (var sym startlab endlab) info
572	(let* ((ea (var-ea var))
573	(ea-val (ldb (byte 16 0) ea)))
574	(setf (aref ptrs (incf i)) (if (memory-spec-p ea)
575	(logior (ash ea-val 6) #o77)
576	ea-val)))
577	(setf (aref syms (incf j)) sym)
578	(setf (aref ptrs (incf i)) (label-address startlab t sym))
579	(setf (aref ptrs (incf i)) (label-address endlab nil sym))))))))
580
581	(defun ppc2-decls (decls)
582	(if (fixnump decls)
583	(locally (declare (fixnum decls))
584	(setq ppc2-tail-allow (neq 0 (%ilogand2 $decl_tailcalls decls))
585	ppc2-open-code-inline (neq 0 (%ilogand2 $decl_opencodeinline decls))
586	ppc2-reckless (neq 0 (%ilogand2 $decl_unsafe decls))
587	ppc2-trust-declarations (neq 0 (%ilogand2 $decl_trustdecls decls))))))
588
589
590	(defun %ppc2-bigger-cdr-than (x y)
591	(declare (cons x y))
592	(> (the fixnum (cdr x)) (the fixnum (cdr y))))
593
594	;;; Return an unordered list of "varsets": each var in a varset can be assigned a register
595	;;; and all vars in a varset can be assigned the same register (e.g., no scope conflicts.)
596
597	(defun ppc2-partition-vars (vars)
598	(labels ((var-weight (var)
599	(let* ((bits (nx-var-bits var)))
600	(declare (fixnum bits))
601	(if (eql 0 (logand bits (logior
602	(ash 1 $vbitpuntable)
603	(ash -1 $vbitspecial)
604	(ash 1 $vbitnoreg))))
605	(if (eql (logior (ash 1 $vbitclosed) (ash 1 $vbitsetq))
606	(logand bits (logior (ash 1 $vbitclosed) (ash 1 $vbitsetq))))
607	0
608	(%i+ (%ilogand $vrefmask bits) (%ilsr 8 (%ilogand $vsetqmask bits))))
609	0)))
610	(sum-weights (varlist)
611	(let ((sum 0))
612	(dolist (v varlist sum) (incf sum (var-weight v)))))
613	(vars-disjoint-p (v1 v2)
614	(if (eq v1 v2)
615	nil
616	(if (memq v1 (var-binding-info v2))
617	nil
618	(if (memq v2 (var-binding-info v1))
619	nil
620	t)))))
621	(setq vars (%sort-list-no-key
622	;(delete-if #'(lambda (v) (eql (var-weight v) 0)) vars)
623	(do* ((handle (cons nil vars))
624	(splice handle))
625	((null (cdr splice)) (cdr handle))
626	(declare (dynamic-extent handle) (type cons handle splice))
627	(if (eql 0 (var-weight (%car (cdr splice))))
628	(rplacd splice (%cdr (cdr splice)))
629	(setq splice (cdr splice))))
630	#'(lambda (v1 v2) (%i> (var-weight v1) (var-weight v2)))))
631	; This isn't optimal. It partitions all register-allocatable variables into sets such that
632	; 1) no variable is a member of more than one set and
633	; 2) all variables in a given set are disjoint from each other
634	; A set might have exactly one member.
635	; If a register is allocated for any member of a set, it's allocated for all members of that
636	; set.
637	(let* ((varsets nil))
638	(do* ((all vars (cdr all)))
639	((null all))
640	(let* ((var (car all)))
641	(when (dolist (already varsets t)
642	(when (memq var (car already)) (return)))
643	(let* ((varset (cons var nil)))
644	(dolist (v (cdr all))
645	(when (dolist (already varsets t)
646	(when (memq v (car already)) (return)))
647	(when (dolist (d varset t)
648	(unless (vars-disjoint-p v d) (return)))
649	(push v varset))))
650	(let* ((weight (sum-weights varset)))
651	(declare (fixnum weight))
652	(if (>= weight 3)
653	(push (cons (nreverse varset) weight) varsets)))))))
654	varsets)))
655
656	;;; Maybe globally allocate registers to symbols naming functions & variables,
657	;;; and to simple lexical variables.
658	(defun ppc2-allocate-global-registers (fcells vcells all-vars no-regs)
659	(if no-regs
660	(progn
661	(dolist (c fcells) (%rplacd c nil))
662	(dolist (c vcells) (%rplacd c nil))
663	(values 0 nil))
664	(let* ((maybe (ppc2-partition-vars all-vars)))
665	(dolist (c fcells)
666	(if (>= (the fixnum (cdr c)) 3) (push c maybe)))
667	(dolist (c vcells)
668	(if (>= (the fixnum (cdr c)) 3) (push c maybe)))
669	(do* ((things (%sort-list-no-key maybe #'%ppc2-bigger-cdr-than) (cdr things))
670	(n 0 (1+ n))
671	(regno ppc::save0 (1- regno))
672	(constant-alist ()))
673	((or (null things) (= n $numppcsaveregs))
674	(dolist (cell fcells) (%rplacd cell nil))
675	(dolist (cell vcells) (%rplacd cell nil))
676	(values n constant-alist))
677	(declare (list things)
678	(fixnum n regno))
679	(let* ((thing (car things)))
680	(if (or (memq thing fcells)
681	(memq thing vcells))
682	(push (cons thing regno) constant-alist)
683	(dolist (var (car thing))
684	(nx-set-var-bits var
685	(%ilogior (%ilogand (%ilognot $vrefmask) (nx-var-bits var))
686	regno
687	(%ilsl $vbitreg 1))))))))))
688
689
690	;;; Vpush the last N non-volatile-registers.
691	;;; Could use a STM here, especially if N is largish or optimizing for space.
692	(defun ppc2-save-nvrs (seg n)
693	(declare (fixnum n))
694	(when (> n 0)
695	(setq ppc2-compiler-register-save-label (ppc2-emit-note seg :regsave))
696	(with-ppc-local-vinsn-macros (seg)
697	(if ppc2-open-code-inline
698	(! save-nvrs-individually (- 32 n))
699	(! save-nvrs (- 32 n))))
700	(dotimes (i n)
701	(ppc2-new-vstack-lcell :regsave ppc2-target-lcell-size 0 (- ppc::save0 i)))
702	(incf ppc2-vstack (the fixnum (* n ppc2-target-node-size)))
703	(setq ppc2-register-restore-ea ppc2-vstack
704	ppc2-register-restore-count n)))
705
706
707	;;; If there are an indefinite number of args/values on the vstack,
708	;;; we have to restore from a register that matches the compiler's
709	;;; notion of the vstack depth. This can be computed by the caller
710	;;; (sum of vsp & nargs, or copy of vsp before indefinite number of
711	;;; args pushed, etc.)
712	;;; We DON'T try to compute this from the saved context, since the
713	;;; saved vsp may belong to a different stack segment. (It's cheaper
714	;;; to compute/copy than to load it, anyway.)
715
716	(defun ppc2-restore-nvrs (seg ea nregs &optional from-fp)
717	(when (null from-fp)
718	(setq from-fp ppc::vsp))
719	(when (and ea nregs)
720	(with-ppc-local-vinsn-macros (seg)
721	(let* ((first (- 32 nregs)))
722	(declare (fixnum cell first n))
723	(! restore-nvrs first from-fp (- ppc2-vstack ea))))))
724
725
726	;;; The change is to ask for a stack-consed rest var if the rest var is ignored.
727	;;; And also to pop the rest var immediately if it's ignored, rather than at the end
728	;;; of the function. That will allow calling the final function tail-recursively.
729
730
731
732	(defun ppc2-bind-lambda (seg lcells req opt rest keys auxen optsupvloc passed-in-regs lexpr &optional inherited
733	&aux (vloc 0) (numopt (%ilsl 2 (list-length (%car opt))))
734	(nkeys (list-length (%cadr keys)))
735	reg)
736	(declare (fixnum vloc))
737	(ppc2-check-lcell-depth)
738	(dolist (arg inherited)
739	(if (memq arg passed-in-regs)
740	(ppc2-set-var-ea seg arg (var-ea arg))
741	(let* ((lcell (pop lcells)))
742	(if (setq reg (ppc2-assign-register-var arg))
743	(ppc2-init-regvar seg arg reg (ppc2-vloc-ea vloc))
744	(ppc2-bind-var seg arg vloc lcell))
745	(setq vloc (%i+ vloc ppc2-target-node-size)))))
746	(dolist (arg req)
747	(if (memq arg passed-in-regs)
748	(ppc2-set-var-ea seg arg (var-ea arg))
749	(let* ((lcell (pop lcells)))
750	(if (setq reg (ppc2-assign-register-var arg))
751	(ppc2-init-regvar seg arg reg (ppc2-vloc-ea vloc))
752	(ppc2-bind-var seg arg vloc lcell))
753	(setq vloc (%i+ vloc ppc2-target-node-size)))))
754	(when opt
755	(if (ppc2-hard-opt-p opt)
756	(setq vloc (apply #'ppc2-initopt seg vloc optsupvloc lcells (nthcdr (- (length lcells) (ash numopt -2)) lcells) opt)
757	lcells (nthcdr (ash numopt -2) lcells))
758	(dolist (var (%car opt))
759	(if (memq var passed-in-regs)
760	(ppc2-set-var-ea seg var (var-ea var))
761	(let* ((lcell (pop lcells)))
762	(if (setq reg (ppc2-assign-register-var var))
763	(ppc2-init-regvar seg var reg (ppc2-vloc-ea vloc))
764	(ppc2-bind-var seg var vloc lcell))
765	(setq vloc (+ vloc ppc2-target-node-size)))))))
766	(when keys
767	(apply #'ppc2-init-keys seg vloc lcells keys)
768	(setq vloc (+ vloc (* 2 ppc2-target-node-size nkeys))
769	lcells (nthcdr (+ nkeys nkeys) lcells)))
770	(when rest
771	(if lexpr
772	(progn
773	(if (setq reg (ppc2-assign-register-var rest))
774	(progn
775	(ppc2-load-lexpr-address seg reg)
776	(ppc2-set-var-ea seg rest reg))
777	(with-imm-temps () ((nargs-cell :natural))
778	(ppc2-load-lexpr-address seg nargs-cell)
779	(let* ((loc ppc2-vstack))
780	(ppc2-vpush-register seg nargs-cell :reserved)
781	(ppc2-note-top-cell rest)
782	(ppc2-bind-var seg rest loc ppc2-top-vstack-lcell)))))
783	(progn
784	(if (setq reg (ppc2-assign-register-var rest))
785	(ppc2-init-regvar seg rest reg (ppc2-vloc-ea vloc))
786	(ppc2-bind-var seg rest vloc (pop lcells)))
787	(setq vloc (+ vloc ppc2-target-node-size)))))
788	(ppc2-seq-bind seg (%car auxen) (%cadr auxen)))
789
790	(defun ppc2-initopt (seg vloc spvloc lcells splcells vars inits spvars)
791	(with-ppc-local-vinsn-macros (seg)
792	(dolist (var vars vloc)
793	(let* ((initform (pop inits))
794	(spvar (pop spvars))
795	(lcell (pop lcells))
796	(splcell (pop splcells))
797	(reg (ppc2-assign-register-var var))
798	(sp-reg ($ ppc::arg_z))
799	(regloadedlabel (if reg (backend-get-next-label))))
800	(unless (nx-null initform)
801	(ppc2-stack-to-register seg (ppc2-vloc-ea spvloc) sp-reg)
802	(let ((skipinitlabel (backend-get-next-label)))
803	(with-crf-target () crf
804	(ppc2-compare-register-to-nil seg crf (ppc2-make-compound-cd 0 skipinitlabel) sp-reg ppc::ppc-eq-bit t))
805	(if reg
806	(ppc2-form seg reg regloadedlabel initform)
807	(ppc2-register-to-stack seg (ppc2-one-untargeted-reg-form seg initform ($ ppc::arg_z)) (ppc2-vloc-ea vloc)))
808	(@ skipinitlabel)))
809	(if reg
810	(progn
811	(ppc2-init-regvar seg var reg (ppc2-vloc-ea vloc))
812	(@ regloadedlabel))
813	(ppc2-bind-var seg var vloc lcell))
814	(when spvar
815	(if (setq reg (ppc2-assign-register-var spvar))
816	(ppc2-init-regvar seg spvar reg (ppc2-vloc-ea spvloc))
817	(ppc2-bind-var seg spvar spvloc splcell))))
818	(setq vloc (%i+ vloc ppc2-target-node-size))
819	(if spvloc (setq spvloc (%i+ spvloc ppc2-target-node-size))))))
820
821	(defun ppc2-init-keys (seg vloc lcells allow-others keyvars keysupp keyinits keykeys)
822	(declare (ignore keykeys allow-others))
823	(with-ppc-local-vinsn-macros (seg)
824	(dolist (var keyvars)
825	(let* ((spvar (pop keysupp))
826	(initform (pop keyinits))
827	(reg (ppc2-assign-register-var var))
828	(regloadedlabel (if reg (backend-get-next-label)))
829	(var-lcell (pop lcells))
830	(sp-lcell (pop lcells))
831	(sp-reg ($ ppc::arg_z))
832	(sploc (%i+ vloc 4)))
833	(unless (nx-null initform)
834	(ppc2-stack-to-register seg (ppc2-vloc-ea sploc) sp-reg)
835	(let ((skipinitlabel (backend-get-next-label)))
836	(with-crf-target () crf
837	(ppc2-compare-register-to-nil seg crf (ppc2-make-compound-cd 0 skipinitlabel) sp-reg ppc::ppc-eq-bit t))
838	(if reg
839	(ppc2-form seg reg regloadedlabel initform)
840	(ppc2-register-to-stack seg (ppc2-one-untargeted-reg-form seg initform ($ ppc::arg_z)) (ppc2-vloc-ea vloc)))
841	(@ skipinitlabel)))
842	(if reg
843	(progn
844	(ppc2-init-regvar seg var reg (ppc2-vloc-ea vloc))
845	(@ regloadedlabel))
846	(ppc2-bind-var seg var vloc var-lcell))
847	(when spvar
848	(if (setq reg (ppc2-assign-register-var spvar))
849	(ppc2-init-regvar seg spvar reg (ppc2-vloc-ea sploc))
850	(ppc2-bind-var seg spvar sploc sp-lcell))))
851	(setq vloc (%i+ vloc 8)))))
852
853	;;; Vpush register r, unless var gets a globally-assigned register.
854	;;; Return NIL if register was vpushed, else var.
855	(defun ppc2-vpush-arg-register (seg reg var)
856	(when var
857	(let* ((bits (nx-var-bits var)))
858	(declare (fixnum bits))
859	(if (logbitp $vbitreg bits)
860	var
861	(progn
862	(ppc2-vpush-register seg reg :reserved)
863	nil)))))
864
865
866	;;; nargs has been validated, arguments defaulted and canonicalized.
867	;;; Save caller's context, then vpush any argument registers that
868	;;; didn't get global registers assigned to their variables.
869	;;; Return a list of vars/nils for each argument register
870	;;; (nil if vpushed, var if still in arg_reg).
871	(defun ppc2-argregs-entry (seg revargs)
872	(with-ppc-local-vinsn-macros (seg)
873	(let* ((nargs (length revargs))
874	(reg-vars ()))
875	(declare (type (unsigned-byte 16) nargs))
876	(! save-lr)
877	(if (<= nargs $numppcargregs) ; caller didn't vpush anything
878	(if ppc2-open-code-inline
879	(! save-lisp-context-vsp)
880	(! save-lisp-context-vsp-ool))
881	(let* ((offset (ash (the fixnum (- nargs $numppcargregs)) 2)))
882	(declare (fixnum offset))
883	(if ppc2-open-code-inline
884	(! save-lisp-context-offset offset)
885	(! save-lisp-context-offset-ool offset))))
886	(destructuring-bind (&optional zvar yvar xvar &rest stack-args) revargs
887	(let* ((nstackargs (length stack-args)))
888	(ppc2-set-vstack (* nstackargs ppc2-target-node-size))
889	(dotimes (i nstackargs)
890	(ppc2-new-vstack-lcell :reserved ppc2-target-lcell-size 0 nil))
891	(if (>= nargs 3)
892	(push (ppc2-vpush-arg-register seg ($ ppc::arg_x) xvar) reg-vars))
893	(if (>= nargs 2)
894	(push (ppc2-vpush-arg-register seg ($ ppc::arg_y) yvar) reg-vars))
895	(if (>= nargs 1)
896	(push (ppc2-vpush-arg-register seg ($ ppc::arg_z) zvar) reg-vars))))
897	reg-vars)))
898
899	;;; Just required args.
900	;;; Since this is just a stupid bootstrapping port, always save
901	;;; lisp context.
902	(defun ppc2-req-nargs-entry (seg rev-fixed-args)
903	(let* ((nargs (length rev-fixed-args)))
904	(declare (type (unsigned-byte 16) nargs))
905	(with-ppc-local-vinsn-macros (seg)
906	(unless ppc2-reckless
907	(! check-exact-nargs nargs))
908	(ppc2-argregs-entry seg rev-fixed-args))))
909
910	;;; No more than three &optional args; all default to NIL and none have
911	;;; supplied-p vars. No &key/&rest.
912	(defun ppc2-simple-opt-entry (seg rev-opt-args rev-req-args)
913	(let* ((min (length rev-req-args))
914	(nopt (length rev-opt-args))
915	(max (+ min nopt)))
916	(declare (type (unsigned-byte 16) min nopt max))
917	(with-ppc-local-vinsn-macros (seg)
918	(unless ppc2-reckless
919	(when rev-req-args
920	(! check-min-nargs min))
921	(! check-max-nargs max))
922	(if (= nopt 1)
923	(! default-1-arg min)
924	(if (= nopt 2)
925	(! default-2-args min)
926	(! default-3-args min)))
927	(ppc2-argregs-entry seg (append rev-opt-args rev-req-args)))))
928
929	;;; if "num-fixed" is > 0, we've already ensured that at least that many args
930	;;; were provided; that may enable us to generate better code for saving the
931	;;; argument registers.
932	;;; We're responsible for computing the caller's VSP and saving
933	;;; caller's state.
934	(defun ppc2-lexpr-entry (seg num-fixed)
935	(with-ppc-local-vinsn-macros (seg)
936	(! save-lexpr-argregs num-fixed)
937	(dotimes (i num-fixed)
938	(! copy-lexpr-argument))
939	(! save-lisp-context-lexpr)))
940
941	(defun ppc2-load-lexpr-address (seg dest)
942	(with-ppc-local-vinsn-macros (seg)
943	(! load-vframe-address dest ppc2-vstack)))
944
945
946	(defun ppc2-structured-initopt (seg lcells vloc context vars inits spvars)
947	(with-ppc-local-vinsn-macros (seg)
948	(dolist (var vars vloc)
949	(let* ((initform (pop inits))
950	(spvar (pop spvars))
951	(spvloc (%i+ vloc 4))
952	(var-lcell (pop lcells))
953	(sp-reg ($ ppc::arg_z))
954	(sp-lcell (pop lcells)))
955	(unless (nx-null initform)
956	(ppc2-stack-to-register seg (ppc2-vloc-ea spvloc) sp-reg)
957	(let ((skipinitlabel (backend-get-next-label)))
958	(with-crf-target () crf
959	(ppc2-compare-register-to-nil seg crf (ppc2-make-compound-cd 0 skipinitlabel) sp-reg ppc::ppc-eq-bit t))
960	(ppc2-register-to-stack seg (ppc2-one-untargeted-reg-form seg initform ($ ppc::arg_z)) (ppc2-vloc-ea vloc))
961	(@ skipinitlabel)))
962	(ppc2-bind-structured-var seg var vloc var-lcell context)
963	(when spvar
964	(ppc2-bind-var seg spvar spvloc sp-lcell)))
965	(setq vloc (%i+ vloc 8)))))
966
967
968
969	(defun ppc2-structured-init-keys (seg lcells vloc context allow-others keyvars keysupp keyinits keykeys)
970	(declare (ignore keykeys allow-others))
971	(with-ppc-local-vinsn-macros (seg)
972	(dolist (var keyvars)
973	(let* ((spvar (pop keysupp))
974	(initform (pop keyinits))
975	(sploc (%i+ vloc 4))
976	(var-lcell (pop lcells))
977	(sp-reg ($ ppc::arg_z))
978	(sp-lcell (pop lcells)))
979	(unless (nx-null initform)
980	(ppc2-stack-to-register seg (ppc2-vloc-ea sploc) sp-reg)
981	(let ((skipinitlabel (backend-get-next-label)))
982	(with-crf-target () crf
983	(ppc2-compare-register-to-nil seg crf (ppc2-make-compound-cd 0 skipinitlabel) sp-reg ppc::ppc-eq-bit t))
984	(ppc2-register-to-stack seg (ppc2-one-untargeted-reg-form seg initform ($ ppc::arg_z)) (ppc2-vloc-ea vloc))
985	(@ skipinitlabel)))
986	(ppc2-bind-structured-var seg var vloc var-lcell context)
987	(when spvar
988	(ppc2-bind-var seg spvar sploc sp-lcell)))
989	(setq vloc (%i+ vloc 8)))))
990
991	(defun ppc2-vloc-ea (n &optional vcell-p)
992	(setq n (make-memory-spec (dpb memspec-frame-address memspec-type-byte n)))
993	(if vcell-p
994	(make-vcell-memory-spec n)
995	n))
996
997
998	(defun ppc2-form (seg vreg xfer form)
999	(if (nx-null form)
1000	(ppc2-nil seg vreg xfer)
1001	(if (nx-t form)
1002	(ppc2-t seg vreg xfer)
1003	(let* ((op nil)
1004	(fn nil))
1005	(if (and (consp form)
1006	(setq fn (svref ppc2-specials (%ilogand #.operator-id-mask (setq op (acode-operator form))))))
1007	(if (and (null vreg)
1008	(%ilogbitp operator-acode-subforms-bit op)
1009	(%ilogbitp operator-assignment-free-bit op))
1010	(dolist (f (%cdr form) (ppc2-branch seg xfer nil))
1011	(ppc2-form seg nil nil f ))
1012	(apply fn seg vreg xfer (%cdr form)))
1013	(error "ppc2-form ? ~s" form))))))
1014
1015	;;; dest is a float reg - form is acode
1016	(defun ppc2-form-float (seg freg xfer form)
1017	(declare (ignore xfer))
1018	(when (or (nx-null form)(nx-t form))(error "ppc2-form to freg ~s" form))
1019	(when (and (= (get-regspec-mode freg) hard-reg-class-fpr-mode-double)
1020	(ppc2-form-typep form 'double-float))
1021	; kind of screwy - encoding the source type in the dest register spec
1022	(set-node-regspec-type-modes freg hard-reg-class-fpr-type-double))
1023	(let* ((fn nil))
1024	(if (and (consp form)
1025	(setq fn (svref ppc2-specials (%ilogand #.operator-id-mask (acode-operator form)))))
1026	(apply fn seg freg nil (%cdr form))
1027	(error "ppc2-form ? ~s" form))))
1028
1029
1030
1031	(defun ppc2-form-typep (form type)
1032	(acode-form-typep form type ppc2-trust-declarations)
1033	)
1034
1035	(defun ppc2-form-type (form)
1036	(acode-form-type form ppc2-trust-declarations))
1037
1038	(defun ppc2-use-operator (op seg vreg xfer &rest forms)
1039	(declare (dynamic-extent forms))
1040	(apply (svref ppc2-specials (%ilogand operator-id-mask op)) seg vreg xfer forms))
1041
1042	;;; Returns true iff lexical variable VAR isn't setq'ed in FORM.
1043	;;; Punts a lot ...
1044	(defun ppc2-var-not-set-by-form-p (var form)
1045	(or (not (%ilogbitp $vbitsetq (nx-var-bits var)))
1046	(ppc2-setqed-var-not-set-by-form-p var form)))
1047
1048	(defun ppc2-setqed-var-not-set-by-form-p (var form)
1049	(setq form (acode-unwrapped-form form))
1050	(or (atom form)
1051	(ppc-constant-form-p form)
1052	(ppc2-lexical-reference-p form)
1053	(let ((op (acode-operator form))
1054	(subforms nil))
1055	(if (eq op (%nx1-operator setq-lexical))
1056	(and (neq var (cadr form))
1057	(ppc2-setqed-var-not-set-by-form-p var (caddr form)))
1058	(and (%ilogbitp operator-side-effect-free-bit op)
1059	(flet ((not-set-in-formlist (formlist)
1060	(dolist (subform formlist t)
1061	(unless (ppc2-setqed-var-not-set-by-form-p var subform) (return)))))
1062	(if
1063	(cond ((%ilogbitp operator-acode-subforms-bit op) (setq subforms (%cdr form)))
1064	((%ilogbitp operator-acode-list-bit op) (setq subforms (cadr form))))
1065	(not-set-in-formlist subforms)
1066	(and (or (eq op (%nx1-operator call))
1067	(eq op (%nx1-operator lexical-function-call)))
1068	(ppc2-setqed-var-not-set-by-form-p var (cadr form))
1069	(setq subforms (caddr form))
1070	(not-set-in-formlist (car subforms))
1071	(not-set-in-formlist (cadr subforms))))))))))
1072
1073	(defun ppc2-nil (seg vreg xfer)
1074	(with-ppc-local-vinsn-macros (seg vreg xfer)
1075	(if (ppc2-for-value-p vreg)
1076	(ensuring-node-target (target vreg)
1077	(! load-nil target)))
1078	(ppc2-branch seg (ppc2-cd-false xfer) vreg)))
1079
1080	(defun ppc2-t (seg vreg xfer)
1081	(with-ppc-local-vinsn-macros (seg vreg xfer)
1082	(if (ppc2-for-value-p vreg)
1083	(ensuring-node-target (target vreg)
1084	(! load-t target)))
1085	(ppc2-branch seg (ppc2-cd-true xfer) vreg)))
1086
1087	(defun ppc2-for-value-p (vreg)
1088	(and vreg (not (backend-crf-p vreg))))
1089
1090	(defun ppc2-mvpass (seg form &optional xfer)
1091	(with-ppc-local-vinsn-macros (seg)
1092	(ppc2-form seg ($ ppc::arg_z) (%ilogior2 (or xfer 0) $backend-mvpass-mask) form)))
1093
1094	(defun ppc2-adjust-vstack (delta)
1095	(ppc2-set-vstack (%i+ ppc2-vstack delta)))
1096
1097	(defun ppc2-set-vstack (new)
1098	(setq ppc2-vstack new))
1099
1100
1101	;;; Emit a note at the end of the segment.
1102	(defun ppc2-emit-note (seg class &rest info)
1103	(declare (dynamic-extent info))
1104	(let* ((note (make-vinsn-note class info)))
1105	(append-dll-node (vinsn-note-label note) seg)
1106	note))
1107
1108	;;; Emit a note immediately before the target vinsn.
1109	(defun ppc-prepend-note (vinsn class &rest info)
1110	(declare (dynamic-extent info))
1111	(let* ((note (make-vinsn-note class info)))
1112	(insert-dll-node-before (vinsn-note-label note) vinsn)
1113	note))
1114
1115	(defun ppc2-close-note (seg note)
1116	(let* ((end (close-vinsn-note note)))
1117	(append-dll-node (vinsn-note-label end) seg)
1118	end))
1119
1120
1121
1122
1123
1124
1125	(defun ppc2-stack-to-register (seg memspec reg)
1126	(with-ppc-local-vinsn-macros (seg)
1127	(! vframe-load reg (memspec-frame-address-offset memspec) ppc2-vstack)))
1128
1129	(defun ppc2-lcell-to-register (seg lcell reg)
1130	(with-ppc-local-vinsn-macros (seg)
1131	(! lcell-load reg lcell (ppc2-vstack-mark-top))))
1132
1133	(defun ppc2-register-to-lcell (seg reg lcell)
1134	(with-ppc-local-vinsn-macros (seg)
1135	(! lcell-store reg lcell (ppc2-vstack-mark-top))))
1136
1137	(defun ppc2-register-to-stack (seg reg memspec)
1138	(with-ppc-local-vinsn-macros (seg)
1139	(! vframe-store reg (memspec-frame-address-offset memspec) ppc2-vstack)))
1140
1141
1142	(defun ppc2-ea-open (ea)
1143	(if (and ea (not (typep ea 'lreg)) (addrspec-vcell-p ea))
1144	(make-memory-spec (memspec-frame-address-offset ea))
1145	ea))
1146
1147	(defun ppc2-set-NARGS (seg n)
1148	(if (> n call-arguments-limit)
1149	(error "~s exceeded." call-arguments-limit)
1150	(with-ppc-local-vinsn-macros (seg)
1151	(! set-nargs n))))
1152
1153	(defun ppc2-assign-register-var (v)
1154	(let ((bits (nx-var-bits v)))
1155	(when (%ilogbitp $vbitreg bits)
1156	(%ilogand bits $vrefmask))))
1157
1158	;;; Can't cross-compile this. Too bad.
1159	#+ppc32-host
1160	(defun ppc2-single-float-bits (the-sf)
1161	(uvref the-sf ppc32::single-float.value-cell))
1162
1163	#+ppc32-host
1164	(defun ppc2-double-float-bits (the-df)
1165	(values (uvref the-df ppc32::double-float.value-cell)
1166	(uvref the-df ppc32::double-float.val-low-cell)))
1167
1168	(defun ppc2-immediate (seg vreg xfer form)
1169	(with-ppc-local-vinsn-macros (seg vreg xfer)
1170	(if vreg
1171	(if (and (= (hard-regspec-class vreg) hard-reg-class-fpr)
1172	(or (and (typep form 'double-float) (= (get-regspec-mode vreg) hard-reg-class-fpr-mode-double))
1173	(and (typep form 'short-float)(= (get-regspec-mode vreg) hard-reg-class-fpr-mode-single))))
1174	(if (zerop form)
1175	(if (eql form 0.0d0)
1176	(! zero-double-float-register vreg)
1177	(! zero-single-float-register vreg))
1178	(if (typep form 'short-float)
1179	(let* ((bits (ppc2-single-float-bits form)))
1180	(with-imm-temps () ((bitsreg :u32))
1181	(! lri bitsreg bits)
1182	(! load-single-float-constant vreg bitsreg)))
1183	(multiple-value-bind (high low) (ppc2-double-float-bits form)
1184	(declare (integer high low))
1185	(with-imm-temps () ((highreg :u32) (lowreg :u32))
1186	(if (zerop high)
1187	(setq highreg ($ ppc::rzero))
1188	(! lri highreg high))
1189	(if (zerop low)
1190	(setq lowreg ($ ppc::rzero))
1191	(! lri lowreg low))
1192	(! load-double-float-constant vreg highreg lowreg)))))
1193	(if (and (typep form '(unsigned-byte 32))
1194	(= (hard-regspec-class vreg) hard-reg-class-gpr)
1195	(= (get-regspec-mode vreg)
1196	hard-reg-class-gpr-mode-u32))
1197	(ppc2-lri seg vreg form)
1198	(ensuring-node-target
1199	(target vreg)
1200	(if (characterp form)
1201	(! load-character-constant target (char-code form))
1202	(ppc2-store-immediate seg form target)))))
1203	(if (and (listp form) load-time-eval-token (eq (car form) load-time-eval-token))
1204	(ppc2-store-immediate seg form ($ ppc::temp0))))
1205	(^)))
1206
1207	(defun ppc2-register-constant-p (form)
1208	(and (consp form)
1209	(or (memq form ppc2-vcells)
1210	(memq form ppc2-fcells))
1211	(%cdr form)))
1212
1213	(defun ppc2-store-immediate (seg imm dest)
1214	(with-ppc-local-vinsn-macros (seg)
1215	(let* ((reg (ppc2-register-constant-p imm)))
1216	(if reg
1217	(ppc2-copy-register seg dest reg)
1218	(let* ((idx (backend-immediate-index imm)))
1219	(target-arch-case
1220	(:ppc32
1221	(if (< idx 8192)
1222	(! ref-constant dest idx)
1223	(with-imm-target () (idxreg :s32)
1224	(ppc2-lri seg idxreg (+ ppc32::misc-data-offset (ash (1+ idx) 2)))
1225	(! ref-indexed-constant dest idxreg))))
1226	(:ppc64
1227	(if (< idx 4096)
1228	(! ref-constant dest idx)
1229	(with-imm-target () (idxreg :s64)
1230	(ppc2-lri seg idxreg (+ ppc64::misc-data-offset (ash (1+ idx) 3)))
1231	(! ref-indexed-constant dest idxreg)))))))
1232	dest)))
1233
1234
1235	;;; Returns label iff form is (local-go <tag>) and can go without adjusting stack.
1236	(defun ppc2-go-label (form)
1237	(let ((current-stack (ppc2-encode-stack)))
1238	(while (and (acode-p form) (or (eq (acode-operator form) (%nx1-operator progn))
1239	(eq (acode-operator form) (%nx1-operator local-tagbody))))
1240	(setq form (caadr form)))
1241	(when (acode-p form)
1242	(let ((op (acode-operator form)))
1243	(if (and (eq op (%nx1-operator local-go))
1244	(ppc2-equal-encodings-p (%caddr (%cadr form)) current-stack))
1245	(%cadr (%cadr form))
1246	(if (and (eq op (%nx1-operator local-return-from))
1247	(nx-null (caddr form)))
1248	(let ((tagdata (car (cadr form))))
1249	(and (ppc2-equal-encodings-p (cdr tagdata) current-stack)
1250	(null (caar tagdata))
1251	(< 0 (cdar tagdata) $backend-mvpass)
1252	(cdar tagdata)))))))))
1253
1254	(defun ppc2-single-valued-form-p (form)
1255	(setq form (acode-unwrapped-form form))
1256	(or (nx-null form)
1257	(nx-t form)
1258	(if (acode-p form)
1259	(let ((op (acode-operator form)))
1260	(or (%ilogbitp operator-single-valued-bit op)
1261	(and (eql op (%nx1-operator values))
1262	(let ((values (cadr form)))
1263	(and values (null (cdr values)))))
1264	nil ; Learn about functions someday
1265	)))))
1266
1267
1268	(defun ppc2-box-s32 (seg node-dest s32-src)
1269	(with-ppc-local-vinsn-macros (seg)
1270	(if (target-arch-case
1271	(:ppc32 ppc2-open-code-inline)
1272	(:ppc64 t))
1273	(! s32->integer node-dest s32-src)
1274	(let* ((arg_z ($ ppc::arg_z))
1275	(imm0 ($ ppc::imm0 :mode :s32)))
1276	(ppc2-copy-register seg imm0 s32-src)
1277	(! call-subprim .SPmakes32)
1278	(ppc2-copy-register seg node-dest arg_z)))))
1279
1280	(defun ppc2-box-s64 (seg node-dest s64-src)
1281	(with-ppc-local-vinsn-macros (seg)
1282	(if (target-arch-case
1283	(:ppc32 (error "Bug!"))
1284	(:ppc64 ppc2-open-code-inline))
1285	(! s64->integer node-dest s64-src)
1286	(let* ((arg_z ($ ppc::arg_z))
1287	(imm0 ($ ppc::imm0 :mode :s64)))
1288	(ppc2-copy-register seg imm0 s64-src)
1289	(! call-subprim .SPmakes64)
1290	(ppc2-copy-register seg node-dest arg_z)))))
1291
1292	(defun ppc2-box-u32 (seg node-dest u32-src)
1293	(with-ppc-local-vinsn-macros (seg)
1294	(if (target-arch-case
1295	(:ppc32 ppc2-open-code-inline)
1296	(:ppc64 t))
1297	(! u32->integer node-dest u32-src)
1298	(let* ((arg_z ($ ppc::arg_z))
1299	(imm0 ($ ppc::imm0 :mode :u32)))
1300	(ppc2-copy-register seg imm0 u32-src)
1301	(! call-subprim .SPmakeu32)
1302	(ppc2-copy-register seg node-dest arg_z)))))
1303
1304	(defun ppc2-box-u64 (seg node-dest u64-src)
1305	(with-ppc-local-vinsn-macros (seg)
1306	(if (target-arch-case
1307	(:ppc32 (error "Bug!"))
1308	(:ppc64 ppc2-open-code-inline))
1309	(! u64->integer node-dest u64-src)
1310	(let* ((arg_z ($ ppc::arg_z))
1311	(imm0 ($ ppc::imm0 :mode :u64)))
1312	(ppc2-copy-register seg imm0 u64-src)
1313	(! call-subprim .SPmakeu64)
1314	(ppc2-copy-register seg node-dest arg_z)))))
1315
1316
1317	;;; safe = T means assume "vector" is miscobj, do bounds check.
1318	;;; safe = fixnum means check that subtag of vector = "safe" and do bounds check.
1319	;;; safe = nil means crash&burn.
1320	;;; This mostly knows how to reference the elements of an immediate miscobj.
1321	(defun ppc2-vref (seg vreg xfer type-keyword vector index safe)
1322	(let* ((arch (backend-target-arch target-backend))
1323	(is-node (member type-keyword (arch::target-gvector-types arch)))
1324	(is-1-bit (member type-keyword (arch::target-1-bit-ivector-types arch)))
1325	(is-8-bit (member type-keyword (arch::target-8-bit-ivector-types arch)))
1326	(is-16-bit (member type-keyword (arch::target-16-bit-ivector-types arch)))
1327	(is-32-bit (member type-keyword (arch::target-32-bit-ivector-types arch)))
1328	(is-64-bit (member type-keyword (arch::target-64-bit-ivector-types arch))))
1329
1330	(if is-node
1331	(ppc2-misc-node-ref seg vreg xfer vector index safe)
1332	(with-ppc-local-vinsn-macros (seg vreg xfer)
1333	(if (null vreg)
1334	(progn
1335	(ppc2-form seg nil nil vector)
1336	(ppc2-form seg nil xfer index))
1337	(let* ((vreg-class (hard-regspec-class vreg))
1338	(vreg-mode
1339	(if (= vreg-class hard-reg-class-gpr)
1340	(get-regspec-mode vreg)
1341	hard-reg-class-gpr-mode-invalid)))
1342	(declare (fixnum vreg-class vreg-mode))
1343	(if (and (= vreg-class hard-reg-class-fpr)
1344	(eq type-keyword :double-float-vector))
1345	(ppc2-df-vref seg vreg xfer vector index safe)
1346	(if (and (= vreg-class hard-reg-class-fpr)
1347	(eq type-keyword :single-float-vector))
1348	(ppc2-sf-vref seg vreg xfer vector index safe)
1349	(if (and (= vreg-mode hard-reg-class-gpr-mode-u32)
1350	is-32-bit
1351	(not (or (eq type-keyword :signed-32-bit-vector)
1352	(eq type-keyword :single-float-vector))))
1353	(ppc2-u32-vref seg vreg xfer vector index safe)
1354	(let* ((index-known-fixnum (acode-fixnum-form-p index))
1355	(unscaled-idx nil)
1356	(src nil))
1357	(ensuring-node-target
1358	(target vreg)
1359	(if (or safe (not index-known-fixnum))
1360	(multiple-value-setq (src unscaled-idx)
1361	(ppc2-two-untargeted-reg-forms seg vector ppc::arg_y index ppc::arg_z))
1362	(setq src (ppc2-one-untargeted-reg-form seg vector ppc::arg_z)))
1363	(when safe
1364	(if (typep safe 'fixnum)
1365	(! trap-unless-typecode= src safe))
1366	(unless index-known-fixnum
1367	(! trap-unless-fixnum unscaled-idx))
1368	(! check-misc-bound unscaled-idx src))
1369	(if is-32-bit
1370	(if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-32-bit-constant-index arch)))
1371	(cond ((eq type-keyword :single-float-vector)
1372	(! misc-ref-c-single-float 0 src index-known-fixnum)
1373	(! single->node target 0))
1374	(t
1375	(with-imm-temps () (temp)
1376	(! misc-ref-c-u32 temp src index-known-fixnum)
1377	(if (eq type-keyword :signed-32-bit-vector)
1378	(ppc2-box-s32 seg target temp)
1379	(ppc2-box-u32 seg target temp)))))
1380	(with-imm-temps
1381	() (idx-reg)
1382	(if index-known-fixnum
1383	(ppc2-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 2)))
1384	(! scale-32bit-misc-index idx-reg unscaled-idx))
1385	(cond ((eq type-keyword :single-float-vector)
1386	(! misc-ref-single-float 0 src idx-reg)
1387	(! single->node target 0))
1388	(t (with-imm-temps
1389	(idx-reg) (temp)
1390	(! misc-ref-u32 temp src idx-reg)
1391	(if (eq type-keyword :signed-32-bit-vector)
1392	(ppc2-box-s32 seg target temp)
1393	(ppc2-box-u32 seg target temp)))))))
1394	(if is-8-bit
1395	(with-imm-temps
1396	() (temp)
1397	(if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-8-bit-constant-index arch)))
1398	(! misc-ref-c-u8 temp src index-known-fixnum)
1399	(with-imm-temps
1400	() (idx-reg)
1401	(if index-known-fixnum
1402	(ppc2-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) index-known-fixnum))
1403	(! scale-8bit-misc-index idx-reg unscaled-idx))
1404	(! misc-ref-u8 temp src idx-reg)))
1405	(if (eq type-keyword :unsigned-8-bit-vector)
1406	(! u8->fixnum target temp)
1407	(if (eq type-keyword :signed-8-bit-vector)
1408	(! s8->fixnum target temp)
1409	(! u8->char target temp))))
1410	(if is-16-bit
1411	(with-imm-temps
1412	() (temp)
1413	(if (and index-known-fixnum
1414	(<= index-known-fixnum (arch::target-max-16-bit-constant-index arch)))
1415	(! misc-ref-c-u16 temp src index-known-fixnum)
1416	(with-imm-temps
1417	() (idx-reg)
1418	(if index-known-fixnum
1419	(ppc2-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 1)))
1420	(! scale-16bit-misc-index idx-reg unscaled-idx))
1421	(! misc-ref-u16 temp src idx-reg)))
1422	(if (eq type-keyword :unsigned-16-bit-vector)
1423	(! u16->fixnum target temp)
1424	(if (eq type-keyword :unsigned-16-bit-vector)
1425	(! s16->fixnum target temp)
1426	(! u8->char target temp))))
1427	;; Down to the dregs.
1428	(if is-64-bit
1429	(progn
1430	(if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-64-bit-constant-index arch)))
1431	(! misc-ref-c-double-float 0 src index-known-fixnum)
1432	(with-imm-temps
1433	() (idx-reg)
1434	(if index-known-fixnum
1435	(ppc2-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 3)))
1436	(! scale-64bit-misc-index idx-reg unscaled-idx))
1437	(! misc-ref-double-float 0 src idx-reg)))
1438	(! double->heap target 0))
1439	(progn
1440	(unless is-1-bit
1441	(nx-error "~& unsupported vector type: ~s"
1442	type-keyword))
1443	(if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-1-bit-constant-index arch)))
1444	(! misc-ref-c-bit-fixnum target src index-known-fixnum)
1445	(with-imm-temps
1446	() (word-index bitnum dest)
1447	(if index-known-fixnum
1448	(progn
1449	(ppc2-lri seg word-index (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum -5)))
1450	(ppc2-lri seg bitnum (logand index-known-fixnum #x1f)))
1451	(! scale-1bit-misc-index word-index bitnum unscaled-idx))
1452	(! misc-ref-u32 dest src word-index)
1453	(! extract-variable-bit-fixnum target dest bitnum)))))))))
1454	(^)))))))))))
1455
1456	;;; In this case, the target register is an fp reg and the vector is declared
1457	;;; do be a double-float vector. Avoid boxing the result!
1458	(defun ppc2-df-vref (seg vreg xfer vector index safe)
1459	(with-ppc-local-vinsn-macros (seg vreg xfer)
1460	(let* ((index-known-fixnum (acode-fixnum-form-p index))
1461	(arch (backend-target-arch target-backend))
1462	(src)
1463	(unscaled-idx))
1464	(if (or safe (not index-known-fixnum))
1465	(multiple-value-setq (src unscaled-idx)
1466	(ppc2-two-untargeted-reg-forms seg vector ppc::arg_y index ppc::arg_z))
1467	(setq src (ppc2-one-untargeted-reg-form seg vector ppc::arg_z)))
1468	(when safe
1469	(if (typep safe 'fixnum)
1470	(! trap-unless-typecode= src safe))
1471	(unless index-known-fixnum
1472	(! trap-unless-fixnum unscaled-idx))
1473	(! check-misc-bound unscaled-idx src))
1474	(if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-64-bit-constant-index arch)))
1475	(! misc-ref-c-double-float vreg src index-known-fixnum)
1476	(with-imm-temps () (idx-reg)
1477	(if index-known-fixnum
1478	(ppc2-absolute-natural seg idx-reg nil (+ (arch::target-misc-dfloat-offset arch) (ash index-known-fixnum 3)))
1479	(! scale-64bit-misc-index idx-reg unscaled-idx))
1480	(! misc-ref-double-float vreg src idx-reg)))
1481	(^))))
1482
1483	(defun ppc2-aset2 (seg target array i j new safe typename &optional dim0 dim1)
1484	(with-ppc-local-vinsn-macros (seg target)
1485	(let* ((i-known-fixnum (acode-fixnum-form-p i))
1486	(j-known-fixnum (acode-fixnum-form-p j))
1487	(arch (backend-target-arch target-backend))
1488	(src)
1489	(unscaled-i)
1490	(unscaled-j)
1491	(need-scale t)
1492	(constidx
1493	(and dim0 dim1 i-known-fixnum j-known-fixnum
1494	(>= i-known-fixnum 0)
1495	(>= j-known-fixnum 0)
1496	(< i-known-fixnum dim0)
1497	(< j-known-fixnum dim1)
1498	(+ (* i-known-fixnum dim1) j-known-fixnum))))
1499	(progn
1500	(if constidx
1501	(multiple-value-setq (src target)
1502	(ppc2-two-targeted-reg-forms seg array ($ ppc::arg_z) new target))
1503	(multiple-value-setq (src unscaled-i unscaled-j target)
1504	(ppc2-four-untargeted-reg-forms seg
1505	array ($ ppc::arg_x)
1506	i ($ ppc::arg_y)
1507	j ($ ppc::arg_z)
1508	new target)))
1509	(when safe
1510	(when (typep safe 'fixnum)
1511	(! trap-unless-array-header src)
1512	(! check-arrayH-rank src 2)
1513	(! check-arrayH-flags src
1514	(dpb safe ppc32::arrayh.flags-cell-subtag-byte
1515	(ash 1 $arh_simple_bit))))
1516	(unless i-known-fixnum
1517	(! trap-unless-fixnum unscaled-i))
1518	(unless j-known-fixnum
1519	(! trap-unless-fixnum unscaled-j)))
1520	(with-imm-temps () (dim1 idx-reg)
1521	(unless constidx
1522	(if safe
1523	(! check-2d-bound dim1 unscaled-i unscaled-j src)
1524	(! 2d-dim1 dim1 src))
1525	(! 2d-unscaled-index idx-reg src unscaled-i unscaled-j dim1))
1526	(with-node-temps () (v)
1527	(let* ((bias (arch::target-misc-data-offset arch)))
1528	(! array-data-vector-ref v src)
1529	(multiple-value-bind (shift limit)
1530	(case typename
1531	(:double-float-vector
1532	(setq bias (arch::target-misc-dfloat-offset arch))
1533	(values 3 (arch::target-max-64-bit-constant-index arch)))
1534	(:single-float-vector
1535	(values 2 (arch::target-max-32-bit-constant-index arch))))
1536	(when (and constidx (>= constidx limit))
1537	(ppc2-absolute-natural seg idx-reg nil (+ bias
1538	(ash constidx shift)))
1539	(setq constidx nil need-scale nil)))
1540	(case typename
1541	(:double-float-vector
1542	(if constidx
1543	(! misc-set-c-double-float target v constidx)
1544	(progn
1545	(when need-scale (! scale-64bit-misc-index idx-reg idx-reg))
1546	(! misc-set-double-float target v idx-reg))))
1547	(:single-float-vector
1548	(if constidx
1549	(! misc-set-c-single-float target v constidx)
1550	(progn
1551	(when need-scale (! scale-32bit-misc-index idx-reg idx-reg))
1552	(! misc-set-single-float target v idx-reg)))))))))))
1553	target)
1554
1555	(defun ppc2-aref2 (seg vreg xfer array i j safe typekeyword &optional dim0 dim1)
1556	(with-ppc-local-vinsn-macros (seg vreg xfer)
1557	(let* ((i-known-fixnum (acode-fixnum-form-p i))
1558	(j-known-fixnum (acode-fixnum-form-p j))
1559	(arch (backend-target-arch target-backend))
1560	(src)
1561	(need-scale t)
1562	(unscaled-i)
1563	(unscaled-j)
1564	(constidx
1565	(and dim0 dim1 i-known-fixnum j-known-fixnum
1566	(>= i-known-fixnum 0)
1567	(>= j-known-fixnum 0)
1568	(< i-known-fixnum dim0)
1569	(< j-known-fixnum dim1)
1570	(+ (* i-known-fixnum dim1) j-known-fixnum))))
1571	(if constidx
1572	(setq src (ppc2-one-targeted-reg-form seg array ($ ppc::arg_z)))
1573	(multiple-value-setq (src unscaled-i unscaled-j)
1574	(ppc2-three-untargeted-reg-forms seg
1575	array ppc::arg_x
1576	i ppc::arg_y
1577	j ppc::arg_z)))
1578	(when safe
1579	(when (typep safe 'fixnum)
1580	(! trap-unless-array-header src)
1581	(! check-arrayH-rank src 2)
1582	(! check-arrayH-flags src
1583	(dpb safe target::arrayH.flags-cell-subtag-byte
1584	(ash 1 $arh_simple_bit))))
1585	(unless i-known-fixnum
1586	(! trap-unless-fixnum unscaled-i))
1587	(unless j-known-fixnum
1588	(! trap-unless-fixnum unscaled-j)))
1589	(with-imm-temps () (dim1 idx-reg)
1590	(unless constidx
1591	(if safe
1592	(! check-2d-bound dim1 unscaled-i unscaled-j src)
1593	(! 2d-dim1 dim1 src))
1594	(! 2d-unscaled-index idx-reg src unscaled-i unscaled-j dim1))
1595	(with-node-temps () (v)
1596	(! array-data-vector-ref v src)
1597	(let* ((bias (arch::target-misc-data-offset arch)))
1598	(multiple-value-bind (shift limit)
1599	(case typekeyword
1600	(:double-float-vector
1601	(setq bias (arch::target-misc-dfloat-offset arch))
1602	(values 3 (arch::target-max-64-bit-constant-index arch)))
1603	((:single-float-vector
1604	:s32-vector
1605	:u32-vector)
1606	(values 2 (arch::target-max-32-bit-constant-index arch))))
1607	(when (and constidx (>= constidx limit))
1608	(ppc2-absolute-natural seg idx-reg nil (+ bias
1609	(ash constidx shift)))
1610	(setq constidx nil need-scale nil))))
1611	(case typekeyword
1612	(:double-float-vector
1613	(if constidx
1614	(! misc-ref-c-double-float vreg v constidx)
1615	(progn
1616	(when need-scale (! scale-64bit-misc-index idx-reg idx-reg))
1617	(! misc-ref-double-float vreg v idx-reg))))
1618	(:single-float-vector
1619	(if constidx
1620	(! misc-ref-c-single-float vreg v constidx)
1621	(progn
1622	(when need-scale (! scale-32bit-misc-index idx-reg idx-reg))
1623	(! misc-ref-single-float vreg v idx-reg)))))))
1624	(^))))
1625
1626	(defun ppc2-sf-vref (seg vreg xfer vector index safe)
1627	(with-ppc-local-vinsn-macros (seg vreg xfer)
1628	(let* ((index-known-fixnum (acode-fixnum-form-p index))
1629	(arch (backend-target-arch target-backend))
1630	(src)
1631	(unscaled-idx))
1632	(if (or safe (not index-known-fixnum))
1633	(multiple-value-setq (src unscaled-idx)
1634	(ppc2-two-untargeted-reg-forms seg vector ppc::arg_y index ppc::arg_z))
1635	(setq src (ppc2-one-untargeted-reg-form seg vector ppc::arg_z)))
1636	(when safe
1637	(if (typep safe 'fixnum)
1638	(! trap-unless-typecode= src safe))
1639	(unless index-known-fixnum
1640	(! trap-unless-fixnum unscaled-idx))
1641	(! check-misc-bound unscaled-idx src))
1642	(if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-64-bit-constant-index arch)))
1643	(! misc-ref-c-single-float vreg src index-known-fixnum)
1644	(with-imm-temps () (idx-reg)
1645	(if index-known-fixnum
1646	(ppc2-absolute-natural seg idx-reg nil (+ (arch::target-misc-dfloat-offset arch) (ash index-known-fixnum 3)))
1647	(! scale-32bit-misc-index idx-reg unscaled-idx))
1648	(! misc-ref-single-float vreg src idx-reg)))
1649	(^))))
1650
1651	;;; Vreg is of mode u32; so's the vector element. Don't box result.
1652	(defun ppc2-u32-vref (seg vreg xfer vector index safe)
1653	(with-ppc-local-vinsn-macros (seg vreg xfer)
1654	(let* ((index-known-fixnum (acode-fixnum-form-p index))
1655	(arch (backend-target-arch target-backend))
1656	(src)
1657	(unscaled-idx))
1658	(if (or safe (not index-known-fixnum))
1659	(multiple-value-setq (src unscaled-idx)
1660	(ppc2-two-untargeted-reg-forms seg vector ppc::arg_y index ppc::arg_z))
1661	(setq src (ppc2-one-untargeted-reg-form seg vector ppc::arg_z)))
1662	(when safe
1663	(if (typep safe 'fixnum)
1664	(! trap-unless-typecode= src safe))
1665	(unless index-known-fixnum
1666	(! trap-unless-fixnum unscaled-idx))
1667	(! check-misc-bound unscaled-idx src))
1668	(if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-32-bit-constant-index arch)))
1669	(! misc-ref-c-u32 vreg src index-known-fixnum)
1670	(with-imm-temps () (idx-reg)
1671	(if index-known-fixnum
1672	(ppc2-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 2)))
1673	(! scale-32bit-misc-index idx-reg unscaled-idx))
1674	(! misc-ref-u32 vreg src idx-reg)))
1675	(^))))
1676
1677	(defun ppc2-u32-vset (seg vreg xfer vector index value safe)
1678	(with-ppc-local-vinsn-macros (seg vreg xfer)
1679	(let* ((index-known-fixnum (acode-fixnum-form-p index))
1680	(arch (backend-target-arch target-backend))
1681	(src nil)
1682	(unscaled-idx nil))
1683	(with-imm-target () (target :u32)
1684	(if (or safe (not index-known-fixnum))
1685	(multiple-value-setq (src unscaled-idx target)
1686	(ppc2-three-untargeted-reg-forms seg vector ppc::arg_y index ppc::arg_z value (or vreg target)))
1687	(multiple-value-setq (src target)
1688	(ppc2-two-untargeted-reg-forms seg vector ppc::arg_y value (or vreg target))))
1689	(when safe
1690	(with-imm-temps (target) () ; Don't use target in type/bounds check
1691	(if (typep safe 'fixnum)
1692	(! trap-unless-typecode= src safe))
1693	(unless index-known-fixnum
1694	(! trap-unless-fixnum unscaled-idx))
1695	(! check-misc-bound unscaled-idx src)))
1696	(if (and index-known-fixnum
1697	(<= index-known-fixnum (arch::target-max-64-bit-constant-index arch)))
1698	(! misc-set-c-u32 target src index-known-fixnum)
1699	(with-imm-temps (target) (idx-reg)
1700	(if index-known-fixnum
1701	(ppc2-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 2)))
1702	(! scale-32bit-misc-index idx-reg unscaled-idx))
1703	(! misc-set-u32 target src idx-reg)))
1704	(<- target) ; should be a no-op in this case
1705	(^)))))
1706
1707
1708	(defun ppc2-constant-value-ok-for-type-keyword (type-keyword form)
1709	(if (and (acode-p form)
1710	(or (eq (acode-operator form) (%nx1-operator immediate))
1711	(eq (acode-operator form) (%nx1-operator fixnum))))
1712	(let* ((val (%cadr form))
1713	(typep (cond ((eq type-keyword :signed-32-bit-vector)
1714	(typep val '(signed-byte 32)))
1715	((eq type-keyword :single-float-vector)
1716	(typep val 'short-float))
1717	((eq type-keyword :double-float-vector)
1718	(typep val 'double-float))
1719	((eq type-keyword :simple-string)
1720	(typep val 'base-char))
1721	((eq type-keyword :signed-8-bit-vector)
1722	(typep val '(signed-byte 8)))
1723	((eq type-keyword :unsigned-8-bit-vector)
1724	(typep val '(unsigned-byte 8)))
1725	((eq type-keyword :signed-16-bit-vector)
1726	(typep val '(signed-byte 16)))
1727	((eq type-keyword :unsigned-16-bit-vector)
1728	(typep val '(unsigned-byte 16)))
1729	((eq type-keyword :bit-vector)
1730	(typep val 'bit)))))
1731	(if typep val))))
1732
1733	(defun ppc2-vset (seg vreg xfer type-keyword vector index value safe)
1734	(let* ((arch (backend-target-arch target-backend))
1735	(is-node (member type-keyword (arch::target-gvector-types arch)))
1736	(is-1-bit (member type-keyword (arch::target-1-bit-ivector-types arch)))
1737	(is-8-bit (member type-keyword (arch::target-8-bit-ivector-types arch)))
1738	(is-16-bit (member type-keyword (arch::target-16-bit-ivector-types arch)))
1739	(is-32-bit (member type-keyword (arch::target-32-bit-ivector-types arch)))
1740	(is-64-bit (member type-keyword (arch::target-64-bit-ivector-types arch))))
1741	(if is-node
1742	(ppc2-misc-node-set seg vreg xfer vector index value safe)
1743	(let* ((vreg-class (if vreg (hard-regspec-class vreg)))
1744	(vreg-mode
1745	(if (and vreg-class (= vreg-class hard-reg-class-gpr))
1746	(get-regspec-mode vreg)
1747	hard-reg-class-gpr-mode-invalid)))
1748	(declare (fixnum vreg-class vreg-mode))
1749	(if (and (eq type-keyword :double-float-vector)
1750	(or (null vreg) (eql vreg-class hard-reg-class-fpr)))
1751	(ppc2-df-vset seg vreg xfer vector index value safe)
1752	(if (and (eq type-keyword :single-float-vector)
1753	(or (null vreg) (eql vreg-class hard-reg-class-fpr)))
1754	(ppc2-sf-vset seg vreg xfer vector index value safe)
1755	(if (and (eq type-keyword :unsigned-32-bit-vector)
1756	(or (null vreg) (eql vreg-mode hard-reg-class-gpr-mode-u32)))
1757	(ppc2-u32-vset seg vreg xfer vector index value safe)
1758	(with-ppc-local-vinsn-macros (seg vreg xfer)
1759	(let* ((index-known-fixnum (acode-fixnum-form-p index))
1760	(constval (ppc2-constant-value-ok-for-type-keyword type-keyword value))
1761	(need-val-reg (or vreg (not constval)))
1762	(unscaled-idx nil)
1763	(idx-reg nil)
1764	(val-reg)
1765	(src nil))
1766	(if (or safe (not index-known-fixnum))
1767	(if need-val-reg
1768	(multiple-value-setq (src unscaled-idx val-reg)
1769	(ppc2-three-untargeted-reg-forms seg vector ppc::arg_x index ppc::arg_y value ppc::arg_z))
1770	(multiple-value-setq (src unscaled-idx)
1771	(ppc2-two-untargeted-reg-forms seg vector ppc::arg_y index ppc::arg_z)))
1772	(if need-val-reg
1773	(multiple-value-setq (src val-reg)
1774	(ppc2-two-untargeted-reg-forms seg vector ppc::arg_y value ppc::arg_z))
1775	(setq src (ppc2-one-untargeted-reg-form seg vector ppc::arg_z))))
1776	(when safe
1777	(if (typep safe 'fixnum)
1778	(! trap-unless-typecode= src safe))
1779	(unless index-known-fixnum
1780	(! trap-unless-fixnum unscaled-idx))
1781	(! check-misc-bound unscaled-idx src))
1782	(with-imm-temps () (temp)
1783	(cond (is-32-bit
1784	(if constval
1785	(ppc2-lri seg temp
1786	(if (typep constval 'single-float)
1787	(uvref constval 0)
1788	constval))
1789	(cond ((eq type-keyword :single-float-vector)
1790	(when safe
1791	(! trap-unless-single-float val-reg))
1792	(! single-float-bits temp val-reg))
1793	((eq type-keyword :signed-32-bit-vector)
1794	(! unbox-s32 temp val-reg))
1795	(t
1796	(! unbox-u32 temp val-reg))))
1797	(if (and index-known-fixnum
1798	(<= index-known-fixnum (arch::target-max-32-bit-constant-index arch)))
1799	(! misc-set-c-u32 temp src index-known-fixnum)
1800	(progn
1801	(setq idx-reg (make-unwired-lreg (select-imm-temp :natural)))
1802	(if index-known-fixnum
1803	(ppc2-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 2)))
1804	(! scale-32bit-misc-index idx-reg unscaled-idx))
1805	(! misc-set-u32 temp src idx-reg))))
1806	(is-8-bit
1807	(if constval
1808	(ppc2-lri seg temp (if (characterp constval) (char-code constval) constval))
1809	(if safe
1810	(cond ((eq type-keyword :simple-string)
1811	(! unbox-base-char temp val-reg))
1812	((eq type-keyword :signed-8-bit-vector)
1813	(! unbox-s8 temp val-reg))
1814	(t
1815	(! unbox-u8 temp val-reg)))
1816	(if (eq type-keyword :simple-string)
1817	(! character->code temp val-reg)
1818	(! fixnum->u32 temp val-reg))))
1819	(if (and index-known-fixnum
1820	(<= index-known-fixnum (arch::target-max-8-bit-constant-index arch)))
1821	(! misc-set-c-u8 temp src index-known-fixnum)
1822	(progn
1823	(setq idx-reg (make-unwired-lreg (select-imm-temp :natural)))
1824	(if index-known-fixnum
1825	(ppc2-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) index-known-fixnum))
1826	(! scale-8bit-misc-index idx-reg unscaled-idx))
1827	(! misc-set-u8 temp src idx-reg))))
1828	(is-16-bit
1829	(if constval
1830	(ppc2-lri seg temp (if (characterp constval) (char-code constval) constval))
1831	(if safe
1832	(cond ((eq type-keyword :signed-16-bit-vector)
1833	(! unbox-s16 temp val-reg))
1834	(t
1835	(! unbox-u16 temp val-reg)))
1836	(! fixnum->u32 temp val-reg)))
1837	(if (and index-known-fixnum
1838	(<= index-known-fixnum (arch::target-max-16-bit-constant-index arch)))
1839	(! misc-set-c-u16 temp src index-known-fixnum)
1840	(progn
1841	(setq idx-reg (make-unwired-lreg (select-imm-temp :natural)))
1842	(if index-known-fixnum
1843	(ppc2-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 1)))
1844	(! scale-16bit-misc-index idx-reg unscaled-idx))
1845	(! misc-set-u16 temp src idx-reg))))
1846	(is-64-bit
1847	(if (eq type-keyword :double-float-vector)
1848	(if safe
1849	(! get-double? 0 val-reg)
1850	(! get-double 0 val-reg)))
1851	(if (and index-known-fixnum
1852	(<= index-known-fixnum (arch::target-max-64-bit-constant-index arch)))
1853	(! misc-set-c-double-float 0 src index-known-fixnum)
1854	(progn
1855	(setq idx-reg temp)
1856	(if index-known-fixnum
1857	(ppc2-absolute-natural seg idx-reg nil (+ (arch::target-misc-dfloat-offset arch) (ash index-known-fixnum 3)))
1858	(! scale-64bit-misc-index idx-reg unscaled-idx))
1859	(! misc-set-double-float 0 src idx-reg))))
1860	(t
1861	(unless is-1-bit
1862	(nx-error "~& unsupported vector type: ~s"
1863	type-keyword))
1864	;; bit-vector case.
1865	;; It's easiest to do this when the bitnumber is
1866	;; known (and a little easier still
1867	;; if the value's known.)
1868	(if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-64-bit-constant-index arch)))
1869	(let* ((word-index (ash index-known-fixnum -5))
1870	(bit-number (logand index-known-fixnum #x1f)))
1871	(! misc-ref-c-u32 temp src word-index)
1872	(if constval
1873	(if (zerop constval)
1874	(! set-constant-ppc-bit-to-0 temp temp bit-number)
1875	(! set-constant-ppc-bit-to-1 temp temp bit-number))
1876	(with-imm-temps () (bitval)
1877	(! unbox-bit bitval val-reg)
1878	(! set-constant-ppc-bit-to-variable-value temp temp bitval bit-number)))
1879	(! misc-set-c-u32 temp src word-index))
1880	;; When the bit-number isn't known, we have to do one of the following:
1881	;; A) If the value's known:
1882	;; 1) generate a mask with a 1 in the "bitnum" bit and 0s elsewhere.
1883	;; 2) Grab the word out of the vector.
1884	;; 3) If the value's 0, do an ANDC with the mask and word, else an OR.
1885	;; B) When the value's not known:
1886	;; 1) Extract the value into PPC bit 0 of some register, trapping if value not a bit.
1887	;; 2) Shift the value right "bitnum" bits.
1888	;; 3) Generate a mask with a 1 in the "bitnum" bit and 0s elsewhere.
1889	;; 4) Reference the word, ANDC it with the mask, OR the shifted value in.
1890	(with-imm-temps () (word-index bit-number)
1891	(! scale-1bit-misc-index word-index bit-number unscaled-idx)
1892	(if constval
1893	(progn
1894	(! lri temp #x80000000)
1895	(! shift-right-variable-word bit-number temp bit-number) ; (A1)
1896	(! misc-ref-u32 temp src word-index) ; (A2)
1897	(if (zerop constval) ; (A3)
1898	(! u32logandc2 temp temp bit-number)
1899	(! u32logior temp temp bit-number)))
1900	(with-imm-temps () (bitval)
1901	(! unbox-bit-bit0 bitval val-reg) ; (B1)
1902	(! shift-right-variable-word bitval bitval bit-number) ; (B2)
1903	(! lri temp #x80000000)
1904	(! shift-right-variable-word bit-number temp bit-number) ; (B3)
1905	(! misc-ref-u32 temp src word-index)
1906	(! u32logandc2 temp temp bit-number) ; clear bit-number'th bit
1907	(! u32logior temp temp bitval))) ; (B4)
1908	(! misc-set-u32 temp src word-index))))))
1909	(when vreg (<- val-reg)))
1910	(^)))))))))
1911
1912	;;; In this case, the destination (vreg) is either an FPR or null, so
1913	;;; we can maybe avoid boxing the value.
1914	(defun ppc2-df-vset (seg vreg xfer vector index value safe)
1915	(with-ppc-local-vinsn-macros (seg vreg xfer)
1916	(let* ((index-known-fixnum (acode-fixnum-form-p index))
1917	(arch (backend-target-arch target-backend))
1918	(src nil)
1919	(unscaled-idx nil))
1920	(with-fp-target () fp-val
1921	(if (or safe (not index-known-fixnum))
1922	(multiple-value-setq (src unscaled-idx fp-val)
1923	(ppc2-three-untargeted-reg-forms seg vector ppc::arg_y index ppc::arg_z value (or vreg fp-val)))
1924	(multiple-value-setq (src fp-val)
1925	(ppc2-two-untargeted-reg-forms seg vector ppc::arg_z value (or vreg fp-val))))
1926	(when safe
1927	(if (typep safe 'fixnum)
1928	(! trap-unless-typecode= src safe))
1929	(unless index-known-fixnum
1930	(! trap-unless-fixnum unscaled-idx))
1931	(! check-misc-bound unscaled-idx src))
1932	(if (and index-known-fixnum
1933	(<= index-known-fixnum (arch::target-max-64-bit-constant-index arch)))
1934	(! misc-set-c-double-float fp-val src index-known-fixnum)
1935	(with-imm-temps () (idx-reg)
1936	(if index-known-fixnum
1937	(ppc2-absolute-natural seg idx-reg nil (+ (arch::target-misc-dfloat-offset arch) (ash index-known-fixnum 3)))
1938	(! scale-64bit-misc-index idx-reg unscaled-idx))
1939	(! misc-set-double-float fp-val src idx-reg)))
1940	(<- fp-val) ; should be a no-op in this case
1941	(^)))))
1942
1943	(defun ppc2-sf-vset (seg vreg xfer vector index value safe)
1944	(with-ppc-local-vinsn-macros (seg vreg xfer)
1945	(let* ((index-known-fixnum (acode-fixnum-form-p index))
1946	(arch (backend-target-arch target-backend))
1947	(src nil)
1948	(unscaled-idx nil))
1949	(with-fp-target () (fp-val :single-float)
1950	(if (or safe (not index-known-fixnum))
1951	(multiple-value-setq (src unscaled-idx fp-val)
1952	(ppc2-three-untargeted-reg-forms seg vector ppc::arg_y index ppc::arg_z value (or vreg fp-val)))
1953	(multiple-value-setq (src fp-val)
1954	(ppc2-two-untargeted-reg-forms seg vector ppc::arg_z value (or vreg fp-val))))
1955	(when safe
1956	(if (typep safe 'fixnum)
1957	(! trap-unless-typecode= src safe))
1958	(unless index-known-fixnum
1959	(! trap-unless-fixnum unscaled-idx))
1960	(! check-misc-bound unscaled-idx src))
1961	(if (and index-known-fixnum
1962	(<= index-known-fixnum (arch::target-max-32-bit-constant-index arch)))
1963	(! misc-set-c-single-float fp-val src index-known-fixnum)
1964	(with-imm-temps () (idx-reg)
1965	(if index-known-fixnum
1966	(ppc2-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 2)))
1967	(! scale-32bit-misc-index idx-reg unscaled-idx))
1968	(! misc-set-single-float fp-val src idx-reg)))
1969	(<- fp-val) ; should be a no-op in this case
1970	(^)))))
1971
1972
1973	(defun ppc2-tail-call-alias (immref sym &optional arglist)
1974	(let ((alias (cdr (assq sym ppc2-tail-call-aliases))))
1975	(if (and alias (or (null arglist) (eq (+ (length (car arglist)) (length (cadr arglist))) (cdr alias))))
1976	(make-acode (%nx1-operator immediate) (car alias))
1977	immref)))
1978
1979	;;; If BODY is essentially an APPLY involving an &rest arg, try to avoid
1980	;;; consing it.
1981	(defun ppc2-eliminate-&rest (body rest key-p auxen rest-values)
1982	(when (and rest (not key-p) (not (cadr auxen)) rest-values)
1983	(when (eq (logand (the fixnum (nx-var-bits rest))
1984	(logior $vsetqmask (ash -1 $vbitspecial)
1985	(ash 1 $vbitclosed) (ash 1 $vbitsetq) (ash 1 $vbitcloseddownward)))
1986	0) ; Nothing but simple references
1987	(do* ()
1988	((not (acode-p body)))
1989	(let* ((op (acode-operator body)))
1990	(if (or (eq op (%nx1-operator lexical-function-call))
1991	(eq op (%nx1-operator call)))
1992	(destructuring-bind (fn-form (stack-args reg-args) &optional spread-p) (%cdr body)
1993	(unless (and (eq spread-p t)
1994	(eq (ppc2-lexical-reference-p (%car reg-args)) rest))
1995	(return nil))
1996	(flet ((independent-of-all-values (form)
1997	(setq form (acode-unwrapped-form form))
1998	(or (ppc-constant-form-p form)
1999	(let* ((lexref (ppc2-lexical-reference-p form)))
2000	(and lexref
2001	(neq lexref rest)
2002	(dolist (val rest-values t)
2003	(unless (ppc2-var-not-set-by-form-p lexref val)
2004	(return))))))))
2005	(unless (or (eq op (%nx1-operator lexical-function-call))
2006	(independent-of-all-values fn-form))
2007	(return nil))
2008	(if (dolist (s stack-args t)
2009	(unless (independent-of-all-values s)
2010	(return nil)))
2011	(let* ((arglist (append stack-args rest-values)))
2012	(return
2013	(make-acode op
2014	fn-form
2015	(if (<= (length arglist) $numppcargregs)
2016	(list nil (reverse arglist))
2017	(list (butlast arglist $numppcargregs)
2018	(reverse (last arglist $numppcargregs))))
2019	nil)))
2020	(return nil))))
2021	(if (eq op (%nx1-operator local-block))
2022	(setq body (%cadr body))
2023	(if (and (eq op (%nx1-operator if))
2024	(eq (ppc2-lexical-reference-p (%cadr body)) rest))
2025	(setq body (%caddr body))
2026	(return nil)))))))))
2027
2028	(defun ppc2-call-fn (seg vreg xfer fn arglist spread-p)
2029	(with-ppc-local-vinsn-macros (seg vreg xfer)
2030	(when spread-p
2031	(destructuring-bind (stack-args reg-args) arglist
2032	(when (and (null (cdr reg-args))
2033	(nx-null (acode-unwrapped-form (car reg-args))))
2034	(setq spread-p nil)
2035	(let* ((nargs (length stack-args)))
2036	(declare (fixnum nargs))
2037	(if (<= nargs $numppcargregs)
2038	(setq arglist (list nil (reverse stack-args)))
2039	(setq arglist (list (butlast stack-args $numppcargregs) (reverse (last stack-args $numppcargregs)))))))))
2040	(let* ((lexref (ppc2-lexical-reference-p fn))
2041	(simple-case (or (fixnump fn)
2042	(typep fn 'lreg)
2043	(ppc2-immediate-function-p fn)
2044	(and
2045	lexref
2046	(not spread-p)
2047	(flet ((all-simple (args)
2048	(dolist (arg args t)
2049	(when (and arg (not (ppc2-var-not-set-by-form-p lexref arg)))
2050	(return)))))
2051	(and (all-simple (car arglist))
2052	(all-simple (cadr arglist))
2053	(setq fn (var-ea lexref)))))))
2054	(cstack ppc2-cstack)
2055	(top ppc2-top-vstack-lcell)
2056	(vstack ppc2-vstack))
2057	(setq xfer (or xfer 0))
2058	(when (and (eq xfer $backend-return)
2059	(eq 0 ppc2-undo-count)
2060	(acode-p fn)
2061	(eq (acode-operator fn) (%nx1-operator immediate))
2062	(symbolp (cadr fn)))
2063	(setq fn (ppc2-tail-call-alias fn (%cadr fn) arglist)))
2064
2065	(if (and (eq xfer $backend-return) (not (ppc2-tailcallok xfer)))
2066	(progn
2067	(ppc2-call-fn seg vreg $backend-mvpass fn arglist spread-p)
2068	(ppc2-set-vstack (%i+ (if simple-case 0 4) vstack))
2069	(setq ppc2-cstack cstack)
2070	(let ((ppc2-returning-values t)) (ppc2-do-return seg)))
2071	(let* ((mv-p (ppc2-mv-p xfer)))
2072	(unless simple-case
2073	(ppc2-vpush-register seg (ppc2-one-untargeted-reg-form seg fn ppc::arg_z))
2074	(setq fn (ppc2-vloc-ea vstack)))
2075	(ppc2-invoke-fn seg fn (ppc2-arglist seg arglist) spread-p xfer)
2076	(if (and (%ilogbitp $backend-mvpass-bit xfer)
2077	(not simple-case))
2078	(progn
2079	(! save-values)
2080	(! vstack-discard 1)
2081	(ppc2-set-nargs seg 0)
2082	(! recover-values))
2083	(unless (or mv-p simple-case)
2084	(! vstack-discard 1)))
2085	(ppc2-set-vstack vstack)
2086	(setq ppc2-top-vstack-lcell top)
2087	(setq ppc2-cstack cstack)
2088	(when (or (%ilogbitp $backend-mvpass-bit xfer) (not mv-p))
2089	(<- ppc::arg_z)
2090	(ppc2-branch seg (%ilogand2 (%ilognot $backend-mvpass-mask) xfer) vreg))))
2091	nil)))
2092
2093	(defun ppc2-restore-full-lisp-context (seg)
2094	(with-ppc-local-vinsn-macros (seg)
2095	(if ppc2-open-code-inline
2096	(! restore-full-lisp-context)
2097	(! restore-full-lisp-context-ool))))
2098
2099	(defun ppc2-call-symbol (seg jump-p)
2100	; fname contains a symbol; we can either call it via
2101	; a call to .SPjmpsym or expand the instructions inline.
2102	; Since the branches are unconditional, the call doesn't
2103	; cost much, but doing the instructions inline would give
2104	; an instruction scheduler some opportunities to improve
2105	; performance, so this isn't a strict time/speed tradeoff.
2106	; This should probably dispatch on something other than
2107	; ppc2-open-code-inline, since that does imply a time/speed
2108	; tradeoff.
2109	(with-ppc-local-vinsn-macros (seg)
2110	(if ppc2-open-code-inline
2111	(if jump-p
2112	(! jump-known-symbol)
2113	(! call-known-symbol ppc::arg_z))
2114	(if jump-p
2115	(! jump-known-symbol-ool)
2116	(! call-known-symbol-ool)))))
2117
2118	;;; Nargs = nil -> multiple-value case.
2119	(defun ppc2-invoke-fn (seg fn nargs spread-p xfer)
2120	(with-ppc-local-vinsn-macros (seg)
2121	(let* ((f-op (acode-unwrapped-form fn))
2122	(immp (and (consp f-op)
2123	(eq (%car f-op) (%nx1-operator immediate))))
2124	(symp (and immp (symbolp (%cadr f-op))))
2125	(label-p (and (fixnump fn)
2126	(locally (declare (fixnum fn))
2127	(and (= fn -1) (- fn)))))
2128	(tail-p (eq xfer $backend-return))
2129	(func (if (consp f-op) (%cadr f-op)))
2130	(a-reg nil)
2131	(lfunp (and (acode-p f-op)
2132	(eq (acode-operator f-op) (%nx1-operator simple-function))))
2133	(expression-p (or (typep fn 'lreg) (and (fixnump fn) (not label-p))))
2134	(callable (or symp lfunp label-p))
2135	(destreg (if symp ($ ppc::fname) (if lfunp ($ ppc::nfn) (unless label-p ($ ppc::temp0))))))
2136	(when expression-p
2137	;Have to do this before spread args, since might be vsp-relative.
2138	(if nargs
2139	(ppc2-do-lexical-reference seg destreg fn)
2140	(ppc2-copy-register seg destreg fn)))
2141	(if (or symp lfunp)
2142	(setq func (if symp (ppc2-symbol-entry-locative func)
2143	(ppc2-afunc-lfun-ref func))
2144	a-reg (ppc2-register-constant-p func)))
2145	(when tail-p
2146	#-no-compiler-bugs
2147	(unless (or immp symp lfunp (typep fn 'lreg) (fixnump fn)) (error "Well, well, well. How could this have happened ?"))
2148	(when a-reg
2149	(ppc2-copy-register seg destreg a-reg))
2150	(unless spread-p
2151	(if nargs
2152	(ppc2-restore-nvrs seg ppc2-register-restore-ea ppc2-register-restore-count)
2153	(when ppc2-register-restore-count
2154	(with-imm-temps () (vsp0)
2155	(! fixnum-add vsp0 ppc::vsp ppc::nargs)
2156	(ppc2-restore-nvrs seg ppc2-register-restore-ea ppc2-register-restore-count vsp0))))))
2157	(if spread-p
2158	(progn
2159	(ppc2-set-nargs seg (%i- nargs 1))
2160	(when (and tail-p ppc2-register-restore-count)
2161	(! copy-gpr ppc::temp1 ppc::vsp)) ; .SPspread-lexpr-z & .SPspreadargz preserve temp1
2162	(if (eq spread-p 0)
2163	(! spread-lexpr)
2164	(! spread-list))
2165	(when (and tail-p ppc2-register-restore-count)
2166	(ppc2-restore-nvrs seg ppc2-register-restore-ea ppc2-register-restore-count ppc::temp1)))
2167	(if nargs
2168	(ppc2-set-nargs seg nargs)
2169	(! pop-argument-registers)))
2170	(if callable
2171	(if (not tail-p)
2172	(if (ppc2-mvpass-p xfer)
2173	(let* ((call-reg (if symp ($ ppc::fname) ($ ppc::temp0))))
2174	(if label-p
2175	(ppc2-copy-register seg call-reg ($ ppc::fn))
2176	(if a-reg
2177	(ppc2-copy-register seg call-reg a-reg)
2178	(ppc2-store-immediate seg func call-reg)))
2179	(if symp
2180	(! pass-multiple-values-symbol)
2181	(! pass-multiple-values)))
2182	(progn
2183	(if label-p
2184	(progn
2185	(ppc2-copy-register seg ($ ppc::nfn) ($ ppc::fn))
2186	(! call-label (aref backend-labels 1)))
2187	(progn
2188	(if a-reg
2189	(ppc2-copy-register seg destreg a-reg)
2190	(ppc2-store-immediate seg func destreg))
2191	(if symp
2192	(ppc2-call-symbol seg nil)
2193	(! call-known-function))))))
2194	(progn
2195	(ppc2-unwind-stack seg xfer 0 0 #x7fffff)
2196	(if (and (not spread-p) nargs (%i<= nargs $numppcargregs))
2197	(progn
2198	(if label-p
2199	(ppc2-copy-register seg ppc::nfn ppc::fn))
2200	(unless (or label-p a-reg) (ppc2-store-immediate seg func destreg))
2201	(ppc2-restore-full-lisp-context seg)
2202	(if label-p
2203	(! jump (aref backend-labels 1))
2204	(progn
2205	(if symp
2206	(ppc2-call-symbol seg t)
2207	(! jump-known-function)))))
2208	(progn
2209	(if label-p
2210	(ppc2-copy-register seg ppc::nfn ppc::fn)
2211	(unless a-reg (ppc2-store-immediate seg func destreg)))
2212	(cond ((or spread-p (null nargs))
2213	(if symp
2214	(! tail-call-sym-gen)
2215	(! tail-call-fn-gen)))
2216	((%i> nargs $numppcargregs)
2217	(if symp
2218	(! tail-call-sym-slide)
2219	(! tail-call-fn-slide)))
2220	(t
2221	(if symp
2222	(! tail-call-sym-vsp)
2223	(! tail-call-fn-vsp))))))))
2224	;; The general (funcall) case: we don't know (at compile-time)
2225	;; for sure whether we've got a symbol or a (local, constant)
2226	;; function.
2227	(progn
2228	(unless (or (fixnump fn) (typep fn 'lreg))
2229	(ppc2-one-targeted-reg-form seg fn destreg))
2230	(if (not tail-p)
2231	(if (ppc2-mvpass-p xfer)
2232	(! pass-multiple-values)
2233	(! funcall))
2234	(cond ((or (null nargs) spread-p)
2235	(! tail-funcall-gen))
2236	((%i> nargs $numppcargregs)
2237	(! tail-funcall-slide))
2238	(t
2239	(! tail-funcall-vsp)))))))
2240	nil))
2241
2242	(defun ppc2-seq-fbind (seg vreg xfer vars afuncs body p2decls)
2243	(let* ((old-stack (ppc2-encode-stack))
2244	(copy afuncs)
2245	(func nil))
2246	(with-ppc-p2-declarations p2decls
2247	(dolist (var vars)
2248	(when (neq 0 (afunc-fn-refcount (setq func (pop afuncs))))
2249	(ppc2-seq-bind-var seg var (nx1-afunc-ref func))))
2250	(ppc2-undo-body seg vreg xfer body old-stack)
2251	(dolist (var vars)
2252	(when (neq 0 (afunc-fn-refcount (setq func (pop copy))))
2253	(ppc2-close-var seg var))))))
2254
2255	(defun ppc2-make-closure (seg afunc downward-p)
2256	(with-ppc-local-vinsn-macros (seg)
2257	(flet ((var-to-reg (var target)
2258	(let* ((ea (var-ea (var-bits var))))
2259	(if ea
2260	(ppc2-addrspec-to-reg seg (ppc2-ea-open ea) target)
2261	(! load-nil target))
2262	target))
2263	(set-some-cells (dest cellno c0 c1 c2 c3)
2264	(declare (fixnum cellno))
2265	(! misc-set-c-node c0 dest cellno)
2266	(incf cellno)
2267	(when c1
2268	(! misc-set-c-node c1 dest cellno)
2269	(incf cellno)
2270	(when c2
2271	(! misc-set-c-node c2 dest cellno)
2272	(incf cellno)
2273	(when c3
2274	(! misc-set-c-node c3 dest cellno)
2275	(incf cellno))))
2276	cellno))
2277	(let* ((inherited-vars (afunc-inherited-vars afunc))
2278	(arch (backend-target-arch target-backend))
2279	(dest ($ ppc::arg_z))
2280	(vsize (+ (length inherited-vars)
2281	2 ; %closure-code%, afunc
2282	2))) ; name, lfun-bits
2283	(declare (list inherited-vars))
2284	(if downward-p
2285	(progn
2286	(let* ((ppc2-vstack ppc2-vstack)
2287	(ppc2-top-vstack-lcell ppc2-top-vstack-lcell))
2288	(ppc2-lri seg ppc::arg_x (ash (ppc2-lookup-target-uvector-subtag :function) ppc2-target-fixnum-shift))
2289	(! %closure-code% ppc::arg_y)
2290	(ppc2-store-immediate seg (ppc2-afunc-lfun-ref afunc) ppc::arg_z)
2291	(ppc2-vpush-register-arg seg ppc::arg_x)
2292	(ppc2-vpush-register-arg seg ppc::arg_y)
2293	(ppc2-vpush-register-arg seg ppc::arg_z)
2294	; Could be smarter about memory traffic here.
2295	(dolist (v inherited-vars)
2296	(ppc2-vpush-register-arg seg (var-to-reg v ppc::arg_z)))
2297	(! load-nil ppc::arg_z)
2298	(ppc2-vpush-register-arg seg ppc::arg_z)
2299	(ppc2-lri seg ppc::arg_z (ash (ash 1 $lfbits-trampoline-bit) ppc2-target-fixnum-shift))
2300	(ppc2-vpush-register-arg seg ppc::arg_z)
2301	(ppc2-set-nargs seg (1+ vsize)) ; account for subtag
2302	(! make-stack-gvector))
2303	(ppc2-open-undo $undostkblk))
2304	(let* ((cell 0))
2305	(declare (fixnum cell))
2306	(progn
2307	(ppc2-lri seg
2308	ppc::imm0
2309	(arch::make-vheader vsize (ppc2-lookup-target-uvector-subtag :function)))
2310	(! %alloc-misc-fixed dest ppc::imm0 (ash vsize (arch::target-word-shift arch)))
2311	)
2312	(! %closure-code% ppc::arg_x)
2313	(ppc2-store-immediate seg (ppc2-afunc-lfun-ref afunc) ppc::arg_y)
2314	(with-node-temps (ppc::arg_z) (t0 t1 t2 t3)
2315	(do* ((ccode ppc::arg_x nil)
2316	(func ppc::arg_y nil))
2317	((null inherited-vars))
2318	(let* ((t0r (or ccode (if inherited-vars (var-to-reg (pop inherited-vars) t0))))
2319	(t1r (or func (if inherited-vars (var-to-reg (pop inherited-vars) t1))))
2320	(t2r (if inherited-vars (var-to-reg (pop inherited-vars) t2)))
2321	(t3r (if inherited-vars (var-to-reg (pop inherited-vars) t3))))
2322	(setq cell (set-some-cells dest cell t0r t1r t2r t3r)))))
2323	(ppc2-lri seg ppc::arg_y (ash (ash 1 $lfbits-trampoline-bit) ppc2-target-fixnum-shift))
2324	(! load-nil ppc::arg_x)
2325	(! misc-set-c-node ppc::arg_x dest cell)
2326	(! misc-set-c-node ppc::arg_y dest (1+ cell))))
2327	dest))))
2328
2329	(defun ppc2-symbol-entry-locative (sym)
2330	(setq sym (require-type sym 'symbol))
2331	(when (eq sym '%call-next-method-with-args)
2332	(setf (afunc-bits ppc2-cur-afunc)
2333	(%ilogior (%ilsl $fbitnextmethargsp 1) (afunc-bits ppc2-cur-afunc))))
2334	(or (assq sym ppc2-fcells)
2335	(let ((new (list sym)))
2336	(push new ppc2-fcells)
2337	new)))
2338
2339	(defun ppc2-symbol-value-svar (sym)
2340	(setq sym (require-type sym 'symbol))
2341	(or (dolist (cell ppc2-vcells)
2342	(when (eq sym (%svref (car cell) target::svar.symbol-cell))
2343	(return cell)))
2344	(let ((new (list (ensure-svar sym))))
2345	(push new ppc2-vcells)
2346	new)))
2347
2348	(defun ppc2-symbol-locative-p (imm)
2349	(and (consp imm)
2350	(or (memq imm ppc2-vcells)
2351	(memq imm ppc2-fcells))))
2352
2353
2354
2355
2356	(defun ppc2-immediate-function-p (f)
2357	(setq f (acode-unwrapped-form f))
2358	(and (acode-p f)
2359	(or (eq (%car f) (%nx1-operator immediate))
2360	(eq (%car f) (%nx1-operator simple-function)))))
2361
2362	(defun ppc-constant-form-p (form)
2363	(setq form (nx-untyped-form form))
2364	(if form
2365	(or (nx-null form)
2366	(nx-t form)
2367	(and (consp form)
2368	(or (eq (acode-operator form) (%nx1-operator immediate))
2369	(eq (acode-operator form) (%nx1-operator fixnum))
2370	(eq (acode-operator form) (%nx1-operator simple-function)))))))
2371
2372
2373
2374	(defun ppc2-long-constant-p (form)
2375	(setq form (acode-unwrapped-form form))
2376	(or (acode-fixnum-form-p form)
2377	(and (acode-p form)
2378	(eq (acode-operator form) (%nx1-operator immediate))
2379	(setq form (%cadr form))
2380	(if (integerp form)
2381	form
2382	(progn
2383	(if (symbolp form) (setq form (symbol-name form)))
2384	(if (and (stringp form) (eql (length form) 4))
2385	(%stack-block ((buf 4))
2386	(%put-ostype buf form)
2387	(%get-unsigned-long buf))
2388	(if (characterp form) (%char-code form))))))))
2389
2390
2391	(defun ppc-side-effect-free-form-p (form)
2392	(when (consp (setq form (acode-unwrapped-form form)))
2393	(or (ppc-constant-form-p form)
2394	;(eq (acode-operator form) (%nx1-operator bound-special-ref))
2395	(if (eq (acode-operator form) (%nx1-operator lexical-reference))
2396	(not (%ilogbitp $vbitsetq (nx-var-bits (%cadr form))))))))
2397
2398	(defun ppc2-formlist (seg stkargs &optional revregargs)
2399	(with-ppc-local-vinsn-macros (seg)
2400	(let* ((nregs (length revregargs))
2401	(n nregs))
2402	(declare (fixnum n))
2403	(dolist (arg stkargs)
2404	(let* ((reg (ppc2-one-untargeted-reg-form seg arg ppc::arg_z)))
2405	(ppc2-vpush-register-arg seg reg)
2406	(incf n)))
2407	(when revregargs
2408	(let* ((zform (%car revregargs))
2409	(yform (%cadr revregargs))
2410	(xform (%caddr revregargs)))
2411	(if (eq 3 nregs)
2412	(ppc2-three-targeted-reg-forms seg xform ($ ppc::arg_x) yform ($ ppc::arg_y) zform ($ ppc::arg_z))
2413	(if (eq 2 nregs)
2414	(ppc2-two-targeted-reg-forms seg yform ($ ppc::arg_y) zform ($ ppc::arg_z))
2415	(ppc2-one-targeted-reg-form seg zform ($ ppc::arg_z))))))
2416	n)))
2417
2418	(defun ppc2-arglist (seg args)
2419	(ppc2-formlist seg (car args) (cadr args)))
2420
2421
2422
2423
2424	;;; treat form as a 32-bit immediate value and load it into immreg.
2425	;;; This is the "lenient" version of 32-bit-ness; OSTYPEs and chars
2426	;;; count, and we don't care about the integer's sign.
2427
2428	(defun ppc2-unboxed-integer-arg-to-reg (seg form immreg)
2429	(with-ppc-local-vinsn-macros (seg)
2430	(let* ((value (ppc2-long-constant-p form)))
2431	(if value
2432	(if (eql value 0)
2433	($ ppc::rzero :mode :natural)
2434	(progn
2435	(unless (typep immreg 'lreg)
2436	(setq immreg (make-unwired-lreg immreg :mode (gpr-mode-name-value :natural))))
2437	(ppc2-lri seg immreg value)
2438	immreg))
2439	(progn
2440	(ppc2-one-targeted-reg-form seg form ($ ppc::arg_z))
2441	(! getXlong)
2442	($ ppc::imm0 :mode :natural))))))
2443
2444
2445	(defun ppc2-macptr-arg-to-reg (seg form address-reg)
2446	(ppc2-one-targeted-reg-form seg
2447	form
2448	address-reg))
2449
2450
2451	(defun ppc2-one-lreg-form (seg form lreg)
2452	(let ((is-float (= (hard-regspec-class lreg) hard-reg-class-fpr)))
2453	(if is-float
2454	(ppc2-form-float seg lreg nil form)
2455	(ppc2-form seg lreg nil form))
2456	lreg))
2457
2458	(defun ppc2-one-targeted-reg-form (seg form reg)
2459	(ppc2-one-lreg-form seg form reg))
2460
2461	(defun ppc2-one-untargeted-lreg-form (seg form reg)
2462	(ppc2-one-lreg-form seg form (if (typep reg 'lreg) reg (make-unwired-lreg reg))))
2463
2464	(defun ppc2-one-untargeted-reg-form (seg form suggested)
2465	(with-ppc-local-vinsn-macros (seg)
2466	(let* ((gpr-p (= (hard-regspec-class suggested) hard-reg-class-gpr))
2467	(node-p (if gpr-p (= (get-regspec-mode suggested) hard-reg-class-gpr-mode-node))))
2468	(if node-p
2469	(let* ((ref (ppc2-lexical-reference-ea form))
2470	(reg (backend-ea-physical-reg ref hard-reg-class-gpr)))
2471	(if reg
2472	ref
2473	(if (nx-null form)
2474	(progn
2475	(! load-nil suggested)
2476	suggested)
2477	(if (eql 0 (acode-fixnum-form-p form))
2478	($ ppc::rzero)
2479	(if (and (acode-p form)
2480	(eq (acode-operator form) (%nx1-operator immediate))
2481	(setq reg (ppc2-register-constant-p (cadr form))))
2482	reg
2483	(if (and (acode-p form)
2484	(eq (acode-operator form) (%nx1-operator %current-tcr)))
2485	($ ppc::rcontext)
2486
2487	(ppc2-one-untargeted-lreg-form seg form suggested)))))))
2488	(ppc2-one-untargeted-lreg-form seg form suggested)))))
2489
2490
2491	(defun ppc2-push-register (seg areg)
2492	(let* ((a-float (= (hard-regspec-class areg) hard-reg-class-fpr))
2493	(a-double (if a-float (= (get-regspec-mode areg) hard-reg-class-fpr-mode-double)))
2494	(a-node (unless a-float (= (get-regspec-mode areg) hard-reg-class-gpr-mode-node)))
2495	vinsn)
2496	(with-ppc-local-vinsn-macros (seg)
2497	(if a-node
2498	(setq vinsn (ppc2-vpush-register seg areg :node-temp))
2499	(progn
2500	(setq vinsn
2501	(if a-float
2502	(if a-double
2503	(! temp-push-double-float areg)
2504	(! temp-push-single-float areg))
2505	(! temp-push-unboxed-word areg)))
2506	(ppc2-open-undo $undostkblk)))
2507	vinsn)))
2508
2509	(defun ppc2-pop-register (seg areg)
2510	(let* ((a-float (= (hard-regspec-class areg) hard-reg-class-fpr))
2511	(a-double (if a-float (= (get-regspec-mode areg) hard-reg-class-fpr-mode-double)))
2512	(a-node (unless a-float (= (get-regspec-mode areg) hard-reg-class-gpr-mode-node)))
2513	vinsn)
2514	(with-ppc-local-vinsn-macros (seg)
2515	(if a-node
2516	(setq vinsn (ppc2-vpop-register seg areg))
2517	(progn
2518	(setq vinsn
2519	(if a-float
2520	(if a-double
2521	(! temp-pop-double-float areg)
2522	(! temp-pop-single-float areg))
2523	(! temp-pop-unboxed-word areg)))
2524	(ppc2-close-undo)))
2525	vinsn)))
2526
2527	(defun ppc2-acc-reg-for (reg)
2528	(with-ppc-local-vinsn-macros (seg)
2529	(let* ((class (hard-regspec-class reg))
2530	(mode (get-regspec-mode reg)))
2531	(declare (fixnum class mode))
2532	(cond ((= class hard-reg-class-fpr)
2533	(make-wired-lreg ppc::fp1 :class class :mode mode))
2534	((= class hard-reg-class-gpr)
2535	(if (= mode hard-reg-class-gpr-mode-node)
2536	($ ppc::arg_z)
2537	(make-wired-lreg ppc::imm0 :mode mode)))
2538	(t (error "Unknown register class for reg ~s" reg))))))
2539
2540	;;; The compiler often generates superfluous pushes & pops. Try to
2541	;;; eliminate them.
2542	;;; It's easier to elide pushes and pops to the TSP.
2543	(defun ppc2-elide-pushes (seg push-vinsn pop-vinsn)
2544	(with-ppc-local-vinsn-macros (seg)
2545	(let* ((pushed-reg (svref (vinsn-variable-parts push-vinsn) 0))
2546	(popped-reg (svref (vinsn-variable-parts pop-vinsn) 0))
2547	(same-reg (eq (hard-regspec-value pushed-reg)
2548	(hard-regspec-value popped-reg)))
2549	(tsp-p (vinsn-attribute-p push-vinsn :tsp)))
2550	(when (and tsp-p t) ; vsp case is harder.
2551	(let* ((pushed-reg-is-set (vinsn-sequence-sets-reg-p
2552	push-vinsn pop-vinsn pushed-reg))
2553	(popped-reg-is-set (if same-reg
2554	pushed-reg-is-set
2555	(vinsn-sequence-sets-reg-p
2556	push-vinsn pop-vinsn popped-reg))))
2557	(unless (and pushed-reg-is-set popped-reg-is-set)
2558	(unless same-reg
2559	(let* ((copy (if (eq (hard-regspec-class pushed-reg)
2560	hard-reg-class-fpr)
2561	(! copy-fpr popped-reg pushed-reg)
2562	(! copy-gpr popped-reg pushed-reg))))
2563	(remove-dll-node copy)
2564	(if pushed-reg-is-set
2565	(insert-dll-node-after copy push-vinsn)
2566	(insert-dll-node-before copy push-vinsn))))
2567	(elide-vinsn push-vinsn)
2568	(elide-vinsn pop-vinsn)))))))
2569
2570
2571	;;; we never leave the first form pushed (the 68K compiler had some subprims that
2572	;;; would vpop the first argument out of line.)
2573	(defun ppc2-two-targeted-reg-forms (seg aform areg bform breg)
2574	(unless (typep areg 'lreg)
2575	(warn "~s is not an lreg (1/2)" areg))
2576	(unless (typep breg 'lreg)
2577	(warn "~s is not an lreg (2/2)" breg))
2578	(let* ((avar (ppc2-lexical-reference-p aform))
2579	(atriv (ppc2-trivial-p bform))
2580	(aconst (and (not atriv) (or (ppc-side-effect-free-form-p aform)
2581	(if avar (ppc2-var-not-set-by-form-p avar bform)))))
2582	(apushed (not (or atriv aconst))))
2583	(progn
2584	(unless aconst
2585	(if atriv
2586	(ppc2-one-targeted-reg-form seg aform areg)
2587	(setq apushed (ppc2-push-register seg (ppc2-one-untargeted-reg-form seg aform (ppc2-acc-reg-for areg))))))
2588	(ppc2-one-targeted-reg-form seg bform breg)
2589	(if aconst
2590	(ppc2-one-targeted-reg-form seg aform areg)
2591	(if apushed
2592	(ppc2-elide-pushes seg apushed (ppc2-pop-register seg areg)))))
2593	(values areg breg)))
2594
2595
2596	(defun ppc2-two-untargeted-reg-forms (seg aform areg bform breg)
2597	(with-ppc-local-vinsn-macros (seg)
2598	(let* ((avar (ppc2-lexical-reference-p aform))
2599	(adest areg)
2600	(bdest breg)
2601	(atriv (ppc2-trivial-p bform))
2602	(aconst (and (not atriv) (or (ppc-side-effect-free-form-p aform)
2603	(if avar (ppc2-var-not-set-by-form-p avar bform)))))
2604	(apushed (not (or atriv aconst))))
2605	(progn
2606	(unless aconst
2607	(if atriv
2608	(setq adest (ppc2-one-untargeted-reg-form seg aform areg))
2609	(setq apushed (ppc2-push-register seg (ppc2-one-untargeted-reg-form seg aform (ppc2-acc-reg-for areg))))))
2610	(setq bdest (ppc2-one-untargeted-reg-form seg bform breg))
2611	(if aconst
2612	(setq adest (ppc2-one-untargeted-reg-form seg aform areg))
2613	(if apushed
2614	(ppc2-elide-pushes seg apushed (ppc2-pop-register seg areg)))))
2615	(values adest bdest))))
2616
2617
2618	(defun ppc2-three-targeted-reg-forms (seg aform areg bform breg cform creg)
2619	(unless (typep areg 'lreg)
2620	(warn "~s is not an lreg (1/3)" areg))
2621	(unless (typep breg 'lreg)
2622	(warn "~s is not an lreg (2/3)" breg))
2623	(unless (typep creg 'lreg)
2624	(warn "~s is not an lreg (3/3)" creg))
2625	(let* ((atriv (or (null aform)
2626	(and (ppc2-trivial-p bform)
2627	(ppc2-trivial-p cform))))
2628	(btriv (or (null bform)
2629	(ppc2-trivial-p cform)))
2630	(aconst (and (not atriv)
2631	(or (ppc-side-effect-free-form-p aform)
2632	(let ((avar (ppc2-lexical-reference-p aform)))
2633	(and avar
2634	(ppc2-var-not-set-by-form-p avar bform)
2635	(ppc2-var-not-set-by-form-p avar cform))))))
2636	(bconst (and (not btriv)
2637	(or
2638	(ppc-side-effect-free-form-p bform)
2639	(let ((bvar (ppc2-lexical-reference-p bform)))
2640	(and bvar (ppc2-var-not-set-by-form-p bvar cform))))))
2641	(apushed nil)
2642	(bpushed nil))
2643	(if (and aform (not aconst))
2644	(if atriv
2645	(ppc2-one-targeted-reg-form seg aform areg)
2646	(setq apushed (ppc2-push-register seg (ppc2-one-untargeted-reg-form seg aform (ppc2-acc-reg-for areg))))))
2647	(if (and bform (not bconst))
2648	(if btriv
2649	(ppc2-one-targeted-reg-form seg bform breg)
2650	(setq bpushed (ppc2-push-register seg (ppc2-one-untargeted-reg-form seg bform (ppc2-acc-reg-for breg))))))
2651	(ppc2-one-targeted-reg-form seg cform creg)
2652	(unless btriv
2653	(if bconst
2654	(ppc2-one-targeted-reg-form seg bform breg)
2655	(ppc2-elide-pushes seg bpushed (ppc2-pop-register seg breg))))
2656	(unless atriv
2657	(if aconst
2658	(ppc2-one-targeted-reg-form seg aform areg)
2659	(ppc2-elide-pushes seg apushed (ppc2-pop-register seg areg))))
2660	(values areg breg creg)))
2661
2662	(defun ppc2-three-untargeted-reg-forms (seg aform areg bform breg cform creg)
2663	(with-ppc-local-vinsn-macros (seg)
2664	(let* ((atriv (or (null aform)
2665	(and (ppc2-trivial-p bform)
2666	(ppc2-trivial-p cform))))
2667	(btriv (or (null bform)
2668	(ppc2-trivial-p cform)))
2669	(aconst (and (not atriv)
2670	(or (ppc-side-effect-free-form-p aform)
2671	(let ((avar (ppc2-lexical-reference-p aform)))
2672	(and avar
2673	(ppc2-var-not-set-by-form-p avar bform)
2674	(ppc2-var-not-set-by-form-p avar cform))))))
2675	(bconst (and (not btriv)
2676	(or
2677	(ppc-side-effect-free-form-p bform)
2678	(let ((bvar (ppc2-lexical-reference-p bform)))
2679	(and bvar (ppc2-var-not-set-by-form-p bvar cform))))))
2680	(adest areg)
2681	(bdest breg)
2682	(cdest creg)
2683	(apushed nil)
2684	(bpushed nil))
2685	(if (and aform (not aconst))
2686	(if atriv
2687	(setq adest (ppc2-one-targeted-reg-form seg aform ($ areg)))
2688	(setq apushed (ppc2-push-register seg (ppc2-one-untargeted-reg-form seg aform (ppc2-acc-reg-for areg))))))
2689	(if (and bform (not bconst))
2690	(if btriv
2691	(setq bdest (ppc2-one-untargeted-reg-form seg bform ($ breg)))
2692	(setq bpushed (ppc2-push-register seg (ppc2-one-untargeted-reg-form seg bform (ppc2-acc-reg-for breg))))))
2693	(setq cdest (ppc2-one-untargeted-reg-form seg cform creg))
2694	(unless btriv
2695	(if bconst
2696	(setq bdest (ppc2-one-untargeted-reg-form seg bform breg))
2697	(ppc2-elide-pushes seg bpushed (ppc2-pop-register seg breg))))
2698	(unless atriv
2699	(if aconst
2700	(setq adest (ppc2-one-untargeted-reg-form seg aform areg))
2701	(ppc2-elide-pushes seg apushed (ppc2-pop-register seg areg))))
2702	(values adest bdest cdest))))
2703
2704	(defun ppc2-four-untargeted-reg-forms (seg aform areg bform breg cform creg dform dreg)
2705	(let* ((atriv (or (null aform)
2706	(and (ppc2-trivial-p bform)
2707	(ppc2-trivial-p cform)
2708	(ppc2-trivial-p dform))))
2709	(btriv (or (null bform)
2710	(and (ppc2-trivial-p cform)
2711	(ppc2-trivial-p dform))))
2712	(ctriv (or (null cform)
2713	(ppc2-trivial-p dform)))
2714	(aconst (and (not atriv)
2715	(or (ppc-side-effect-free-form-p aform)
2716	(let ((avar (ppc2-lexical-reference-p aform)))
2717	(and avar
2718	(ppc2-var-not-set-by-form-p avar bform)
2719	(ppc2-var-not-set-by-form-p avar cform)
2720	(ppc2-var-not-set-by-form-p avar dform))))))
2721	(bconst (and (not btriv)
2722	(or
2723	(ppc-side-effect-free-form-p bform)
2724	(let ((bvar (ppc2-lexical-reference-p bform)))
2725	(and bvar
2726	(ppc2-var-not-set-by-form-p bvar cform)
2727	(ppc2-var-not-set-by-form-p bvar dform))))))
2728	(cconst (and (not ctriv)
2729	(or
2730	(ppc-side-effect-free-form-p cform)
2731	(let ((cvar (ppc2-lexical-reference-p cform)))
2732	(and cvar
2733	(ppc2-var-not-set-by-form-p cvar dform))))))
2734	(adest areg)
2735	(bdest breg)
2736	(cdest creg)
2737	(ddest dreg)
2738	(apushed nil)
2739	(bpushed nil)
2740	(cpushed nil))
2741	(if (and aform (not aconst))
2742	(if atriv
2743	(setq adest (ppc2-one-targeted-reg-form seg aform areg))
2744	(setq apushed (ppc2-push-register seg (ppc2-one-untargeted-reg-form seg aform (ppc2-acc-reg-for areg))))))
2745	(if (and bform (not bconst))
2746	(if btriv
2747	(setq bdest (ppc2-one-untargeted-reg-form seg bform breg))
2748	(setq bpushed (ppc2-push-register seg (ppc2-one-untargeted-reg-form seg bform (ppc2-acc-reg-for breg))))))
2749	(if (and cform (not cconst))
2750	(if ctriv
2751	(setq cdest (ppc2-one-untargeted-reg-form seg cform creg))
2752	(setq cpushed (ppc2-push-register seg (ppc2-one-untargeted-reg-form seg cform (ppc2-acc-reg-for creg))))))
2753	(setq ddest (ppc2-one-untargeted-reg-form seg dform dreg))
2754	(unless ctriv
2755	(if cconst
2756	(setq cdest (ppc2-one-untargeted-reg-form seg cform creg))
2757	(ppc2-elide-pushes seg cpushed (ppc2-pop-register seg creg))))
2758	(unless btriv
2759	(if bconst
2760	(setq bdest (ppc2-one-untargeted-reg-form seg bform breg))
2761	(ppc2-elide-pushes seg bpushed (ppc2-pop-register seg breg))))
2762	(unless atriv
2763	(if aconst
2764	(setq adest (ppc2-one-untargeted-reg-form seg aform areg))
2765	(ppc2-elide-pushes seg apushed (ppc2-pop-register seg areg))))
2766	(values adest bdest cdest ddest)))
2767
2768	(defun ppc2-lri (seg reg value)
2769	(with-ppc-local-vinsn-macros (seg)
2770	(if (>= value 0)
2771	(! lri reg value)
2772	(target-arch-case
2773	(:ppc32 (! lri reg (logand value #xffffffff)))
2774	(:ppc64 (! lri reg (logand value #xffffffffffffffff)))))))
2775
2776
2777	(defun ppc2-multiple-value-body (seg form)
2778	(let* ((lab (backend-get-next-label))
2779	(ppc2-vstack ppc2-vstack)
2780	(ppc2-top-vstack-lcell ppc2-top-vstack-lcell)
2781	(old-stack (ppc2-encode-stack)))
2782	(with-ppc-local-vinsn-macros (seg)
2783	(ppc2-open-undo $undomvexpect)
2784	(ppc2-undo-body seg nil (%ilogior2 $backend-mvpass-mask lab) form old-stack)
2785	(@ lab))))
2786
2787	(defun ppc2-afunc-lfun-ref (afunc)
2788	(or
2789	(afunc-lfun afunc)
2790	(progn (pushnew afunc (afunc-fwd-refs ppc2-cur-afunc) :test #'eq)
2791	afunc)))
2792
2793	(defun ppc2-augment-arglist (afunc arglist &optional (maxregs $numppcargregs))
2794	(let ((inherited-args (afunc-inherited-vars afunc)))
2795	(when inherited-args
2796	(let* ((current-afunc ppc2-cur-afunc)
2797	(stkargs (car arglist))
2798	(regargs (cadr arglist))
2799	(inhforms nil)
2800	(numregs (length regargs))
2801	(own-inhvars (afunc-inherited-vars current-afunc)))
2802	(dolist (var inherited-args)
2803	(let* ((root-var (nx-root-var var))
2804	(other-guy
2805	(dolist (v own-inhvars #\|(error "other guy not found")\|# root-var)
2806	(when (eq root-var (nx-root-var v)) (return v)))))
2807	(push (make-acode (%nx1-operator inherited-arg) other-guy) inhforms)))
2808	(dolist (form inhforms)
2809	(if (%i< numregs maxregs)
2810	(progn
2811	(setq regargs (nconc regargs (list form)))
2812	(setq numregs (%i+ numregs 1)))
2813	(push form stkargs)))
2814	(%rplaca (%cdr arglist) regargs) ; might have started out NIL.
2815	(%rplaca arglist stkargs))))
2816	arglist)
2817
2818
2819
2820
2821	;;; There are other cases involving constants that are worth exploiting.
2822	(defun ppc2-compare (seg vreg xfer i j cr-bit true-p)
2823	(with-ppc-local-vinsn-macros (seg vreg xfer)
2824	(let* ((jconstant (acode-fixnum-form-p j))
2825	(js16 (typep jconstant '(signed-byte #.(- 16 ppc32::fixnumshift))))
2826	(iconstant (acode-fixnum-form-p i))
2827	(is16 (typep iconstant '(signed-byte #.(- 16 ppc32::fixnumshift))))
2828	(boolean (backend-crf-p vreg)))
2829	(if (and boolean (or js16 is16))
2830	(let* ((reg (ppc2-one-untargeted-reg-form seg (if js16 i j) ppc::arg_z)))
2831	(! compare-signed-s16const vreg reg (ash (if js16 jconstant iconstant) ppc2-target-fixnum-shift))
2832	(unless (or js16 (eq cr-bit ppc::ppc-eq-bit))
2833	(setq cr-bit (- 1 cr-bit)))
2834	(^ cr-bit true-p))
2835	(if (and (eq cr-bit ppc::ppc-eq-bit)
2836	(or js16 is16))
2837	(ppc2-test-reg-%izerop
2838	seg
2839	vreg
2840	xfer
2841	(ppc2-one-untargeted-reg-form
2842	seg
2843	(if js16 i j)
2844	ppc::arg_z)
2845	cr-bit
2846	true-p
2847	(ash (if js16 jconstant iconstant) ppc2-target-fixnum-shift))
2848	(multiple-value-bind (ireg jreg) (ppc2-two-untargeted-reg-forms seg i ppc::arg_y j ppc::arg_z)
2849	(ppc2-compare-registers seg vreg xfer ireg jreg cr-bit true-p)))))))
2850
2851	(defun ppc2-natural-compare (seg vreg xfer i j cr-bit true-p)
2852	(with-ppc-local-vinsn-macros (seg vreg xfer)
2853	(let* ((jconstant (acode-fixnum-form-p j))
2854	(ju16 (typep jconstant '(unsigned-byte 16)))
2855	(iconstant (acode-fixnum-form-p i))
2856	(iu16 (typep iconstant '(unsigned-byte 16)))
2857	(boolean (backend-crf-p vreg)))
2858	(if (and boolean (or ju16 iu16))
2859	(with-imm-target
2860	() (reg :natural)
2861	(ppc2-one-targeted-reg-form seg (if ju16 i j) reg)
2862	(! compare-unsigned-u16const vreg reg (if ju16 jconstant iconstant))
2863	(unless (or ju16 (eq cr-bit ppc::ppc-eq-bit))
2864	(setq cr-bit (- 1 cr-bit)))
2865	(^ cr-bit true-p))
2866	(with-imm-target ()
2867	(ireg :natural)
2868	(with-imm-target
2869	(ireg) (jreg :natural)
2870	(ppc2-two-targeted-reg-forms seg i ireg j jreg)
2871	(ppc2-compare-natural-registers seg vreg xfer ireg jreg cr-bit true-p)))))))
2872
2873	(defun ppc2-compare-natural-registers (seg vreg xfer ireg jreg cr-bit true-p)
2874	(with-ppc-local-vinsn-macros (seg vreg xfer)
2875	(if vreg
2876	(regspec-crf-gpr-case
2877	(vreg dest)
2878	(progn
2879	(! compare-logical dest ireg jreg)
2880	(^ cr-bit true-p))
2881	(with-imm-temps () ((b31-reg :natural))
2882	(ecase cr-bit
2883	(#. ppc::ppc-eq-bit
2884	(if true-p
2885	(! eq->bit31 b31-reg ireg jreg)
2886	(! ne->bit31 b31-reg ireg jreg)))
2887	(#. ppc::ppc-lt-bit
2888	(if true-p
2889	(! ltu->bit31 b31-reg ireg jreg)
2890	(! geu->bit31 b31-reg ireg jreg)))
2891	(#. ppc::ppc-gt-bit
2892	(if true-p
2893	(! gtu->bit31 b31-reg ireg jreg)
2894	(! leu->bit31 b31-reg ireg jreg))))
2895	(ensuring-node-target (target dest)
2896	(! lowbit->truth target b31-reg))
2897	(^)))
2898	(^))))
2899
2900	(defun ppc2-compare-registers (seg vreg xfer ireg jreg cr-bit true-p)
2901	(with-ppc-local-vinsn-macros (seg vreg xfer)
2902	(if vreg
2903	(regspec-crf-gpr-case
2904	(vreg dest)
2905	(progn
2906	(! compare dest ireg jreg)
2907	(^ cr-bit true-p))
2908	(with-imm-temps () ((b31-reg :natural))
2909	(ecase cr-bit
2910	(#. ppc::ppc-eq-bit
2911	(if true-p
2912	(! eq->bit31 b31-reg ireg jreg)
2913	(! ne->bit31 b31-reg ireg jreg)))
2914	(#. ppc::ppc-lt-bit
2915	(if true-p
2916	(! lt->bit31 b31-reg ireg jreg)
2917	(! ge->bit31 b31-reg ireg jreg)))
2918	(#. ppc::ppc-gt-bit
2919	(if true-p
2920	(! gt->bit31 b31-reg ireg jreg)
2921	(! le->bit31 b31-reg ireg jreg))))
2922	(ensuring-node-target (target dest)
2923	(! lowbit->truth target b31-reg))
2924	(^)))
2925	(^))))
2926
2927	(defun ppc2-compare-register-to-nil (seg vreg xfer ireg cr-bit true-p)
2928	(with-ppc-local-vinsn-macros (seg vreg xfer)
2929	(if vreg
2930	(regspec-crf-gpr-case
2931	(vreg dest)
2932	(progn
2933	(! compare-to-nil dest ireg)
2934	(^ cr-bit true-p))
2935	(with-imm-temps () ((b31-reg :natural))
2936	(ecase cr-bit
2937	(#. ppc::ppc-eq-bit
2938	(if true-p
2939	(! eqnil->bit31 b31-reg ireg)
2940	(! nenil->bit31 b31-reg ireg))))
2941	(ensuring-node-target (target dest)
2942	(! lowbit->truth target b31-reg))
2943	(^)))
2944	(^))))
2945
2946	;;; Have to extract a bit out of the CR when a boolean result needed.
2947	(defun ppc2-compare-double-float-registers (seg vreg xfer ireg jreg cr-bit true-p)
2948	(with-ppc-local-vinsn-macros (seg vreg xfer)
2949	(if vreg
2950	(regspec-crf-gpr-case
2951	(vreg dest)
2952	(progn
2953	(! double-float-compare dest ireg jreg)
2954	(^ cr-bit true-p))
2955	(with-imm-temps () ((lowbit-reg :natural))
2956	(with-crf-target () flags
2957	(! double-float-compare flags ireg jreg)
2958	(! crbit->bit31 lowbit-reg flags cr-bit))
2959	(unless true-p
2960	(! invert-lowbit lowbit-reg))
2961	(ensuring-node-target (target dest)
2962	(! lowbit->truth target lowbit-reg))
2963	(^)))
2964	(^))))
2965
2966
2967	(defun ppc2-immediate-form-p (form)
2968	(if (and (consp form)
2969	(or (eq (%car form) (%nx1-operator immediate))
2970	(eq (%car form) (%nx1-operator simple-function))))
2971	t))
2972
2973	(defun ppc2-test-%izerop (seg vreg xfer form cr-bit true-p)
2974	(ppc2-test-reg-%izerop seg vreg xfer (ppc2-one-untargeted-reg-form seg form ppc::arg_z) cr-bit true-p 0))
2975
2976	(defun ppc2-test-reg-%izerop (seg vreg xfer reg cr-bit true-p zero)
2977	(declare (fixnum reg zero))
2978	(with-ppc-local-vinsn-macros (seg vreg xfer)
2979	(regspec-crf-gpr-case
2980	(vreg dest)
2981	(progn
2982	(! compare-signed-s16const dest reg zero)
2983	(^ cr-bit true-p))
2984	(with-imm-temps (reg) (b31-reg scaled)
2985	(if (zerop zero)
2986	(setq scaled reg)
2987	(! subtract-constant scaled reg zero))
2988	(ecase cr-bit
2989	(#. ppc::ppc-eq-bit
2990	(if true-p
2991	(! eq0->bit31 b31-reg scaled)
2992	(! ne0->bit31 b31-reg scaled)))
2993	(#. ppc::ppc-lt-bit
2994	(if true-p
2995	(! lt0->bit31 b31-reg scaled)
2996	(! ge0->bit31 b31-reg scaled)))
2997	(#. ppc::ppc-gt-bit
2998	(if true-p
2999	(! gt0->bit31 b31-reg scaled)
3000	(! le0->bit31 b31-reg scaled))))
3001	(ensuring-node-target (target dest)
3002	(! lowbit->truth target b31-reg))
3003	(^)))))
3004
3005	(defun ppc2-lexical-reference-ea (form &optional (no-closed-p t))
3006	(when (acode-p (setq form (acode-unwrapped-form form)))
3007	(if (eq (acode-operator form) (%nx1-operator lexical-reference))
3008	(let* ((addr (var-ea (%cadr form))))
3009	(if (typep addr 'lreg)
3010	addr
3011	(unless (and no-closed-p (addrspec-vcell-p addr ))
3012	addr))))))
3013
3014
3015	(defun ppc2-vpush-register (seg src &optional why info attr)
3016	(with-ppc-local-vinsn-macros (seg)
3017	(prog1
3018	(! vpush-register src)
3019	(ppc2-new-vstack-lcell (or why :node) ppc2-target-lcell-size (or attr 0) info)
3020	(ppc2-adjust-vstack ppc2-target-node-size))))
3021
3022	(defun ppc2-vpush-register-arg (seg src)
3023	(ppc2-vpush-register seg src :outgoing-argument))
3024
3025
3026	(defun ppc2-vpop-register (seg dest)
3027	(with-ppc-local-vinsn-macros (seg)
3028	(prog1
3029	(! vpop-register dest)
3030	(setq ppc2-top-vstack-lcell (lcell-parent ppc2-top-vstack-lcell))
3031	(ppc2-adjust-vstack (- ppc2-target-node-size)))))
3032
3033	(defun ppc2-copy-register (seg dest src)
3034	(with-ppc-local-vinsn-macros (seg)
3035	(when dest
3036	(let* ((dest-gpr (backend-ea-physical-reg dest hard-reg-class-gpr))
3037	(src-gpr (if src (backend-ea-physical-reg src hard-reg-class-gpr)))
3038	(dest-fpr (backend-ea-physical-reg dest hard-reg-class-fpr))
3039	(src-fpr (if src (backend-ea-physical-reg src hard-reg-class-fpr)))
3040	(src-mode (if src (get-regspec-mode src)))
3041	(dest-mode (get-regspec-mode dest))
3042	(dest-crf (backend-ea-physical-reg dest hard-reg-class-crf)))
3043	(if (and dest-gpr (eql dest-gpr ppc::rzero))
3044	(break "Bad destination register: ~s" dest-gpr))
3045	(if (null src)
3046	(if dest-gpr
3047	(! load-nil dest-gpr)
3048	(if dest-crf
3049	(! set-eq-bit dest-crf)))
3050	(if (and dest-crf src-gpr)
3051	;; "Copying" a GPR to a CR field means comparing it to rnil
3052	(! compare-to-nil dest src)
3053	(if (and dest-gpr src-gpr)
3054	(if (eql src-gpr ppc::rzero)
3055	;; Rzero always contains 0, so we can
3056	;; save ourselves some trouble.
3057	;; This assumes that (LI dest-gpr 0) is easier
3058	;; on the register-renaming pipeline nonsense than
3059	;; (MR dest-gpr rzero) would be.
3060	(! lri dest-gpr 0)
3061	;; This is the "GPR <- GPR" case. There are
3062	;; word-size dependencies, but there's also
3063	;; lots of redundancy here.
3064	(target-arch-case
3065	(:ppc32
3066	(case dest-mode
3067	(#.hard-reg-class-gpr-mode-node ; boxed result.
3068	(case src-mode
3069	(#.hard-reg-class-gpr-mode-node
3070	(unless (eql dest-gpr src-gpr)
3071	(! copy-gpr dest src)))
3072	(#.hard-reg-class-gpr-mode-u32
3073	(ppc2-box-u32 seg dest src))
3074	(#.hard-reg-class-gpr-mode-s32
3075	(ppc2-box-s32 seg dest src))
3076	(#.hard-reg-class-gpr-mode-u16
3077	(! u16->fixnum dest src))
3078	(#.hard-reg-class-gpr-mode-s16
3079	(! s16->fixnum dest src))
3080	(#.hard-reg-class-gpr-mode-u8
3081	(! u8->fixnum dest src))
3082	(#.hard-reg-class-gpr-mode-s8
3083	(! s8->fixnum dest src))
3084	(#.hard-reg-class-gpr-mode-address
3085	(! macptr->heap dest src))))
3086	((#.hard-reg-class-gpr-mode-u32
3087	#.hard-reg-class-gpr-mode-address)
3088	(case src-mode
3089	(#.hard-reg-class-gpr-mode-node
3090	(let* ((src-type (get-node-regspec-type-modes src)))
3091	(declare (fixnum src-type))
3092	(case dest-mode
3093	(#.hard-reg-class-gpr-mode-u32
3094	(! unbox-u32 dest src))
3095	(#.hard-reg-class-gpr-mode-address
3096	(unless (logbitp #.hard-reg-class-gpr-mode-address src-type)
3097	(! trap-unless-macptr src))
3098	(! deref-macptr dest src)))))
3099	((#.hard-reg-class-gpr-mode-u32
3100	#.hard-reg-class-gpr-mode-s32
3101	#.hard-reg-class-gpr-mode-address)
3102	(unless (eql dest-gpr src-gpr)
3103	(! copy-gpr dest src)))
3104	((#.hard-reg-class-gpr-mode-u16
3105	#.hard-reg-class-gpr-mode-s16)
3106	(! u16->u32 dest src))
3107	((#.hard-reg-class-gpr-mode-u8
3108	#.hard-reg-class-gpr-mode-s8)
3109	(! u8->u32 dest src))))
3110	(#.hard-reg-class-gpr-mode-s32
3111	(case src-mode
3112	(#.hard-reg-class-gpr-mode-node
3113	(! unbox-s32 dest src))
3114	((#.hard-reg-class-gpr-mode-u32
3115	#.hard-reg-class-gpr-mode-s32
3116	#.hard-reg-class-gpr-mode-address)
3117	(unless (eql dest-gpr src-gpr)
3118	(! copy-gpr dest src)))
3119	(#.hard-reg-class-gpr-mode-u16
3120	(! u16->u32 dest src))
3121	(#.hard-reg-class-gpr-mode-s16
3122	(! s16->s32 dest src))
3123	(#.hard-reg-class-gpr-mode-u8
3124	(! u8->u32 dest src))
3125	(#.hard-reg-class-gpr-mode-s8
3126	(! s8->s32 dest src))))
3127	(#.hard-reg-class-gpr-mode-u16
3128	(case src-mode
3129	(#.hard-reg-class-gpr-mode-node
3130	(! unbox-u16 dest src))
3131	((#.hard-reg-class-gpr-mode-u8
3132	#.hard-reg-class-gpr-mode-s8)
3133	(! u8->u32 dest src))
3134	(t
3135	(unless (eql dest-gpr src-gpr)
3136	(! copy-gpr dest src)))))
3137	(#.hard-reg-class-gpr-mode-s16
3138	(case src-mode
3139	(#.hard-reg-class-gpr-mode-node
3140	(! unbox-s16 dest src))
3141	(#.hard-reg-class-gpr-mode-s8
3142	(! s8->s32 dest src))
3143	(#.hard-reg-class-gpr-mode-u8
3144	(! u8->u32 dest src))
3145	(t
3146	(unless (eql dest-gpr src-gpr)
3147	(! copy-gpr dest src)))))
3148	(#.hard-reg-class-gpr-mode-u8
3149	(case src-mode
3150	(#.hard-reg-class-gpr-mode-node
3151	(! unbox-u8 dest src))
3152	(t
3153	(unless (eql dest-gpr src-gpr)
3154	(! copy-gpr dest src)))))
3155	(#.hard-reg-class-gpr-mode-s8
3156	(case src-mode
3157	(#.hard-reg-class-gpr-mode-node
3158	(! unbox-s8 dest src))
3159	(t
3160	(unless (eql dest-gpr src-gpr)
3161	(! copy-gpr dest src)))))))
3162	(:ppc64
3163	(case dest-mode
3164	(#.hard-reg-class-gpr-mode-node ; boxed result.
3165	(case src-mode
3166	(#.hard-reg-class-gpr-mode-node
3167	(unless (eql dest-gpr src-gpr)
3168	(! copy-gpr dest src)))
3169	(#.hard-reg-class-gpr-mode-u64
3170	(ppc2-box-u64 seg dest src))
3171	(#.hard-reg-class-gpr-mode-s64
3172	(ppc2-box-s64 seg dest src))
3173	(#.hard-reg-class-gpr-mode-u32
3174	(ppc2-box-u32 seg dest src))
3175	(#.hard-reg-class-gpr-mode-s32
3176	(ppc2-box-s32 seg dest src))
3177	(#.hard-reg-class-gpr-mode-u16
3178	(! u16->fixnum dest src))
3179	(#.hard-reg-class-gpr-mode-s16
3180	(! s16->fixnum dest src))
3181	(#.hard-reg-class-gpr-mode-u8
3182	(! u8->fixnum dest src))
3183	(#.hard-reg-class-gpr-mode-s8
3184	(! s8->fixnum dest src))
3185	(#.hard-reg-class-gpr-mode-address
3186	(! macptr->heap dest src))))
3187	((#.hard-reg-class-gpr-mode-u64
3188	#.hard-reg-class-gpr-mode-address)
3189	(case src-mode
3190	(#.hard-reg-class-gpr-mode-node
3191	(let* ((src-type (get-node-regspec-type-modes src)))
3192	(declare (fixnum src-type))
3193	(case dest-mode
3194	(#.hard-reg-class-gpr-mode-u64
3195	(! unbox-u64 dest src))
3196	(#.hard-reg-class-gpr-mode-address
3197	(unless (logbitp #.hard-reg-class-gpr-mode-address src-type)
3198	(! trap-unless-macptr src))
3199	(! deref-macptr dest src)))))
3200	((#.hard-reg-class-gpr-mode-u64
3201	#.hard-reg-class-gpr-mode-s64
3202	#.hard-reg-class-gpr-mode-address)
3203	(unless (eql dest-gpr src-gpr)
3204	(! copy-gpr dest src)))
3205	((#.hard-reg-class-gpr-mode-u16
3206	#.hard-reg-class-gpr-mode-s16)
3207	(! u16->u32 dest src))
3208	((#.hard-reg-class-gpr-mode-u8
3209	#.hard-reg-class-gpr-mode-s8)
3210	(! u8->u32 dest src))))
3211	(#.hard-reg-class-gpr-mode-s32
3212	(case src-mode
3213	(#.hard-reg-class-gpr-mode-node
3214	(! unbox-s32 dest src))
3215	((#.hard-reg-class-gpr-mode-u32
3216	#.hard-reg-class-gpr-mode-s32
3217	#.hard-reg-class-gpr-mode-address)
3218	(unless (eql dest-gpr src-gpr)
3219	(! copy-gpr dest src)))
3220	(#.hard-reg-class-gpr-mode-u16
3221	(! u16->u32 dest src))
3222	(#.hard-reg-class-gpr-mode-s16
3223	(! s16->s32 dest src))
3224	(#.hard-reg-class-gpr-mode-u8
3225	(! u8->u32 dest src))
3226	(#.hard-reg-class-gpr-mode-s8
3227	(! s8->s32 dest src))))
3228	(#.hard-reg-class-gpr-mode-u16
3229	(case src-mode
3230	(#.hard-reg-class-gpr-mode-node
3231	(! unbox-u16 dest src))
3232	((#.hard-reg-class-gpr-mode-u8
3233	#.hard-reg-class-gpr-mode-s8)
3234	(! u8->u32 dest src))
3235	(t
3236	(unless (eql dest-gpr src-gpr)
3237	(! copy-gpr dest src)))))
3238	(#.hard-reg-class-gpr-mode-s16
3239	(case src-mode
3240	(#.hard-reg-class-gpr-mode-node
3241	(! unbox-s16 dest src))
3242	(#.hard-reg-class-gpr-mode-s8
3243	(! s8->s32 dest src))
3244	(#.hard-reg-class-gpr-mode-u8
3245	(! u8->u32 dest src))
3246	(t
3247	(unless (eql dest-gpr src-gpr)
3248	(! copy-gpr dest src)))))
3249	(#.hard-reg-class-gpr-mode-u8
3250	(case src-mode
3251	(#.hard-reg-class-gpr-mode-node
3252	(! unbox-u8 dest src))
3253	(t
3254	(unless (eql dest-gpr src-gpr)
3255	(! copy-gpr dest src)))))
3256	(#.hard-reg-class-gpr-mode-s8
3257	(case src-mode
3258	(#.hard-reg-class-gpr-mode-node
3259	(! unbox-s8 dest src))
3260	(t
3261	(unless (eql dest-gpr src-gpr)
3262	(! copy-gpr dest src)))))))))
3263	(if src-gpr
3264	(if dest-fpr
3265	(progn
3266	(case src-mode
3267	(#.hard-reg-class-gpr-mode-node
3268	(case dest-mode
3269	(#.hard-reg-class-fpr-mode-double
3270	;; if we knew the source was double, we set a bit in the dest reg spec (weird huh)
3271	(unless (logbitp hard-reg-class-fpr-type-double
3272	(get-node-regspec-type-modes dest))
3273	(! trap-unless-double-float src))
3274	(! get-double dest src))
3275	(#.hard-reg-class-fpr-mode-single
3276	(! trap-unless-single-float src)
3277	(! get-single dest src)))))))
3278	(if dest-gpr
3279	(case dest-mode
3280	(#.hard-reg-class-gpr-mode-node
3281	(case src-mode
3282	(#.hard-reg-class-fpr-mode-double
3283	(! double->heap dest src))
3284	(#.hard-reg-class-fpr-mode-single
3285	(! single->node dest src)))))
3286	(if (and src-fpr dest-fpr)
3287	(unless (eql dest-fpr src-fpr)
3288	(! copy-fpr dest src))))))))))))
3289
3290	(defun ppc2-unreachable-store (&optional vreg)
3291	; I don't think that anything needs to be done here,
3292	; but leave this guy around until we're sure.
3293	; (PPC2-VPUSH-REGISTER will always vpush something, even
3294	; if code to -load- that "something" never gets generated.
3295	; If I'm right about this, that means that the compile-time
3296	; stack-discipline problem that this is supposed to deal
3297	; with can't happen.)
3298	(declare (ignore vreg))
3299	nil)
3300
3301	;;; bind vars to initforms, as per let*, &aux.
3302	(defun ppc2-seq-bind (seg vars initforms)
3303	(dolist (var vars)
3304	(ppc2-seq-bind-var seg var (pop initforms))))
3305
3306	(defun ppc2-dynamic-extent-form (seg curstack val)
3307	(when (acode-p val)
3308	(with-ppc-local-vinsn-macros (seg)
3309	(let* ((op (acode-operator val)))
3310	(cond ((eq op (%nx1-operator list))
3311	(let* ((ppc2-vstack ppc2-vstack)
3312	(ppc2-top-vstack-lcell ppc2-top-vstack-lcell))
3313	(ppc2-set-nargs seg (ppc2-formlist seg (%cadr val) nil))
3314	(ppc2-open-undo $undostkblk curstack)
3315	(! stack-cons-list))
3316	(setq val ppc::arg_z))
3317	((eq op (%nx1-operator list*))
3318	(let* ((arglist (%cadr val)))
3319	(let* ((ppc2-vstack ppc2-vstack)
3320	(ppc2-top-vstack-lcell ppc2-top-vstack-lcell))
3321	(ppc2-arglist seg arglist))
3322	(when (car arglist)
3323	(ppc2-set-nargs seg (length (%car arglist)))
3324	(! stack-cons-list*)
3325	(ppc2-open-undo $undostkblk curstack))
3326	(setq val ppc::arg_z)))
3327	((eq op (%nx1-operator multiple-value-list))
3328	(ppc2-multiple-value-body seg (%cadr val))
3329	(ppc2-open-undo $undostkblk curstack)
3330	(! stack-cons-list)
3331	(setq val ppc::arg_z))
3332	((eq op (%nx1-operator cons))
3333	(let* ((y ($ ppc::arg_y))
3334	(z ($ ppc::arg_z))
3335	(result ($ ppc::arg_z)))
3336	(ppc2-two-targeted-reg-forms seg (%cadr val) y (%caddr val) z)
3337	(ppc2-open-undo $undostkblk )
3338	(! make-tsp-cons result y z)
3339	(setq val result)))
3340	((eq op (%nx1-operator %consmacptr%))
3341	(with-imm-target () (address :address)
3342	(ppc2-one-targeted-reg-form seg val address)
3343	(with-node-temps () (node)
3344	(! macptr->stack node address)
3345	(ppc2-open-undo $undostkblk)
3346	(setq val node))))
3347	((eq op (%nx1-operator %new-ptr))
3348	(let ((clear-form (caddr val)))
3349	(if (nx-constant-form-p clear-form)
3350	(progn
3351	(ppc2-one-targeted-reg-form seg (%cadr val) ($ ppc::arg_z))
3352	(ppc2-open-undo $undostkblk)
3353	(if (nx-null clear-form)
3354	(! make-stack-block)
3355	(! make-stack-block0)))
3356	(with-crf-target () crf
3357	(let ((stack-block-0-label (backend-get-next-label))
3358	(done-label (backend-get-next-label))
3359	(rval ($ ppc::arg_z))
3360	(rclear ($ ppc::arg_y)))
3361	(ppc2-two-targeted-reg-forms seg (%cadr val) rval clear-form rclear)
3362	(! compare-to-nil crf rclear)
3363	(! cbranch-false (aref backend-labels stack-block-0-label) crf ppc::ppc-eq-bit)
3364	(! make-stack-block)
3365	(-> done-label)
3366	(@ stack-block-0-label)
3367	(! make-stack-block0)
3368	(@ done-label)))))
3369	(setq val ($ ppc::arg_z)))
3370	((eq op (%nx1-operator make-list))
3371	(ppc2-two-targeted-reg-forms seg (%cadr val) ($ ppc::arg_y) (%caddr val) ($ ppc::arg_z))
3372	(ppc2-open-undo $undostkblk curstack)
3373	(! make-stack-list)
3374	(setq val ppc::arg_z))
3375	((eq (%car val) (%nx1-operator vector))
3376	(let* ((ppc2-vstack ppc2-vstack)
3377	(ppc2-top-vstack-lcell ppc2-top-vstack-lcell))
3378	(ppc2-set-nargs seg (ppc2-formlist seg (%cadr val) nil))
3379	(! make-stack-vector))
3380	(ppc2-open-undo $undostkblk)
3381	(setq val ppc::arg_z))
3382	((eq op (%nx1-operator %ppc-gvector))
3383	(let* ((ppc2-vstack ppc2-vstack)
3384	(ppc2-top-vstack-lcell ppc2-top-vstack-lcell)
3385	(arglist (%cadr val)))
3386	(ppc2-set-nargs seg (ppc2-formlist seg (append (car arglist) (reverse (cadr arglist))) nil))
3387	(! make-stack-gvector))
3388	(ppc2-open-undo $undostkblk)
3389	(setq val ppc::arg_z))
3390	((eq op (%nx1-operator closed-function))
3391	(setq val (ppc2-make-closure seg (cadr val) t))) ; can't error
3392	((eq op (%nx1-operator %make-uvector))
3393	(destructuring-bind (element-count subtag &optional (init 0 init-p)) (%cdr val)
3394	(if init-p
3395	(progn
3396	(ppc2-three-targeted-reg-forms seg element-count ($ ppc::arg_x) subtag ($ ppc::arg_y) init ($ ppc::arg_z))
3397	(! stack-misc-alloc-init))
3398	(progn
3399	(ppc2-two-targeted-reg-forms seg element-count ($ ppc::arg_y) subtag ($ ppc::arg_z))
3400	(! stack-misc-alloc)))
3401	(ppc2-open-undo $undostkblk)
3402	(setq val ($ ppc::arg_z))))))))
3403	val)
3404
3405	(defun ppc2-addrspec-to-reg (seg addrspec reg)
3406	(if (memory-spec-p addrspec)
3407	(ppc2-stack-to-register seg addrspec reg)
3408	(ppc2-copy-register seg reg addrspec)))
3409
3410	(defun ppc2-seq-bind-var (seg var val)
3411	(with-ppc-local-vinsn-macros (seg)
3412	(let* ((sym (var-name var))
3413	(bits (nx-var-bits var))
3414	(closed-p (and (%ilogbitp $vbitclosed bits)
3415	(%ilogbitp $vbitsetq bits)))
3416	(curstack (ppc2-encode-stack))
3417	(make-vcell (and closed-p (eq bits (var-bits var))))
3418	(closed-downward (and closed-p (%ilogbitp $vbitcloseddownward bits))))
3419	(unless (fixnump val)
3420	(setq val (nx-untyped-form val))
3421	(when (and (%ilogbitp $vbitdynamicextent bits) (acode-p val))
3422	(setq val (ppc2-dynamic-extent-form seg curstack val))))
3423	(if (%ilogbitp $vbitspecial bits)
3424	(ppc2-dbind seg val sym)
3425	(let ((puntval nil))
3426	(flet ((ppc2-puntable-binding-p (var initform)
3427	; The value returned is acode.
3428	(let* ((bits (nx-var-bits var)))
3429	(if (%ilogbitp $vbitpuntable bits)
3430	(nx-untyped-form initform)))))
3431	(declare (inline ppc2-puntable-binding-p))
3432	(if (and (not (ppc2-load-ea-p val))
3433	(setq puntval (ppc2-puntable-binding-p var val)))
3434	(progn
3435	(nx-set-var-bits var (%ilogior (%ilsl $vbitpunted 1) bits))
3436	(ppc2-set-var-ea seg var puntval))
3437	(progn
3438	(let* ((vloc ppc2-vstack)
3439	(reg (let* ((r (ppc2-assign-register-var var)))
3440	(if r ($ r)))))
3441	(if (ppc2-load-ea-p val)
3442	(if reg
3443	(ppc2-addrspec-to-reg seg val reg)
3444	(if (memory-spec-p val)
3445	(with-node-temps () (temp)
3446	(ppc2-addrspec-to-reg seg val temp)
3447	(ppc2-vpush-register seg temp :node var bits))
3448	(ppc2-vpush-register seg val :node var bits)))
3449	(if reg
3450	(ppc2-one-targeted-reg-form seg val reg)
3451	(ppc2-vpush-register seg (ppc2-one-untargeted-reg-form seg val ppc::arg_z) :node var bits)))
3452	(ppc2-set-var-ea seg var (or reg (ppc2-vloc-ea vloc closed-p)))
3453	(if reg
3454	(ppc2-note-var-cell var reg)
3455	(ppc2-note-top-cell var))
3456	(when make-vcell
3457	(with-node-temps () (vcell closed)
3458	(ppc2-stack-to-register seg vloc closed)
3459	(if closed-downward
3460	(progn
3461	(! make-tsp-vcell vcell closed)
3462	(ppc2-open-undo $undostkblk))
3463	(! make-vcell vcell closed))
3464	(ppc2-register-to-stack seg vcell vloc))))))))))))
3465
3466
3467
3468	;;; Never make a vcell if this is an inherited var.
3469	;;; If the var's inherited, its bits won't be a fixnum (and will
3470	;;; therefore be different from what NX-VAR-BITS returns.)
3471	(defun ppc2-bind-var (seg var vloc &optional lcell &aux
3472	(bits (nx-var-bits var))
3473	(closed-p (and (%ilogbitp $vbitclosed bits) (%ilogbitp $vbitsetq bits)))
3474	(closed-downward (if closed-p (%ilogbitp $vbitcloseddownward bits)))
3475	(make-vcell (and closed-p (eq bits (var-bits var))))
3476	(addr (ppc2-vloc-ea vloc)))
3477	(with-ppc-local-vinsn-macros (seg)
3478	(if (%ilogbitp $vbitspecial bits)
3479	(progn
3480	(ppc2-dbind seg addr (var-name var))
3481	t)
3482	(progn
3483	(when (%ilogbitp $vbitpunted bits)
3484	(error "bind-var: var ~s was punted" var))
3485	(when make-vcell
3486	(with-node-temps () (vcell closed)
3487	(ppc2-stack-to-register seg vloc closed)
3488	(if closed-downward
3489	(progn
3490	(! make-tsp-vcell vcell closed)
3491	(ppc2-open-undo $undostkblk))
3492	(! make-vcell vcell closed))
3493	(ppc2-register-to-stack seg vcell vloc)))
3494	(when lcell
3495	(setf (lcell-kind lcell) :node
3496	(lcell-attributes lcell) bits
3497	(lcell-info lcell) var)
3498	(ppc2-note-var-cell var lcell))
3499	(ppc2-set-var-ea seg var (ppc2-vloc-ea vloc closed-p))
3500	closed-downward))))
3501
3502	(defun ppc2-set-var-ea (seg var ea)
3503	(setf (var-ea var) ea)
3504	(when (and ppc2-record-symbols (or (typep ea 'lreg) (typep ea 'fixnum)))
3505	(let* ((start (ppc2-emit-note seg :begin-variable-scope)))
3506	(push (list var (var-name var) start (close-vinsn-note start))
3507	ppc2-recorded-symbols)))
3508	ea)
3509
3510	(defun ppc2-close-var (seg var)
3511	(let ((bits (nx-var-bits var)))
3512	(when (and ppc2-record-symbols
3513	(%izerop (%ilogand (%ilogior (ash -1 $vbitspecial)
3514	(%ilsl $vbitpunted 1)) bits)))
3515	(let ((endnote (%car (%cdddr (assq var ppc2-recorded-symbols)))))
3516	(unless endnote (error "ppc2-close-var ?"))
3517	(setf (vinsn-note-class endnote) :end-variable-scope)
3518	(append-dll-node (vinsn-note-label endnote) seg)))))
3519
3520	(defun ppc2-load-ea-p (ea)
3521	(or (typep ea 'fixnum)
3522	(typep ea 'lreg)
3523	(typep ea 'lcell)))
3524
3525	(defun ppc2-dbind (seg value sym)
3526	(with-ppc-local-vinsn-macros (seg)
3527	(let* ((ea-p (ppc2-load-ea-p value))
3528	(nil-p (unless ea-p (eq (setq value (nx-untyped-form value)) nx-nil)))
3529	(self-p (unless ea-p (and (or
3530	(eq (acode-operator value) (%nx1-operator bound-special-ref))
3531	(eq (acode-operator value) (%nx1-operator special-ref)))
3532	(eq (cadr value) sym)))))
3533	(if (or nil-p self-p)
3534	(progn
3535	(ppc2-store-immediate seg (ppc2-symbol-value-svar sym) ppc::temp0)
3536	(if nil-p
3537	(! svar-bind-nil)
3538	(if (or ppc2-reckless (eq (acode-operator value) (%nx1-operator special-ref)))
3539	(! svar-bind-self)
3540	(! svar-bind-self-boundp-check))))
3541	(progn
3542	(if ea-p
3543	(ppc2-store-ea seg value ppc::arg_z)
3544	(ppc2-one-targeted-reg-form seg value ($ ppc::arg_z)))
3545	(ppc2-store-immediate seg (ppc2-symbol-value-svar sym) ($ ppc::temp0))
3546	(! svar-bind)))
3547	(ppc2-open-undo $undospecial)
3548	(ppc2-new-vstack-lcell :special-value ppc2-target-lcell-size 0 sym)
3549	(ppc2-new-vstack-lcell :special ppc2-target-lcell-size (ash 1 $vbitspecial) sym)
3550	(ppc2-new-vstack-lcell :special-link ppc2-target-lcell-size 0 sym)
3551	(ppc2-adjust-vstack (* 3 ppc2-target-node-size)))))
3552
3553	;;; Store the contents of EA - which denotes either a vframe location
3554	;;; or a hard register - in reg.
3555
3556	(defun ppc2-store-ea (seg ea reg)
3557	(if (typep ea 'fixnum)
3558	(if (memory-spec-p ea)
3559	(ppc2-stack-to-register seg ea reg)
3560	(ppc2-copy-register seg reg ea))
3561	(if (typep ea 'lreg)
3562	(ppc2-copy-register seg reg ea)
3563	(if (typep ea 'lcell)
3564	(ppc2-lcell-to-register seg ea reg)))))
3565
3566
3567
3568
3569	;;; Callers should really be sure that this is what they want to use.
3570	(defun ppc2-absolute-natural (seg vreg xfer value)
3571	(with-ppc-local-vinsn-macros (seg vreg xfer)
3572	(when vreg
3573	(ppc2-lri seg vreg value))
3574	(^)))
3575
3576
3577
3578	(defun ppc2-store-macptr (seg vreg address-reg)
3579	(with-ppc-local-vinsn-macros (seg vreg)
3580	(when (ppc2-for-value-p vreg)
3581	(if (logbitp vreg ppc-imm-regs)
3582	(<- address-reg)
3583	(! macptr->heap vreg address-reg)))))
3584
3585	(defun ppc2-store-signed-longword (seg vreg imm-reg)
3586	(with-ppc-local-vinsn-macros (seg vreg)
3587	(when (ppc2-for-value-p vreg)
3588	(if (logbitp vreg ppc-imm-regs)
3589	(<- imm-reg)
3590	(ppc2-box-s32 seg vreg imm-reg)))))
3591
3592	(defun ppc2-store-signed-halfword (seg vreg imm-reg)
3593	(with-ppc-local-vinsn-macros (seg vreg)
3594	(when (ppc2-for-value-p vreg)
3595	(if (logbitp vreg ppc-imm-regs)
3596	(<- imm-reg)
3597	(! s16->fixnum vreg imm-reg)))))
3598
3599
3600	(defun ppc2-store-unsigned-halfword (seg vreg imm-reg)
3601	(with-ppc-local-vinsn-macros (seg vreg)
3602	(when (ppc2-for-value-p vreg)
3603	(if (logbitp vreg ppc-imm-regs)
3604	(<- imm-reg)
3605	(! u16->fixnum vreg imm-reg)))))
3606
3607
3608
3609	;;; If "value-first-p" is true and both "offset" and "val" need to be
3610	;;; evaluated, evaluate "val" before evaluating "offset".
3611	(defun ppc2-%immediate-set-ptr (seg vreg xfer ptr offset val value-first-p)
3612	(with-ppc-local-vinsn-macros (seg vreg xfer)
3613	(let* ((intval (acode-absolute-ptr-p val))
3614	(offval (acode-fixnum-form-p offset))
3615	(absptr (and offval (acode-absolute-ptr-p ptr)))
3616	(for-value (ppc2-for-value-p vreg)))
3617	(flet ((address-and-node-regs ()
3618	(if for-value
3619	(progn
3620	(ppc2-one-targeted-reg-form seg val ($ ppc::arg_z))
3621	(if (eq intval 0)
3622	(values ppc::rzero ppc::arg_z)
3623	(progn
3624	(if intval
3625	(ppc2-lri seg ppc::imm0 intval)
3626	(! deref-macptr ppc::imm0 ppc::arg_z))
3627	(values ppc::imm0 ppc::arg_z))))
3628	(if (eq intval 0)
3629	(values ppc::rzero nil)
3630	(values (ppc2-macptr-arg-to-reg seg val ($ ppc::imm0 :mode :address)) nil)))))
3631	(if (and absptr offval)
3632	(setq absptr (+ absptr offval) offval 0)
3633	(setq absptr nil))
3634	(and offval (%i> (integer-length offval) 15) (setq offval nil))
3635	(and absptr (%i> (integer-length absptr) 15) (setq absptr nil))
3636	(if absptr
3637	(multiple-value-bind (address node) (address-and-node-regs)
3638	(! mem-set-c-fullword address ppc::rzero absptr)
3639	(if for-value
3640	(<- node)))
3641	; No absolute ptr (which is presumably a rare case anyway.)
3642	(if offval
3643	; Easier: need one less register than in the general case.
3644	(with-imm-target () (ptr-reg :address)
3645	(ppc2-one-targeted-reg-form seg ptr ptr-reg)
3646	(if intval
3647	(with-imm-target (ptr-reg) (val-target :address)
3648	(if (eql intval 0)
3649	(setq val-target ppc::rzero)
3650	(ppc2-lri seg val-target intval))
3651	(! mem-set-c-fullword val-target ptr-reg offval)
3652	(if for-value
3653	(<- (set-regspec-mode val-target (gpr-mode-name-value :address)))))
3654	(progn
3655	(! temp-push-unboxed-word ptr-reg)
3656	(ppc2-open-undo $undostkblk)
3657	(multiple-value-bind (address node) (address-and-node-regs)
3658	(with-imm-target (address) (ptr-reg :address)
3659	(! temp-pop-unboxed-word ptr-reg)
3660	(ppc2-close-undo)
3661	(! mem-set-c-fullword address ptr-reg offval)
3662	(if for-value
3663	(<- node)))))))
3664	;; No (16-bit) constant offset. Might still have a 32-bit constant offset;
3665	;; might have a constant value. Might not. Might not.
3666	;; Easiest to special-case the constant-value case first ...
3667	(let* ((xptr-reg nil)
3668	(xoff-reg nil)
3669	(xval-reg nil)
3670	(node-arg_z nil)
3671	(constant-offset (acode-fixnum-form-p offset)))
3672	(if intval
3673	(if constant-offset
3674	(with-imm-target () (ptr-reg :address)
3675	(ppc2-one-targeted-reg-form seg ptr ptr-reg)
3676	(with-imm-target (ptr-reg) (off-reg :s32)
3677	(ppc2-lri seg off-reg constant-offset)
3678	(with-imm-target (ptr-reg off-reg) (val-reg :address)
3679	(if (eql intval 0)
3680	(setq val-reg ppc::rzero)
3681	(ppc2-lri seg val-reg intval))
3682	(setq xptr-reg ptr-reg
3683	xoff-reg off-reg
3684	xval-reg val-reg))))
3685	; Offset's non-constant. Temp-push the pointer, evaluate
3686	; and unbox the offset, load the value, pop the pointer.
3687	(progn
3688	(with-imm-target () (ptr-reg :address)
3689	(ppc2-one-targeted-reg-form seg ptr ptr-reg)
3690	(! temp-push-unboxed-word ptr-reg)
3691	(ppc2-open-undo $undostkblk))
3692	(with-imm-target () (off-reg :s32)
3693	(! fixnum->s32 off-reg (ppc2-one-targeted-reg-form seg offset ($ ppc::arg_z)))
3694	(with-imm-target (off-reg) (val-reg :s32)
3695	(if (eql intval 0)
3696	(setq val-reg ppc::rzero)
3697	(ppc2-lri seg val-reg intval))
3698	(with-imm-target (off-reg val-reg) (ptr-reg :address)
3699	(! temp-pop-unboxed-word ptr-reg)
3700	(ppc2-close-undo)
3701	(setq xptr-reg ptr-reg
3702	xoff-reg off-reg
3703	xval-reg val-reg))))))
3704	;; No intval; maybe constant-offset.
3705	(with-imm-target () (ptr-reg :address)
3706	(ppc2-one-targeted-reg-form seg ptr ptr-reg)
3707	(! temp-push-unboxed-word ptr-reg)
3708	(ppc2-open-undo $undostkblk)
3709	(if (or constant-offset (not value-first-p))
3710	(progn
3711	(if (not constant-offset)
3712	(ppc2-vpush-register seg (ppc2-one-untargeted-reg-form seg offset ppc::arg_z)))
3713	(multiple-value-bind (address node) (address-and-node-regs)
3714	(with-imm-target (address) (off-reg :s32)
3715	(if constant-offset
3716	(ppc2-lri seg off-reg constant-offset)
3717	(with-node-temps (ppc::arg_z) (temp)
3718	(ppc2-vpop-register seg temp)
3719	(! fixnum->s32 off-reg temp)))
3720	(with-imm-target (ppc::imm0 off-reg) (ptr-reg :address)
3721	(! temp-pop-unboxed-word ptr-reg)
3722	(ppc2-close-undo)
3723	(setq xptr-reg ptr-reg
3724	xoff-reg off-reg
3725	xval-reg address
3726	node-arg_z node)))))
3727	(progn
3728	; The "for-value" case can't happen here.
3729	(with-imm-target (ptr-reg) (address :address)
3730	(ppc2-two-targeted-reg-forms seg val address offset ($ ppc::arg_z))
3731	(with-imm-target (address ptr-reg) (off-reg :s32)
3732	(! fixnum->s32 off-reg ppc::arg_z)
3733	(! temp-pop-unboxed-word ptr-reg)
3734	(ppc2-close-undo)
3735	(setq xptr-reg ptr-reg
3736	xoff-reg off-reg
3737	xval-reg address
3738	node-arg_z nil)))))))
3739	(! mem-set-fullword xval-reg xptr-reg xoff-reg)
3740	(when for-value
3741	(if node-arg_z
3742	(<- node-arg_z)
3743	(<- (set-regspec-mode
3744	xval-reg
3745	(gpr-mode-name-value :address))))))))
3746	(^)))))
3747
3748	(defun ppc2-memory-store-displaced (seg valreg basereg displacement size deref)
3749	(with-ppc-local-vinsn-macros (seg)
3750	(if deref
3751	(! mem-ref-c-fullword basereg basereg 0))
3752	(case size
3753	(4 (! mem-set-c-fullword valreg basereg displacement))
3754	(2 (! mem-set-c-halfword valreg basereg displacement))
3755	(1 (! mem-set-c-byte valreg basereg displacement)))))
3756
3757	(defun ppc2-memory-store-indexed (seg valreg basereg idxreg size deref)
3758	(with-ppc-local-vinsn-macros (seg)
3759	(if deref
3760	(! mem-ref-c-fullword basereg basereg 0))
3761	(case size
3762	(4 (! mem-set-fullword valreg basereg idxreg))
3763	(2 (! mem-set-halfword valreg basereg idxreg))
3764	(1 (! mem-set-byte valreg basereg idxreg)))))
3765
3766	(defun ppc2-%immediate-store (seg vreg xfer bits ptr offset val value-first-p)
3767	(with-ppc-local-vinsn-macros (seg vreg xfer)
3768	(if (eql 0 (%ilogand #xf bits))
3769	(ppc2-%immediate-set-ptr seg vreg xfer ptr offset val value-first-p)
3770	(let* ((deref (%ilogbitp 4 bits))
3771	(size
3772	(if (eq (setq bits (%ilogand2 #xf bits)) 3)
3773	1
3774	(if (eq bits 2)
3775	2
3776	4)))
3777	(long-p (eq bits 1))
3778	(intval (if long-p (ppc2-long-constant-p val) (acode-fixnum-form-p val)))
3779	(offval (acode-fixnum-form-p offset))
3780	(absptr (unless deref (and offval (acode-absolute-ptr-p ptr))))
3781	(for-value (ppc2-for-value-p vreg)))
3782	(declare (fixnum size))
3783	(flet ((val-to-argz-and-imm0 ()
3784	(ppc2-one-targeted-reg-form seg val ($ ppc::arg_z))
3785	(if (eq size 4)
3786	(! getxlong)
3787	(! fixnum->s32 ppc::imm0 ppc::arg_z))))
3788	(if (and absptr offval)
3789	(setq absptr (+ absptr offval) offval 0)
3790	(setq absptr nil))
3791	(and offval (%i> (integer-length offval) 15) (setq offval nil))
3792	(and absptr (%i> (integer-length absptr) 15) (setq absptr nil))
3793	(if absptr
3794	(if intval
3795	(with-imm-target () (val-target :s32)
3796	(if (eql intval 0)
3797	(setq val-target ppc::rzero)
3798	(ppc2-lri seg val-target intval))
3799	(ppc2-memory-store-displaced seg val-target ppc::rzero absptr size nil)
3800	(if for-value
3801	(<- (set-regspec-mode
3802	val-target
3803	(gpr-mode-name-value
3804	(if (eq size 4)
3805	:s32
3806	(if (eq size 2)
3807	:s16
3808	:s8)))))))
3809	(progn
3810	(val-to-argz-and-imm0)
3811	(ppc2-memory-store-displaced seg ppc::imm0 ppc::rzero absptr size nil)
3812	(<- ppc::arg_z)))
3813	; No absolute ptr (which is presumably a rare case anyway.)
3814	(if offval
3815	; Easier: need one less register than in the general case.
3816	(with-imm-target () (ptr-reg :address)
3817	(ppc2-one-targeted-reg-form seg ptr ptr-reg)
3818	(if intval
3819	(with-imm-target (ptr-reg) (val-target :s32)
3820	(if (eql intval 0)
3821	(setq val-target ppc::rzero)
3822	(ppc2-lri seg val-target intval))
3823	(ppc2-memory-store-displaced seg val-target ptr-reg offval size deref)
3824	(if for-value
3825	(<- (set-regspec-mode
3826	val-target
3827	(gpr-mode-name-value
3828	(if (eq size 4)
3829	:s32
3830	(if (eq size 2)
3831	:s16
3832	:s8)))))))
3833	(progn
3834	(! temp-push-unboxed-word ptr-reg)
3835	(ppc2-open-undo $undostkblk)
3836	(val-to-argz-and-imm0)
3837	(with-imm-target (ppc::imm0) (ptr-reg :address)
3838	(! temp-pop-unboxed-word ptr-reg)
3839	(ppc2-close-undo)
3840	(ppc2-memory-store-displaced seg ppc::imm0 ptr-reg offval size deref)
3841	(if for-value
3842	(<- ppc::arg_z))))))
3843	;; No (16-bit) constant offset. Might still have a 32-bit constant offset;
3844	;; might have a constant value. Might not. Might not.
3845	;; Easiest to special-case the constant-value case first ...
3846	(let* ((xptr-reg nil)
3847	(xoff-reg nil)
3848	(xval-reg nil)
3849	(node-arg_z nil)
3850	(constant-offset (acode-fixnum-form-p offset)))
3851	(if intval
3852	(if constant-offset
3853	(with-imm-target () (ptr-reg :address)
3854	(ppc2-one-targeted-reg-form seg ptr ptr-reg)
3855	(with-imm-target (ptr-reg) (off-reg :s32)
3856	(ppc2-lri seg off-reg constant-offset)
3857	(with-imm-target (ptr-reg off-reg) (val-reg :s32)
3858	(if (eql intval 0)
3859	(setq val-reg ppc::rzero)
3860	(ppc2-lri seg val-reg intval))
3861	(setq xptr-reg ptr-reg
3862	xoff-reg off-reg
3863	xval-reg val-reg))))
3864	; Offset's non-constant. Temp-push the pointer, evaluate
3865	; and unbox the offset, load the value, pop the pointer.
3866	(progn
3867	(with-imm-target () (ptr-reg :address)
3868	(ppc2-one-targeted-reg-form seg ptr ptr-reg)
3869	(! temp-push-unboxed-word ptr-reg)
3870	(ppc2-open-undo $undostkblk))
3871	(with-imm-target () (off-reg :s32)
3872	(! fixnum->s32 off-reg (ppc2-one-targeted-reg-form seg offset ($ ppc::arg_z)))
3873	(with-imm-target (off-reg) (val-reg :s32)
3874	(if (eql intval 0)
3875	(setq val-reg ppc::rzero)
3876	(ppc2-lri seg val-reg intval))
3877	(with-imm-target (off-reg val-reg) (ptr-reg :address)
3878	(! temp-pop-unboxed-word ptr-reg)
3879	(ppc2-close-undo)
3880	(setq xptr-reg ptr-reg
3881	xoff-reg off-reg
3882	xval-reg val-reg))))))
3883	;; No intval; maybe constant-offset.
3884	(with-imm-target () (ptr-reg :address)
3885	(ppc2-one-targeted-reg-form seg ptr ptr-reg)
3886	(! temp-push-unboxed-word ptr-reg)
3887	(ppc2-open-undo $undostkblk)
3888	(if (or constant-offset (not value-first-p))
3889	(progn
3890	(if (not constant-offset)
3891	(ppc2-vpush-register seg (ppc2-one-untargeted-reg-form seg offset ppc::arg_z)))
3892	(val-to-argz-and-imm0)
3893	(with-imm-target (ppc::imm0) (off-reg :s32)
3894	(if constant-offset
3895	(ppc2-lri seg off-reg constant-offset)
3896	(with-node-temps (ppc::arg_z) (temp)
3897	(ppc2-vpop-register seg temp)
3898	(! fixnum->s32 off-reg temp)))
3899	(with-imm-target (ppc::imm0 off-reg) (ptr-reg :address)
3900	(! temp-pop-unboxed-word ptr-reg)
3901	(ppc2-close-undo)
3902	(setq xptr-reg ptr-reg
3903	xoff-reg off-reg
3904	xval-reg ppc::imm0
3905	node-arg_z t))))
3906	(let* ((rval ($ ppc::arg_z))
3907	(roffset ($ ppc::arg_y)))
3908	(ppc2-two-targeted-reg-forms seg val rval offset roffset)
3909	(if (eq size 4)
3910	(! getXlong)
3911	(! fixnum->s32 ppc::imm0 rval))
3912	(with-imm-target (ppc::imm0) (off-reg :s32)
3913	(! fixnum->s32 off-reg roffset)
3914	(with-imm-target (ppc::imm0 off-reg) (ptr-reg :address)
3915	(! temp-pop-unboxed-word ptr-reg)
3916	(ppc2-close-undo)
3917	(setq xptr-reg ptr-reg
3918	xoff-reg off-reg
3919	xval-reg ppc::imm0
3920	node-arg_z nil)))))))
3921	(ppc2-memory-store-indexed seg xval-reg xptr-reg xoff-reg size deref)
3922	(when for-value
3923	(if node-arg_z
3924	(<- ppc::arg_z)
3925	(<- (set-regspec-mode
3926	xval-reg
3927	(gpr-mode-name-value
3928	(if (eq size 4)
3929	:s32
3930	(if (eq size 2)
3931	:s16
3932	:s8))))))))))
3933	(^))))))
3934
3935
3936
3937
3938
3939	(defun ppc2-encoding-undo-count (encoding)
3940	(svref encoding 0))
3941
3942	(defun ppc2-encoding-cstack-depth (encoding) ; hardly ever interesting
3943	(svref encoding 1))
3944
3945	(defun ppc2-encoding-vstack-depth (encoding)
3946	(svref encoding 2))
3947
3948	(defun ppc2-encoding-vstack-top (encoding)
3949	(svref encoding 3))
3950
3951	(defun ppc2-encode-stack ()
3952	(vector ppc2-undo-count ppc2-cstack ppc2-vstack ppc2-top-vstack-lcell))
3953
3954	(defun ppc2-decode-stack (encoding)
3955	(values (ppc2-encoding-undo-count encoding)
3956	(ppc2-encoding-cstack-depth encoding)
3957	(ppc2-encoding-vstack-depth encoding)
3958	(ppc2-encoding-vstack-top encoding)))
3959
3960	(defun ppc2-equal-encodings-p (a b)
3961	(dotimes (i 3 t)
3962	(unless (eq (svref a i) (svref b i)) (return))))
3963
3964	(defun ppc2-open-undo (&optional (reason $undocatch) (curstack (ppc2-encode-stack)))
3965	(set-fill-pointer
3966	ppc2-undo-stack
3967	(set-fill-pointer ppc2-undo-because ppc2-undo-count))
3968	(vector-push-extend curstack ppc2-undo-stack)
3969	(vector-push-extend reason ppc2-undo-because)
3970	(setq ppc2-undo-count (%i+ ppc2-undo-count 1)))
3971
3972	(defun ppc2-close-undo (&aux
3973	(new-count (%i- ppc2-undo-count 1))
3974	(i (aref ppc2-undo-stack new-count)))
3975	(multiple-value-setq (ppc2-undo-count ppc2-cstack ppc2-vstack ppc2-top-vstack-lcell)
3976	(ppc2-decode-stack i))
3977	(set-fill-pointer
3978	ppc2-undo-stack
3979	(set-fill-pointer ppc2-undo-because new-count)))
3980
3981
3982
3983
3984
3985	;;; "Trivial" means can be evaluated without allocating or modifying registers.
3986	;;; Interim definition, which will probably stay here forever.
3987	(defun ppc2-trivial-p (form &aux op bits)
3988	(setq form (nx-untyped-form form))
3989	(and
3990	(consp form)
3991	(not (eq (setq op (%car form)) (%nx1-operator call)))
3992	(or
3993	(nx-null form)
3994	(nx-t form)
3995	(eq op (%nx1-operator simple-function))
3996	(eq op (%nx1-operator fixnum))
3997	(eq op (%nx1-operator immediate))
3998	#+nil
3999	(eq op (%nx1-operator bound-special-ref))
4000	(and (or (eq op (%nx1-operator inherited-arg))
4001	(eq op (%nx1-operator lexical-reference)))
4002	(or (%ilogbitp $vbitpunted (setq bits (nx-var-bits (cadr form))))
4003	(neq (%ilogior (%ilsl $vbitclosed 1) (%ilsl $vbitsetq 1))
4004	(%ilogand (%ilogior (%ilsl $vbitclosed 1) (%ilsl $vbitsetq 1)) bits)))))))
4005
4006	(defun ppc2-lexical-reference-p (form)
4007	(when (acode-p form)
4008	(let ((op (acode-operator (setq form (acode-unwrapped-form form)))))
4009	(when (or (eq op (%nx1-operator lexical-reference))
4010	(eq op (%nx1-operator inherited-arg)))
4011	(%cadr form)))))
4012
4013	(defun ppc2-ref-symbol-value (seg vreg xfer sym check-boundp)
4014	(with-ppc-local-vinsn-macros (seg vreg xfer)
4015	(when vreg
4016	(let* ((src ($ ppc::temp0))
4017	(dest ($ ppc::arg_z)))
4018	(ppc2-store-immediate seg (ppc2-symbol-value-svar sym) src)
4019	(if check-boundp
4020	(! svar-ref-symbol-value dest src)
4021	(! %svar-ref-symbol-value dest src))
4022	(<- dest)))
4023	(^)))
4024
4025	;;; Should be less eager to box result
4026	(defun ppc2-extract-charcode (seg vreg xfer char safe)
4027	(with-ppc-local-vinsn-macros (seg vreg xfer)
4028	(let* ((src (ppc2-one-untargeted-reg-form seg char ppc::arg_z)))
4029	(when safe
4030	(! trap-unless-character src))
4031	(if vreg
4032	(ensuring-node-target (target vreg)
4033	(! character->fixnum target src)))
4034	(^))))
4035
4036	(defun ppc2-reference-list (seg vreg xfer listform safe refcdr)
4037	(if (ppc2-form-typep listform 'list)
4038	(setq safe nil)) ; May also have been passed as NIL.
4039	(with-ppc-local-vinsn-macros (seg vreg xfer)
4040	(let* ((src (ppc2-one-untargeted-reg-form seg listform ppc::arg_z)))
4041	(when safe
4042	(! trap-unless-list src))
4043	(if vreg
4044	(ensuring-node-target (target vreg)
4045	(if refcdr
4046	(! %cdr target src)
4047	(! %car target src))))
4048	(^))))
4049
4050	;;; If safe, ensure that index is a fixnum (if non-constant)
4051	;;; and check vector bound.
4052	;;; If we're going to have to evaluate the index into a register (to do
4053	;;; the bounds check), but know that the index could be a constant 16-bit
4054	;;; displacement, this'll look pretty silly ..
4055	(defun ppc2-misc-node-ref (seg vreg xfer miscobj index safe)
4056	(with-ppc-local-vinsn-macros (seg vreg xfer)
4057	(let* ((index-known-fixnum (acode-fixnum-form-p index))
4058	(arch (backend-target-arch target-backend))
4059	(unscaled-idx nil)
4060	(src nil))
4061	(if (or safe (not index-known-fixnum))
4062	(multiple-value-setq (src unscaled-idx)
4063	(ppc2-two-untargeted-reg-forms seg miscobj ppc::arg_y index ppc::arg_z))
4064	(setq src (ppc2-one-untargeted-reg-form seg miscobj ppc::arg_z)))
4065	(when safe
4066	(if (typep safe 'fixnum)
4067	(! trap-unless-typecode= src safe))
4068	(unless index-known-fixnum
4069	(! trap-unless-fixnum unscaled-idx))
4070	(! check-misc-bound unscaled-idx src))
4071	(when vreg
4072	(ensuring-node-target (target vreg)
4073	(if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-32-bit-constant-index arch)))
4074	(progn
4075	(! misc-ref-c-node target src index-known-fixnum))
4076	(let* ((idx-reg ppc::imm0))
4077	(if index-known-fixnum
4078	(ppc2-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 2)))
4079	(! scale-32bit-misc-index idx-reg unscaled-idx))
4080	(! misc-ref-node target src idx-reg)))))
4081	(^))))
4082
4083	(defun ppc2-misc-node-set (seg vreg xfer miscobj index value safe)
4084	(with-ppc-local-vinsn-macros (seg vreg xfer)
4085	(multiple-value-bind (src unscaled-idx val-reg)
4086	(ppc2-three-targeted-reg-forms seg miscobj ($ ppc::arg_x) index ($ ppc::arg_y) value ($ ppc::arg_z))
4087	(when safe
4088	(if (typep safe 'fixnum)
4089	(! trap-unless-typecode= src safe))
4090	(! trap-unless-fixnum unscaled-idx)
4091	(! check-misc-bound unscaled-idx src))
4092	(! call-subprim-3 val-reg .SPgvset src unscaled-idx val-reg)
4093	(<- val-reg)
4094	(^))))
4095
4096
4097
4098	(defun ppc2-misc-byte-count (subtag element-count)
4099	(funcall (arch::target-array-data-size-function
4100	(backend-target-arch target-backend))
4101	subtag element-count))
4102
4103
4104	;;; The naive approach is to vpush all of the initforms, allocate the
4105	;;; miscobj, then sit in a loop vpopping the values into the vector.
4106	;;; That's "naive" when most of the initforms in question are
4107	;;; "side-effect-free" (constant references or references to un-SETQed
4108	;;; lexicals), in which case it makes more sense to just store the
4109	;;; things into the vector cells, vpushing/ vpopping only those things
4110	;;; that aren't side-effect-free. (It's necessary to evaluate any
4111	;;; non-trivial forms before allocating the miscobj, since that
4112	;;; ensures that the initforms are older (in the EGC sense) than it
4113	;;; is.) The break-even point space-wise is when there are around 3
4114	;;; non-trivial initforms to worry about.
4115
4116
4117	(defun ppc2-allocate-initialized-gvector (seg vreg xfer subtag initforms)
4118	(with-ppc-local-vinsn-macros (seg vreg xfer)
4119	(if (null vreg)
4120	(dolist (f initforms) (ppc2-form seg nil nil f))
4121	(let* ((ppc2-vstack ppc2-vstack)
4122	(ppc2-top-vstack-lcell ppc2-top-vstack-lcell)
4123	(arch (backend-target-arch target-backend))
4124	(n (length initforms))
4125	(nntriv (let* ((count 0))
4126	(declare (fixnum count))
4127	(dolist (f initforms count)
4128	(unless (ppc-side-effect-free-form-p f)
4129	(incf count)))))
4130	(header (arch::make-vheader n subtag)))
4131	(declare (fixnum n nntriv))
4132	(cond ( (or ppc2-open-code-inline (> nntriv 3))
4133	(ppc2-formlist seg initforms nil)
4134	(ppc2-lri seg ppc::imm0 header)
4135	(! %ppc-gvector vreg ppc::imm0 (ash n (arch::target-word-shift arch))))
4136	(t
4137	(let* ((pending ())
4138	(vstack ppc2-vstack))
4139	(declare (fixnum vstack))
4140	(dolist (form initforms)
4141	(if (ppc-side-effect-free-form-p form)
4142	(push form pending)
4143	(progn
4144	(push nil pending)
4145	(ppc2-vpush-register seg (ppc2-one-untargeted-reg-form seg form ppc::arg_z)))))
4146	(ppc2-lri seg ppc::imm0 header)
4147	(ensuring-node-target (target vreg)
4148	(! %alloc-misc-fixed target ppc::imm0 (ash n (arch::target-word-shift arch)))
4149	(with-node-temps (target) (nodetemp)
4150	(do* ((forms pending (cdr forms))
4151	(index (1- n) (1- index))
4152	(pushed-cell (+ vstack (the fixnum (ash nntriv (arch::target-word-shift arch))))))
4153	((null forms))
4154	(declare (list forms) (fixnum pushed-cell))
4155	(let* ((form (car forms))
4156	(reg nodetemp))
4157	(if form
4158	(setq reg (ppc2-one-untargeted-reg-form seg form nodetemp))
4159	(progn
4160	(decf pushed-cell ppc2-target-node-size)
4161	(ppc2-stack-to-register seg (ppc2-vloc-ea pushed-cell) nodetemp)))
4162	(! misc-set-c-node reg target index)))))
4163	(! vstack-discard nntriv))
4164	))))
4165	(^)))
4166
4167	;;; Heap-allocated constants -might- need memoization: they might be newly-created,
4168	;;; as in the case of synthesized toplevel functions in .pfsl files.
4169	(defun ppc2-acode-needs-memoization (valform)
4170	(if (ppc2-form-typep valform 'fixnum)
4171	nil
4172	(let* ((val (acode-unwrapped-form valform)))
4173	(if (or (eq val nx-t)
4174	(eq val nx-nil)
4175	(and (acode-p val)
4176	(let* ((op (acode-operator val)))
4177	(or (eq op (%nx1-operator fixnum)) #\|(eq op (%nx1-operator immediate))\|#))))
4178	nil
4179	t))))
4180
4181	(defun ppc2-modify-cons (seg vreg xfer ptrform valform safe setcdr returnptr)
4182	(if (ppc2-form-typep ptrform 'cons)
4183	(setq safe nil)) ; May also have been passed as NIL.
4184	(with-ppc-local-vinsn-macros (seg vreg xfer)
4185	(multiple-value-bind (ptr-vreg val-vreg) (ppc2-two-targeted-reg-forms seg ptrform ($ ppc::arg_y) valform ($ ppc::arg_z))
4186	(when safe
4187	(! trap-unless-cons ptr-vreg))
4188	(if setcdr
4189	(! call-subprim-2 ($ ppc::arg_z) .SPrplacd ptr-vreg val-vreg)
4190	(! call-subprim-2 ($ ppc::arg_z) .SPrplaca ptr-vreg val-vreg))
4191	(if returnptr
4192	(<- ptr-vreg)
4193	(<- val-vreg))
4194	(^))))
4195
4196
4197
4198	(defun ppc2-find-nilret-label ()
4199	(dolist (l ppc2-nilret-labels)
4200	(destructuring-bind (label vsp csp register-restore-count register-restore-ea &rest agenda) l
4201	(and (or (and (eql 0 register-restore-count)
4202	(or (not (eql 0 vsp))
4203	(eq vsp ppc2-vstack)))
4204	(and
4205	(eq register-restore-count ppc2-register-restore-count)
4206	(eq vsp ppc2-vstack)))
4207	(or agenda (eq csp ppc2-cstack))
4208	(eq register-restore-ea ppc2-register-restore-ea)
4209	(eq (%ilsr 1 (length agenda)) ppc2-undo-count)
4210	(dotimes (i (the fixnum ppc2-undo-count) t)
4211	(