source: trunk/source/compiler/PPC/ppc2.lisp @ 8752

Last change on this file since 8752 was 8752, checked in by gb, 13 years ago

Complain about calls to side-effeccting functions where the result is
(obviously) unused.

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