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