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

Last change on this file since 16176 was 16176, checked in by gb, 7 years ago

Don't refuse to inline if &REST is present in NX1-LAMBDA-BIND. (We still punt on &LEXPR and &KEY; we could
handle &KEY with constant keywords if we really wanted to.)

Handling &REST means that we have to have a mechanism for eliminating it in the backends; failure to handle/
eliminate &REST led to excessive consing in CALL-NEXT-METHOD. This fixes ticket:1220 in the trunk.)

I haven't tested (or even natively compiled) the ARM and PPC backend changes yet.

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