source: trunk/ccl/compiler/PPC/ppc2.lisp @ 1254

Last change on this file since 1254 was 1254, checked in by gb, 16 years ago

Hide a few more ppc32 dependencies. Still issues when native typecodes
are involved (%gvector, %alloc-misc, etc.)

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