1.0.1.18:
[sbcl.git] / src / compiler / hppa / insts.lisp
1 ;;;; the instruction set definition for HPPA
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
11
12 (in-package "SB!VM")
13
14 (eval-when (:compile-toplevel :load-toplevel :execute)
15   (setf sb!assem:*assem-scheduler-p* nil))
16 \f
17 ;;;; Utility functions.
18
19 (defun reg-tn-encoding (tn)
20   (declare (type tn tn))
21   (sc-case tn
22     (null null-offset)
23     (zero zero-offset)
24     (t
25      (aver (eq (sb-name (sc-sb (tn-sc tn))) 'registers))
26      (tn-offset tn))))
27
28 (defun fp-reg-tn-encoding (tn)
29   (declare (type tn tn))
30   (sc-case tn
31     (fp-single-zero (values 0 nil))
32     (single-reg (values (tn-offset tn) nil))
33     (fp-double-zero (values 0 t))
34     (double-reg (values (tn-offset tn) t))))
35
36 (defconstant-eqx compare-conditions
37   '(:never := :< :<= :<< :<<= :sv :od :tr :<> :>= :> :>>= :>> :nsv :ev)
38   #'equalp)
39
40 (deftype compare-condition ()
41   `(member nil ,@compare-conditions))
42
43 (defun compare-condition (cond)
44   (declare (type compare-condition cond))
45   (if cond
46       (let ((result (or (position cond compare-conditions :test #'eq)
47                         (error "Bogus Compare/Subtract condition: ~S" cond))))
48         (values (ldb (byte 3 0) result)
49                 (logbitp 3 result)))
50       (values 0 nil)))
51
52 (defconstant-eqx add-conditions
53   '(:never := :< :<= :nuv :znv :sv :od :tr :<> :>= :> :uv :vnz :nsv :ev)
54   #'equalp)
55
56 (deftype add-condition ()
57   `(member nil ,@add-conditions))
58
59 (defun add-condition (cond)
60     (declare (type add-condition cond))
61   (if cond
62       (let ((result (or (position cond add-conditions :test #'eq)
63                         (error "Bogus Add condition: ~S" cond))))
64         (values (ldb (byte 3 0) result)
65                 (logbitp 3 result)))
66       (values 0 nil)))
67
68 (defconstant-eqx logical-conditions
69   '(:never := :< :<= nil nil nil :od :tr :<> :>= :> nil nil nil :ev)
70   #'equalp)
71
72 (deftype logical-condition ()
73   `(member nil ,@(remove nil logical-conditions)))
74
75 (defun logical-condition (cond)
76     (declare (type logical-condition cond))
77   (if cond
78       (let ((result (or (position cond logical-conditions :test #'eq)
79                         (error "Bogus Logical condition: ~S" cond))))
80         (values (ldb (byte 3 0) result)
81                 (logbitp 3 result)))
82       (values 0 nil)))
83
84 (defconstant-eqx unit-conditions
85   '(:never nil :sbz :shz :sdc :sbc :shc :tr nil :nbz :nhz :ndc :nbc :nhc)
86   #'equalp)
87
88 (deftype unit-condition ()
89   `(member nil ,@(remove nil unit-conditions)))
90
91 (defun unit-condition (cond)
92   (declare (type unit-condition cond))
93   (if cond
94       (let ((result (or (position cond unit-conditions :test #'eq)
95                         (error "Bogus Unit condition: ~S" cond))))
96         (values (ldb (byte 3 0) result)
97                 (logbitp 3 result)))
98       (values 0 nil)))
99
100 (defconstant-eqx extract/deposit-conditions
101   '(:never := :< :od :tr :<> :>= :ev)
102   #'equalp)
103
104 (deftype extract/deposit-condition ()
105   `(member nil ,@extract/deposit-conditions))
106
107 (defun extract/deposit-condition (cond)
108   (declare (type extract/deposit-condition cond))
109   (if cond
110       (or (position cond extract/deposit-conditions :test #'eq)
111           (error "Bogus Extract/Deposit condition: ~S" cond))
112       0))
113
114
115 (defun space-encoding (space)
116   (declare (type (unsigned-byte 3) space))
117   (dpb (ldb (byte 2 0) space)
118        (byte 2 1)
119        (ldb (byte 1 2) space)))
120
121 \f
122 ;;;; Initial disassembler setup.
123
124 (setf sb!disassem:*disassem-inst-alignment-bytes* 4)
125
126 (defvar *disassem-use-lisp-reg-names* t)
127
128 (defparameter reg-symbols
129   (map 'vector
130        #'(lambda (name)
131            (cond ((null name) nil)
132                  (t (make-symbol (concatenate 'string "$" name)))))
133        *register-names*))
134
135 (sb!disassem:define-arg-type reg
136   :printer #'(lambda (value stream dstate)
137                (declare (stream stream) (fixnum value))
138                (let ((regname (aref reg-symbols value)))
139                  (princ regname stream)
140                  (sb!disassem:maybe-note-associated-storage-ref
141                   value
142                   'registers
143                   regname
144                   dstate))))
145
146 (defparameter float-reg-symbols
147   #.(coerce
148      (loop for n from 0 to 31 collect (make-symbol (format nil "$F~d" n)))
149      'vector))
150
151 (sb!disassem:define-arg-type fp-reg
152   :printer #'(lambda (value stream dstate)
153                (declare (stream stream) (fixnum value))
154                (let ((regname (aref float-reg-symbols value)))
155                  (princ regname stream)
156                  (sb!disassem:maybe-note-associated-storage-ref
157                   value
158                   'float-registers
159                   regname
160                   dstate))))
161
162 (sb!disassem:define-arg-type fp-fmt-0c
163   :printer #'(lambda (value stream dstate)
164                (declare (ignore dstate) (stream stream) (fixnum value))
165                (ecase value
166                  (0 (format stream "~A" '\,SGL))
167                  (1 (format stream "~A" '\,DBL))
168                  (3 (format stream "~A" '\,QUAD)))))
169
170 (defun low-sign-extend (x n)
171   (let ((normal (dpb x (byte 1 (1- n)) (ldb (byte (1- n) 1) x))))
172     (if (logbitp 0 x)
173         (logior (ash -1 (1- n)) normal)
174         normal)))
175
176 (defun sign-extend (x n)
177   (if (logbitp (1- n) x)
178       (logior (ash -1 (1- n)) x)
179       x))
180
181 (defun assemble-bits (x list)
182   (let ((result 0)
183         (offset 0))
184     (dolist (e (reverse list))
185       (setf result (logior result (ash (ldb e x) offset)))
186       (incf offset (byte-size e)))
187     result))
188
189 (defmacro define-imx-decode (name bits)
190   `(sb!disassem:define-arg-type ,name
191      :printer #'(lambda (value stream dstate)
192                   (declare (ignore dstate) (stream stream) (fixnum value))
193                   (format stream "~S" (low-sign-extend value ,bits)))))
194
195 (define-imx-decode im5 5)
196 (define-imx-decode im11 11)
197 (define-imx-decode im14 14)
198
199 (sb!disassem:define-arg-type im3
200   :printer #'(lambda (value stream dstate)
201                (declare (ignore dstate) (stream stream) (fixnum value))
202                (format stream "~S" (assemble-bits value `(,(byte 1 0)
203                                                           ,(byte 2 1))))))
204
205 (sb!disassem:define-arg-type im21
206   :printer #'(lambda (value stream dstate)
207                (declare (ignore dstate) (stream stream) (fixnum value))
208                (format stream "~S"
209                        (assemble-bits value `(,(byte 1 0) ,(byte 11 1)
210                                               ,(byte 2 14) ,(byte 5 16)
211                                               ,(byte 2 12))))))
212
213 (sb!disassem:define-arg-type cp
214   :printer #'(lambda (value stream dstate)
215                (declare (ignore dstate) (stream stream) (fixnum value))
216                (format stream "~S" (- 31 value))))
217
218 (sb!disassem:define-arg-type clen
219   :printer #'(lambda (value stream dstate)
220                (declare (ignore dstate) (stream stream) (fixnum value))
221                (format stream "~S" (- 32 value))))
222
223 (sb!disassem:define-arg-type compare-condition
224   :printer #("" \,= \,< \,<= \,<< \,<<= \,SV \,OD \,TR \,<> \,>=
225              \,> \,>>= \,>> \,NSV \,EV))
226
227 (sb!disassem:define-arg-type compare-condition-false
228   :printer #(\,TR \,<> \,>= \,> \,>>= \,>> \,NSV \,EV
229              "" \,= \,< \,<= \,<< \,<<= \,SV \,OD))
230
231 (sb!disassem:define-arg-type add-condition
232   :printer #("" \,= \,< \,<= \,NUV \,ZNV \,SV \,OD \,TR \,<> \,>= \,> \,UV
233              \,VNZ \,NSV \,EV))
234
235 (sb!disassem:define-arg-type add-condition-false
236   :printer #(\,TR \,<> \,>= \,> \,UV \,VNZ \,NSV \,EV
237              "" \,= \,< \,<= \,NUV \,ZNV \,SV \,OD))
238
239 (sb!disassem:define-arg-type logical-condition
240   :printer #("" \,= \,< \,<= "" "" "" \,OD \,TR \,<> \,>= \,> "" "" "" \,EV))
241
242 (sb!disassem:define-arg-type unit-condition
243   :printer #("" "" \,SBZ \,SHZ \,SDC \,SBC \,SHC \,TR "" \,NBZ \,NHZ \,NDC
244              \,NBC \,NHC))
245
246 (sb!disassem:define-arg-type extract/deposit-condition
247   :printer #("" \,= \,< \,OD \,TR \,<> \,>= \,EV))
248
249 (sb!disassem:define-arg-type extract/deposit-condition-false
250   :printer #(\,TR \,<> \,>= \,EV "" \,= \,< \,OD))
251
252 (sb!disassem:define-arg-type nullify
253   :printer #("" \,N))
254
255 (sb!disassem:define-arg-type fcmp-cond
256   :printer #(\FALSE? \FALSE \? \!<=> \= \=T \?= \!<> \!?>= \< \?<
257                      \!>= \!?> \<= \?<= \!> \!?<= \> \?>\ \!<= \!?< \>=
258                      \?>= \!< \!?= \<> \!= \!=T \!? \<=> \TRUE? \TRUE))
259
260 (sb!disassem:define-arg-type integer
261   :printer #'(lambda (value stream dstate)
262                (declare (ignore dstate) (stream stream) (fixnum value))
263                (format stream "~S" value)))
264
265 (sb!disassem:define-arg-type space
266   :printer #("" |1,| |2,| |3,|))
267
268 \f
269 ;;;; Define-instruction-formats for disassembler.
270
271 (sb!disassem:define-instruction-format
272     (load/store 32)
273   (op   :field (byte 6 26))
274   (b    :field (byte 5 21) :type 'reg)
275   (t/r  :field (byte 5 16) :type 'reg)
276   (s    :field (byte 2 14) :type 'space)
277   (im14 :field (byte 14 0) :type 'im14))
278
279 (defconstant-eqx cmplt-index-print '((:cond ((u :constant 1) '\,S))
280                                  (:cond ((m :constant 1) '\,M)))
281   #'equalp)
282
283 (defconstant-eqx cmplt-disp-print '((:cond ((m :constant 1)
284                                   (:cond ((s :constant 0) '\,MA)
285                                          (t '\,MB)))))
286   #'equalp)
287
288 (defconstant-eqx cmplt-store-print '((:cond ((s :constant 0) '\,B)
289                                          (t '\,E))
290                                   (:cond ((m :constant 1) '\,M)))
291   #'equalp)
292
293 (sb!disassem:define-instruction-format
294     (extended-load/store 32)
295   (op1     :field (byte 6 26) :value 3)
296   (b       :field (byte 5 21) :type 'reg)
297   (x/im5/r :field (byte 5 16) :type 'reg)
298   (s       :field (byte 2 14) :type 'space)
299   (u       :field (byte 1 13))
300   (op2     :field (byte 3 10))
301   (ext4/c  :field (byte 4 6))
302   (m       :field (byte 1 5))
303   (t/im5   :field (byte 5 0) :type 'reg))
304
305 (sb!disassem:define-instruction-format
306     (ldil 32 :default-printer '(:name :tab im21 "," t))
307   (op    :field (byte 6 26))
308   (t   :field (byte 5 21) :type 'reg)
309   (im21 :field (byte 21 0) :type 'im21))
310
311 (sb!disassem:define-instruction-format
312     (branch17 32)
313   (op1 :field (byte 6 26))
314   (t   :field (byte 5 21) :type 'reg)
315   (w   :fields `(,(byte 5 16) ,(byte 11 2) ,(byte 1 0))
316        :use-label
317        #'(lambda (value dstate)
318            (declare (type sb!disassem:disassem-state dstate) (list value))
319            (let ((x (logior (ash (first value) 12) (ash (second value) 1)
320                             (third value))))
321              (+ (ash (sign-extend
322                       (assemble-bits x `(,(byte 1 0) ,(byte 5 12) ,(byte 1 1)
323                                          ,(byte 10 2))) 17) 2)
324                 (sb!disassem:dstate-cur-addr dstate) 8))))
325   (op2 :field (byte 3 13))
326   (n   :field (byte 1 1) :type 'nullify))
327
328 (sb!disassem:define-instruction-format
329     (branch12 32)
330   (op1 :field (byte 6 26))
331   (r2  :field (byte 5 21) :type 'reg)
332   (r1  :field (byte 5 16) :type 'reg)
333   (w   :fields `(,(byte 11 2) ,(byte 1 0))
334        :use-label
335        #'(lambda (value dstate)
336            (declare (type sb!disassem:disassem-state dstate) (list value))
337            (let ((x (logior (ash (first value) 1) (second value))))
338              (+ (ash (sign-extend
339                       (assemble-bits x `(,(byte 1 0) ,(byte 1 1) ,(byte 10 2)))
340                       12) 2)
341                 (sb!disassem:dstate-cur-addr dstate) 8))))
342   (c   :field (byte 3 13))
343   (n   :field (byte 1 1) :type 'nullify))
344
345 (sb!disassem:define-instruction-format
346     (branch 32)
347   (op1 :field (byte 6 26))
348   (t   :field (byte 5 21) :type 'reg)
349   (x   :field (byte 5 16) :type 'reg)
350   (op2 :field (byte 3 13))
351   (x1  :field (byte 11 2))
352   (n   :field (byte 1 1) :type 'nullify)
353   (x2  :field (byte 1 0)))
354
355 (sb!disassem:define-instruction-format
356      (r3-inst 32 :default-printer '(:name c :tab r1 "," r2 "," t))
357   (r3 :field (byte 6 26) :value 2)
358   (r2 :field (byte 5 21) :type 'reg)
359   (r1 :field (byte 5 16) :type 'reg)
360   (c  :field (byte 3 13))
361   (f  :field (byte 1 12))
362   (op :field (byte 7 5))
363   (t  :field (byte 5 0) :type 'reg))
364
365 (sb!disassem:define-instruction-format
366     (imm-inst 32 :default-printer '(:name c :tab im11 "," r "," t))
367   (op   :field (byte 6 26))
368   (r    :field (byte 5 21) :type 'reg)
369   (t    :field (byte 5 16) :type 'reg)
370   (c    :field (byte 3 13))
371   (f    :field (byte 1 12))
372   (o    :field (byte 1 11))
373   (im11 :field (byte 11 0) :type 'im11))
374
375 (sb!disassem:define-instruction-format
376     (extract/deposit-inst 32)
377   (op1    :field (byte 6 26))
378   (r2     :field (byte 5 21) :type 'reg)
379   (r1     :field (byte 5 16) :type 'reg)
380   (c      :field (byte 3 13) :type 'extract/deposit-condition)
381   (op2    :field (byte 3 10))
382   (cp     :field (byte 5 5) :type 'cp)
383   (t/clen :field (byte 5 0) :type 'clen))
384
385 (sb!disassem:define-instruction-format
386     (break 32 :default-printer '(:name :tab im13 "," im5))
387   (op1  :field (byte 6 26) :value 0)
388   (im13 :field (byte 13 13))
389   (q2   :field (byte 8 5) :value 0)
390   (im5  :field (byte 5 0)))
391
392 (defun snarf-error-junk (sap offset &optional length-only)
393   (let* ((length (sb!sys:sap-ref-8 sap offset))
394          (vector (make-array length :element-type '(unsigned-byte 8))))
395     (declare (type sb!sys:system-area-pointer sap)
396              (type (unsigned-byte 8) length)
397              (type (simple-array (unsigned-byte 8) (*)) vector))
398     (cond (length-only
399            (values 0 (1+ length) nil nil))
400           (t
401            (sb!kernel:copy-ub8-from-system-area sap (1+ offset)
402                                                 vector 0 length)
403            (collect ((sc-offsets)
404                      (lengths))
405              (lengths 1)                ; the length byte
406              (let* ((index 0)
407                     (error-number (sb!c:read-var-integer vector index)))
408                (lengths index)
409                (loop
410                  (when (>= index length)
411                    (return))
412                  (let ((old-index index))
413                    (sc-offsets (sb!c:read-var-integer vector index))
414                    (lengths (- index old-index))))
415                (values error-number
416                        (1+ length)
417                        (sc-offsets)
418                        (lengths))))))))
419
420 (defun break-control (chunk inst stream dstate)
421   (declare (ignore inst))
422   (flet ((nt (x) (if stream (sb!disassem:note x dstate))))
423     (case (break-im5 chunk dstate)
424       (#.error-trap
425        (nt "Error trap")
426        (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
427       (#.cerror-trap
428        (nt "Cerror trap")
429        (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
430       (#.breakpoint-trap
431        (nt "Breakpoint trap"))
432       (#.pending-interrupt-trap
433        (nt "Pending interrupt trap"))
434       (#.halt-trap
435        (nt "Halt trap"))
436       (#.fun-end-breakpoint-trap
437        (nt "Function end breakpoint trap"))
438     )))
439
440 (sb!disassem:define-instruction-format
441     (system-inst 32)
442   (op1 :field (byte 6 26) :value 0)
443   (r1  :field (byte 5 21) :type 'reg)
444   (r2  :field (byte 5 16) :type 'reg)
445   (s   :field (byte 3 13))
446   (op2 :field (byte 8 5))
447   (r3  :field (byte 5 0) :type 'reg))
448
449 (sb!disassem:define-instruction-format
450     (fp-load/store 32)
451   (op :field (byte 6 26))
452   (b  :field (byte 5 21) :type 'reg)
453   (x  :field (byte 5 16) :type 'reg)
454   (s  :field (byte 2 14) :type 'space)
455   (u  :field (byte 1 13))
456   (x1 :field (byte 1 12))
457   (x2 :field (byte 2 10))
458   (x3 :field (byte 1 9))
459   (x4 :field (byte 3 6))
460   (m  :field (byte 1 5))
461   (t  :field (byte 5 0) :type 'fp-reg))
462
463 (sb!disassem:define-instruction-format
464     (fp-class-0-inst 32)
465   (op1 :field (byte 6 26))
466   (r   :field (byte 5 21) :type 'fp-reg)
467   (x1  :field (byte 5 16) :type 'fp-reg)
468   (op2 :field (byte 3 13))
469   (fmt :field (byte 2 11) :type 'fp-fmt-0c)
470   (x2  :field (byte 2 9))
471   (x3  :field (byte 3 6))
472   (x4  :field (byte 1 5))
473   (t   :field (byte 5 0) :type 'fp-reg))
474
475 (sb!disassem:define-instruction-format
476     (fp-class-1-inst 32)
477   (op1 :field (byte 6 26))
478   (r   :field (byte 5 21) :type 'fp-reg)
479   (x1  :field (byte 4 17) :value 0)
480   (x2  :field (byte 2 15))
481   (df  :field (byte 2 13) :type 'fp-fmt-0c)
482   (sf  :field (byte 2 11) :type 'fp-fmt-0c)
483   (x3  :field (byte 2 9) :value 1)
484   (x4  :field (byte 3 6) :value 0)
485   (x5  :field (byte 1 5) :value 0)
486   (t   :field (byte 5 0) :type 'fp-reg))
487
488
489 \f
490 ;;;; Load and Store stuff.
491
492 (define-bitfield-emitter emit-load/store 32
493   (byte 6 26)
494   (byte 5 21)
495   (byte 5 16)
496   (byte 2 14)
497   (byte 14 0))
498
499
500 (defun im14-encoding (segment disp)
501   (declare (type (or fixup (signed-byte 14))))
502   (cond ((fixup-p disp)
503          (note-fixup segment :load disp)
504          (aver (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
505          0)
506         (t
507          (dpb (ldb (byte 13 0) disp)
508               (byte 13 1)
509               (ldb (byte 1 13) disp)))))
510
511 (macrolet ((define-load-inst (name opcode)
512                `(define-instruction ,name (segment disp base reg)
513                  (:declare (type tn reg base)
514                   (type (or fixup (signed-byte 14)) disp))
515                  (:printer load/store ((op ,opcode) (s 0))
516                   '(:name :tab im14 "(" s b ")," t/r))
517                  (:emitter
518                   (emit-load/store segment ,opcode
519                    (reg-tn-encoding base) (reg-tn-encoding reg) 0
520                    (im14-encoding segment disp)))))
521            (define-store-inst (name opcode)
522                `(define-instruction ,name (segment reg disp base)
523                  (:declare (type tn reg base)
524                   (type (or fixup (signed-byte 14)) disp))
525                  (:printer load/store ((op ,opcode) (s 0))
526                   '(:name :tab t/r "," im14 "(" s b ")"))
527                  (:emitter
528                   (emit-load/store segment ,opcode
529                    (reg-tn-encoding base) (reg-tn-encoding reg) 0
530                    (im14-encoding segment disp))))))
531   (define-load-inst ldw #x12)
532   (define-load-inst ldh #x11)
533   (define-load-inst ldb #x10)
534   (define-load-inst ldwm #x13)
535   (define-load-inst ldo #x0D)
536
537   (define-store-inst stw #x1A)
538   (define-store-inst sth #x19)
539   (define-store-inst stb #x18)
540   (define-store-inst stwm #x1B))
541
542 (define-bitfield-emitter emit-extended-load/store 32
543   (byte 6 26) (byte 5 21) (byte 5 16) (byte 2 14) (byte 1 13)
544   (byte 3 10) (byte 4 6) (byte 1 5) (byte 5 0))
545
546 (macrolet ((define-load-indexed-inst (name opcode)
547               `(define-instruction ,name (segment index base reg &key modify scale)
548                 (:declare (type tn reg base index)
549                  (type (member t nil) modify scale))
550                 (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'reg)
551                                                (op2 0))
552                  `(:name ,@cmplt-index-print :tab x/im5/r
553                                               "(" s b ")" t/im5))
554                 (:emitter
555                  (emit-extended-load/store
556                   segment #x03 (reg-tn-encoding base) (reg-tn-encoding index)
557                   0 (if scale 1 0) 0 ,opcode (if modify 1 0)
558                   (reg-tn-encoding reg))))))
559   (define-load-indexed-inst ldwx 2)
560   (define-load-indexed-inst ldhx 1)
561   (define-load-indexed-inst ldbx 0)
562   (define-load-indexed-inst ldcwx 7))
563
564 (defun short-disp-encoding (segment disp)
565   (declare (type (or fixup (signed-byte 5)) disp))
566   (cond ((fixup-p disp)
567          (note-fixup segment :load-short disp)
568          (aver (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
569          0)
570         (t
571          (dpb (ldb (byte 4 0) disp)
572               (byte 4 1)
573               (ldb (byte 1 4) disp)))))
574
575 (macrolet ((define-load-short-inst (name opcode)
576                `(define-instruction ,name (segment base disp reg &key modify)
577                  (:declare (type tn base reg)
578                   (type (or fixup (signed-byte 5)) disp)
579                   (type (member :before :after nil) modify))
580                  (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'im5)
581                                                 (op2 4))
582                   `(:name ,@cmplt-disp-print :tab x/im5/r
583                     "(" s b ")" t/im5))
584                  (:emitter
585                   (multiple-value-bind
586                         (m a)
587                       (ecase modify
588                         ((nil) (values 0 0))
589                         (:after (values 1 0))
590                         (:before (values 1 1)))
591                     (emit-extended-load/store segment #x03 (reg-tn-encoding base)
592                                               (short-disp-encoding segment disp)
593                                               0 a 4 ,opcode m
594                                               (reg-tn-encoding reg))))))
595            (define-store-short-inst (name opcode)
596                `(define-instruction ,name (segment reg base disp &key modify)
597                  (:declare (type tn reg base)
598                   (type (or fixup (signed-byte 5)) disp)
599                   (type (member :before :after nil) modify))
600                  (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'im5)
601                                                 (op2 4))
602                   `(:name ,@cmplt-disp-print :tab x/im5/r
603                     "," t/im5 "(" s b ")"))
604                  (:emitter
605                   (multiple-value-bind
606                         (m a)
607                       (ecase modify
608                         ((nil) (values 0 0))
609                         (:after (values 1 0))
610                         (:before (values 1 1)))
611                     (emit-extended-load/store segment #x03 (reg-tn-encoding base)
612                                               (short-disp-encoding segment disp)
613                                               0 a 4 ,opcode m
614                                               (reg-tn-encoding reg)))))))
615   (define-load-short-inst ldws 2)
616   (define-load-short-inst ldhs 1)
617   (define-load-short-inst ldbs 0)
618   (define-load-short-inst ldcws 7)
619
620   (define-store-short-inst stws 10)
621   (define-store-short-inst sths 9)
622   (define-store-short-inst stbs 8))
623
624 (define-instruction stbys (segment reg base disp where &key modify)
625   (:declare (type tn reg base)
626             (type (signed-byte 5) disp)
627             (type (member :begin :end) where)
628             (type (member t nil) modify))
629   (:printer extended-load/store ((ext4/c #xC) (t/im5 nil :type 'im5) (op2 4))
630             `(:name ,@cmplt-store-print :tab x/im5/r "," t/im5 "(" s b ")"))
631   (:emitter
632    (emit-extended-load/store segment #x03 (reg-tn-encoding base)
633                              (reg-tn-encoding reg) 0
634                              (ecase where (:begin 0) (:end 1))
635                              4 #xC (if modify 1 0)
636                              (short-disp-encoding segment disp))))
637
638 \f
639 ;;;; Immediate Instructions.
640
641 (define-bitfield-emitter emit-ldil 32
642   (byte 6 26)
643   (byte 5 21)
644   (byte 21 0))
645
646 (defun immed-21-encoding (segment value)
647   (declare (type (or fixup (signed-byte 21) (unsigned-byte 21)) value))
648   (cond ((fixup-p value)
649          (note-fixup segment :hi value)
650          (aver (or (null (fixup-offset value)) (zerop (fixup-offset value))))
651          0)
652         (t
653          (logior (ash (ldb (byte 5 2) value) 16)
654                  (ash (ldb (byte 2 7) value) 14)
655                  (ash (ldb (byte 2 0) value) 12)
656                  (ash (ldb (byte 11 9) value) 1)
657                  (ldb (byte 1 20) value)))))
658
659 (define-instruction ldil (segment value reg)
660   (:declare (type tn reg)
661             (type (or (signed-byte 21) (unsigned-byte 21) fixup) value))
662   (:printer ldil ((op #x08)))
663   (:emitter
664    (emit-ldil segment #x08 (reg-tn-encoding reg)
665               (immed-21-encoding segment value))))
666
667 (define-instruction addil (segment value reg)
668   (:declare (type tn reg)
669             (type (or (signed-byte 21) (unsigned-byte 21) fixup) value))
670   (:printer ldil ((op #x0A)))
671   (:emitter
672    (emit-ldil segment #x0A (reg-tn-encoding reg)
673               (immed-21-encoding segment value))))
674
675 \f
676 ;;;; Branch instructions.
677
678 (define-bitfield-emitter emit-branch 32
679   (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
680   (byte 11 2) (byte 1 1) (byte 1 0))
681
682 (defun label-relative-displacement (label posn &optional delta-if-after)
683    (declare (type label label) (type index posn))
684   (ash (- (if delta-if-after
685               (label-position label posn delta-if-after)
686               (label-position label))
687           (+ posn 8)) -2))
688
689 (defun decompose-branch-disp (segment disp)
690   (declare (type (or fixup (signed-byte 17)) disp))
691   (cond ((fixup-p disp)
692          (note-fixup segment :branch disp)
693          (aver (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
694          (values 0 0 0))
695         (t
696          (values (ldb (byte 5 11) disp)
697                  (dpb (ldb (byte 10 0) disp)
698                       (byte 10 1)
699                       (ldb (byte 1 10) disp))
700                  (ldb (byte 1 16) disp)))))
701
702 (defun emit-relative-branch (segment opcode link sub-opcode target nullify)
703   (declare (type (unsigned-byte 6) opcode)
704            (type (unsigned-byte 5) link)
705            (type (unsigned-byte 1) sub-opcode)
706            (type label target)
707            (type (member t nil) nullify))
708   (emit-back-patch segment 4
709     #'(lambda (segment posn)
710         (let ((disp (label-relative-displacement target posn)))
711           (aver (<= (- (ash 1 16)) disp (1- (ash 1 16))))
712           (multiple-value-bind
713               (w1 w2 w)
714               (decompose-branch-disp segment disp)
715             (emit-branch segment opcode link w1 sub-opcode w2
716                          (if nullify 1 0) w))))))
717
718 (define-instruction b (segment target &key nullify)
719   (:declare (type label target) (type (member t nil) nullify))
720   (:emitter
721    (emit-relative-branch segment #x3A 0 0 target nullify)))
722
723 (define-instruction bl (segment target reg &key nullify)
724   (:declare (type tn reg) (type label target) (type (member t nil) nullify))
725   (:printer branch17 ((op1 #x3A) (op2 0)) '(:name n :tab w "," t))
726   (:emitter
727    (emit-relative-branch segment #x3A (reg-tn-encoding reg) 0 target nullify)))
728
729 (define-instruction gateway (segment target reg &key nullify)
730   (:declare (type tn reg) (type label target) (type (member t nil) nullify))
731   (:printer branch17 ((op1 #x3A) (op2 1)) '(:name n :tab w "," t))
732   (:emitter
733    (emit-relative-branch segment #x3A (reg-tn-encoding reg) 1 target nullify)))
734
735 ;;; BLR is useless because we have no way to generate the offset.
736
737 (define-instruction bv (segment base &key nullify offset)
738   (:declare (type tn base)
739             (type (member t nil) nullify)
740             (type (or tn null) offset))
741   (:printer branch ((op1 #x3A) (op2 6)) '(:name n :tab x "(" t ")"))
742   (:emitter
743    (emit-branch segment #x3A (reg-tn-encoding base)
744                 (if offset (reg-tn-encoding offset) 0)
745                 6 0 (if nullify 1 0) 0)))
746
747 (define-instruction be (segment disp space base &key nullify)
748   (:declare (type (or fixup (signed-byte 17)) disp)
749             (type tn base)
750             (type (unsigned-byte 3) space)
751             (type (member t nil) nullify))
752   (:printer branch17 ((op1 #x38) (op2 nil :type 'im3))
753             '(:name n :tab w "(" op2 "," t ")"))
754   (:emitter
755    (multiple-value-bind
756        (w1 w2 w)
757        (decompose-branch-disp segment disp)
758      (emit-branch segment #x38 (reg-tn-encoding base) w1
759                   (space-encoding space) w2 (if nullify 1 0) w))))
760
761 (define-instruction ble (segment disp space base &key nullify)
762   (:declare (type (or fixup (signed-byte 17)) disp)
763             (type tn base)
764             (type (unsigned-byte 3) space)
765             (type (member t nil) nullify))
766   (:printer branch17 ((op1 #x39) (op2 nil :type 'im3))
767             '(:name n :tab w "(" op2 "," t ")"))
768   (:emitter
769    (multiple-value-bind
770        (w1 w2 w)
771        (decompose-branch-disp segment disp)
772      (emit-branch segment #x39 (reg-tn-encoding base) w1
773                   (space-encoding space) w2 (if nullify 1 0) w))))
774
775 (defun emit-conditional-branch (segment opcode r2 r1 cond target nullify)
776   (emit-back-patch segment 4
777     #'(lambda (segment posn)
778         (let ((disp (label-relative-displacement target posn)))
779           (aver (<= (- (ash 1 11)) disp (1- (ash 1 11))))
780           (let ((w1 (logior (ash (ldb (byte 10 0) disp) 1)
781                             (ldb (byte 1 10) disp)))
782                 (w (ldb (byte 1 11) disp)))
783             (emit-branch segment opcode r2 r1 cond w1 (if nullify 1 0) w))))))
784
785 (defun im5-encoding (value)
786   (declare (type (signed-byte 5) value)
787            #+nil (values (unsigned-byte 5)))
788   (dpb (ldb (byte 4 0) value)
789        (byte 4 1)
790        (ldb (byte 1 4) value)))
791
792 (macrolet ((define-branch-inst (r-name r-opcode i-name i-opcode cond-kind)
793                (let* ((conditional (symbolicate cond-kind "-CONDITION"))
794                       (false-conditional (symbolicate conditional "-FALSE")))
795                  `(progn
796                    (define-instruction ,r-name (segment cond r1 r2 target &key nullify)
797                      (:declare (type ,conditional cond)
798                       (type tn r1 r2)
799                       (type label target)
800                       (type (member t nil) nullify))
801                      (:printer branch12 ((op1 ,r-opcode) (c nil :type ',conditional))
802                       '(:name c n :tab r1 "," r2 "," w))
803                      ,@(unless (= r-opcode #x32)
804                                `((:printer branch12 ((op1 ,(+ 2 r-opcode))
805                                                      (c nil :type ',false-conditional))
806                                   '(:name c n :tab r1 "," r2 "," w))))
807                      (:emitter
808                       (multiple-value-bind
809                             (cond-encoding false)
810                           (,conditional cond)
811                         (emit-conditional-branch
812                          segment (if false ,(+ r-opcode 2) ,r-opcode)
813                          (reg-tn-encoding r2) (reg-tn-encoding r1)
814                          cond-encoding target nullify))))
815                    (define-instruction ,i-name (segment cond imm reg target &key nullify)
816                      (:declare (type ,conditional cond)
817                       (type (signed-byte 5) imm)
818                       (type tn reg)
819                       (type (member t nil) nullify))
820                      (:printer branch12 ((op1 ,i-opcode) (r1 nil :type 'im5)
821                                          (c nil :type ',conditional))
822                       '(:name c n :tab r1 "," r2 "," w))
823                      ,@(unless (= r-opcode #x32)
824                                `((:printer branch12 ((op1 ,(+ 2 i-opcode)) (r1 nil :type 'im5)
825                                                      (c nil :type ',false-conditional))
826                                   '(:name c n :tab r1 "," r2 "," w))))
827                      (:emitter
828                       (multiple-value-bind
829                             (cond-encoding false)
830                           (,conditional cond)
831                         (emit-conditional-branch
832                          segment (if false (+ ,i-opcode 2) ,i-opcode)
833                          (reg-tn-encoding reg) (im5-encoding imm)
834                          cond-encoding target nullify))))))))
835   (define-branch-inst movb #x32 movib #x33 extract/deposit)
836   (define-branch-inst comb #x20 comib #x21 compare)
837   (define-branch-inst addb #x28 addib #x29 add))
838
839 (define-instruction bb (segment cond reg posn target &key nullify)
840   (:declare (type (member t nil) cond nullify)
841             (type tn reg)
842             (type (or (member :variable) (unsigned-byte 5)) posn))
843   (:printer branch12 ((op1 30) (c nil :type 'extract/deposit-condition))
844                       '('BVB c n :tab r1 "," w))
845   (:emitter
846    (multiple-value-bind
847        (opcode posn-encoding)
848        (if (eq posn :variable)
849            (values #x30 0)
850            (values #x31 posn))
851      (emit-conditional-branch segment opcode posn-encoding
852                               (reg-tn-encoding reg)
853                               (if cond 2 6) target nullify))))
854
855 \f
856 ;;;; Computation Instructions
857
858 (define-bitfield-emitter emit-r3-inst 32
859   (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
860   (byte 1 12) (byte 7 5) (byte 5 0))
861
862 (macrolet ((define-r3-inst (name cond-kind opcode)
863                `(define-instruction ,name (segment r1 r2 res &optional cond)
864                  (:declare (type tn res r1 r2))
865                  (:printer r3-inst ((op ,opcode) (c nil :type ',(symbolicate
866                                                                  cond-kind
867                                                                  "-CONDITION"))))
868                  ,@(when (= opcode #x12)
869                          `((:printer r3-inst ((op ,opcode) (r2 0)
870                                               (c nil :type ',(symbolicate cond-kind
871                                                                           "-CONDITION")))
872                             `('COPY :tab r1 "," t))))
873                  (:emitter
874                   (multiple-value-bind
875                         (cond false)
876                       (,(symbolicate cond-kind "-CONDITION") cond)
877                     (emit-r3-inst segment #x02 (reg-tn-encoding r2) (reg-tn-encoding r1)
878                                   cond (if false 1 0) ,opcode
879                                   (reg-tn-encoding res)))))))
880   (define-r3-inst add add #x30)
881   (define-r3-inst addl add #x50)
882   (define-r3-inst addo add #x70)
883   (define-r3-inst addc add #x38)
884   (define-r3-inst addco add #x78)
885   (define-r3-inst sh1add add #x32)
886   (define-r3-inst sh1addl add #x52)
887   (define-r3-inst sh1addo add #x72)
888   (define-r3-inst sh2add add #x34)
889   (define-r3-inst sh2addl add #x54)
890   (define-r3-inst sh2addo add #x74)
891   (define-r3-inst sh3add add #x36)
892   (define-r3-inst sh3addl add #x56)
893   (define-r3-inst sh3addo add #x76)
894   (define-r3-inst sub compare #x20)
895   (define-r3-inst subo compare #x60)
896   (define-r3-inst subb compare #x28)
897   (define-r3-inst subbo compare #x68)
898   (define-r3-inst subt compare #x26)
899   (define-r3-inst subto compare #x66)
900   (define-r3-inst ds compare #x22)
901   (define-r3-inst comclr compare #x44)
902   (define-r3-inst or logical #x12)
903   (define-r3-inst xor logical #x14)
904   (define-r3-inst and logical #x10)
905   (define-r3-inst andcm logical #x00)
906   (define-r3-inst uxor unit #x1C)
907   (define-r3-inst uaddcm unit #x4C)
908   (define-r3-inst uaddcmt unit #x4E)
909   (define-r3-inst dcor unit #x5C)
910   (define-r3-inst idcor unit #x5E))
911
912 (define-bitfield-emitter emit-imm-inst 32
913   (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
914   (byte 1 12) (byte 1 11) (byte 11 0))
915
916 (defun im11-encoding (value)
917   (declare (type (signed-byte 11) value)
918            #+nil (values (unsigned-byte 11)))
919   (dpb (ldb (byte 10 0) value)
920        (byte 10 1)
921        (ldb (byte 1 10) value)))
922
923 (macrolet ((define-imm-inst (name cond-kind opcode subcode)
924                `(define-instruction ,name (segment imm src dst &optional cond)
925                  (:declare (type tn dst src)
926                   (type (signed-byte 11) imm))
927                  (:printer imm-inst ((op ,opcode) (o ,subcode)
928                                      (c nil :type
929                                         ',(symbolicate cond-kind "-CONDITION"))))
930                  (:emitter
931                   (multiple-value-bind
932                         (cond false)
933                       (,(symbolicate cond-kind "-CONDITION") cond)
934                     (emit-imm-inst segment ,opcode (reg-tn-encoding src)
935                                    (reg-tn-encoding dst) cond
936                                    (if false 1 0) ,subcode
937                                    (im11-encoding imm)))))))
938   (define-imm-inst addi add #x2D 0)
939   (define-imm-inst addio add #x2D 1)
940   (define-imm-inst addit add #x2C 0)
941   (define-imm-inst addito add #x2C 1)
942   (define-imm-inst subi compare #x25 0)
943   (define-imm-inst subio compare #x25 1)
944   (define-imm-inst comiclr compare #x24 0))
945
946 (define-bitfield-emitter emit-extract/deposit-inst 32
947   (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
948   (byte 3 10) (byte 5 5) (byte 5 0))
949
950 (define-instruction shd (segment r1 r2 count res &optional cond)
951   (:declare (type tn res r1 r2)
952             (type (or (member :variable) (integer 0 31)) count))
953   (:printer extract/deposit-inst ((op1 #x34) (op2 2) (t/clen nil :type 'reg))
954             '(:name c :tab r1 "," r2 "," cp "," t/clen))
955   (:printer extract/deposit-inst ((op1 #x34) (op2 0) (t/clen nil :type 'reg))
956             '('VSHD c :tab r1 "," r2 "," t/clen))
957   (:emitter
958    (etypecase count
959      ((member :variable)
960       (emit-extract/deposit-inst segment #x34
961                                  (reg-tn-encoding r2) (reg-tn-encoding r1)
962                                  (extract/deposit-condition cond)
963                                  0 0 (reg-tn-encoding res)))
964      ((integer 0 31)
965       (emit-extract/deposit-inst segment #x34
966                                  (reg-tn-encoding r2) (reg-tn-encoding r1)
967                                  (extract/deposit-condition cond)
968                                  2 (- 31 count)
969                                  (reg-tn-encoding res))))))
970
971 (macrolet ((define-extract-inst (name opcode)
972                `(define-instruction ,name (segment src posn len res &optional cond)
973                  (:declare (type tn res src)
974                   (type (or (member :variable) (integer 0 31)) posn)
975                   (type (integer 1 32) len))
976                  (:printer extract/deposit-inst ((op1 #x34) (cp nil :type 'integer)
977                                                  (op2 ,opcode))
978                   '(:name c :tab r2 "," cp "," t/clen "," r1))
979                  (:printer extract/deposit-inst ((op1 #x34) (op2 ,(- opcode 2)))
980                   '('V :name c :tab r2 "," t/clen "," r1))
981                  (:emitter
982                   (etypecase posn
983                     ((member :variable)
984                      (emit-extract/deposit-inst segment #x34 (reg-tn-encoding src)
985                                                 (reg-tn-encoding res)
986                                                 (extract/deposit-condition cond)
987                                                 ,(- opcode 2) 0 (- 32 len)))
988                     ((integer 0 31)
989                      (emit-extract/deposit-inst segment #x34 (reg-tn-encoding src)
990                                                 (reg-tn-encoding res)
991                                                 (extract/deposit-condition cond)
992                                                 ,opcode posn (- 32 len))))))))
993   (define-extract-inst extru 6)
994   (define-extract-inst extrs 7))
995
996 (macrolet ((define-deposit-inst (name opcode)
997                `(define-instruction ,name (segment src posn len res &optional cond)
998                  (:declare (type tn res)
999                   (type (or tn (signed-byte 5)) src)
1000                   (type (or (member :variable) (integer 0 31)) posn)
1001                   (type (integer 1 32) len))
1002                  (:printer extract/deposit-inst ((op1 #x35) (op2 ,opcode))
1003                   ',(let ((base '('VDEP c :tab r1 "," t/clen "," r2)))
1004                          (if (= opcode 0) (cons ''Z base) base)))
1005                  (:printer extract/deposit-inst ((op1 #x35) (op2 ,(+ 2 opcode)))
1006                   ',(let ((base '('DEP c :tab r1 "," cp "," t/clen "," r2)))
1007                          (if (= opcode 0) (cons ''Z base) base)))
1008                  (:printer extract/deposit-inst ((op1 #x35) (r1 nil :type 'im5)
1009                                                  (op2 ,(+ 4 opcode)))
1010                   ',(let ((base '('VDEPI c :tab r1 "," t/clen "," r2)))
1011                          (if (= opcode 0) (cons ''Z base) base)))
1012                  (:printer extract/deposit-inst ((op1 #x35) (r1 nil :type 'im5)
1013                                                  (op2 ,(+ 6 opcode)))
1014                   ',(let ((base '('DEPI c :tab r1 "," cp "," t/clen "," r2)))
1015                          (if (= opcode 0) (cons ''Z base) base)))
1016                  (:emitter
1017                   (multiple-value-bind
1018                         (opcode src-encoding)
1019                       (etypecase src
1020                         (tn
1021                          (values ,opcode (reg-tn-encoding src)))
1022                         ((signed-byte 5)
1023                          (values ,(+ opcode 4) (im5-encoding src))))
1024                     (multiple-value-bind
1025                           (opcode posn-encoding)
1026                         (etypecase posn
1027                           ((member :variable)
1028                            (values opcode 0))
1029                           ((integer 0 31)
1030                            (values (+ opcode 2) (- 31 posn))))
1031                       (emit-extract/deposit-inst segment #x35 (reg-tn-encoding res)
1032                                                  src-encoding
1033                                                  (extract/deposit-condition cond)
1034                                                  opcode posn-encoding (- 32 len))))))))
1035
1036   (define-deposit-inst dep 1)
1037   (define-deposit-inst zdep 0))
1038
1039
1040 \f
1041 ;;;; System Control Instructions.
1042
1043 (define-bitfield-emitter emit-break 32
1044   (byte 6 26) (byte 13 13) (byte 8 5) (byte 5 0))
1045
1046 (define-instruction break (segment &optional (im5 0) (im13 0))
1047   (:declare (type (unsigned-byte 13) im13)
1048             (type (unsigned-byte 5) im5))
1049   (:printer break () :default :control #'break-control)
1050   (:emitter
1051    (emit-break segment 0 im13 0 im5)))
1052
1053 (define-bitfield-emitter emit-system-inst 32
1054   (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) (byte 8 5) (byte 5 0))
1055
1056 (define-instruction ldsid (segment res base &optional (space 0))
1057   (:declare (type tn res base)
1058             (type (integer 0 3) space))
1059   (:printer system-inst ((op2 #x85) (c nil :type 'space)
1060                          (s nil  :printer #(0 0 1 1 2 2 3 3)))
1061             `(:name :tab "(" s r1 ")," r3))
1062   (:emitter
1063    (emit-system-inst segment 0 (reg-tn-encoding base) 0 (ash space 1) #x85
1064                      (reg-tn-encoding res))))
1065
1066 (define-instruction mtsp (segment reg space)
1067   (:declare (type tn reg) (type (integer 0 7) space))
1068   (:printer system-inst ((op2 #xC1)) '(:name :tab r2 "," s))
1069   (:emitter
1070    (emit-system-inst segment 0 0 (reg-tn-encoding reg) (space-encoding space)
1071                      #xC1 0)))
1072
1073 (define-instruction mfsp (segment space reg)
1074   (:declare (type tn reg) (type (integer 0 7) space))
1075   (:printer system-inst ((op2 #x25) (c nil :type 'space)) '(:name :tab s r3))
1076   (:emitter
1077    (emit-system-inst segment 0 0 0 (space-encoding space) #x25
1078                      (reg-tn-encoding reg))))
1079
1080 (deftype control-reg ()
1081   '(or (unsigned-byte 5) (member :sar)))
1082
1083 (defun control-reg (reg)
1084   (declare (type control-reg reg)
1085            #+nil (values (unsigned-byte 32)))
1086   (if (typep reg '(unsigned-byte 5))
1087       reg
1088       (ecase reg
1089         (:sar 11))))
1090
1091 (define-instruction mtctl (segment reg ctrl-reg)
1092   (:declare (type tn reg) (type control-reg ctrl-reg))
1093   (:printer system-inst ((op2 #xC2)) '(:name :tab r2 "," r1))
1094   (:emitter
1095    (emit-system-inst segment 0 (control-reg ctrl-reg) (reg-tn-encoding reg)
1096                      0 #xC2 0)))
1097
1098 (define-instruction mfctl (segment ctrl-reg reg)
1099   (:declare (type tn reg) (type control-reg ctrl-reg))
1100   (:printer system-inst ((op2 #x45)) '(:name :tab r1 "," r3))
1101   (:emitter
1102    (emit-system-inst segment 0 (control-reg ctrl-reg) 0 0 #x45
1103                      (reg-tn-encoding reg))))
1104
1105
1106 \f
1107 ;;;; Floating point instructions.
1108
1109 (define-bitfield-emitter emit-fp-load/store 32
1110   (byte 6 26) (byte 5 21) (byte 5 16) (byte 2 14) (byte 1 13) (byte 1 12)
1111   (byte 2 10) (byte 1 9) (byte 3 6) (byte 1 5) (byte 5 0))
1112
1113 (define-instruction fldx (segment index base result &key modify scale side)
1114   (:declare (type tn index base result)
1115             (type (member t nil) modify scale)
1116             (type (member nil 0 1) side))
1117   (:printer fp-load/store ((op #x0b) (x1 0) (x2 0) (x3 0))
1118             `('FLDDX ,@cmplt-index-print :tab x "(" s b ")" "," t))
1119   (:printer fp-load/store ((op #x09) (x1 0) (x2 0) (x3 0))
1120             `('FLDWX ,@cmplt-index-print :tab x "(" s b ")" "," t))
1121   (:emitter
1122    (multiple-value-bind
1123        (result-encoding double-p)
1124        (fp-reg-tn-encoding result)
1125      (when side
1126        (aver double-p)
1127        (setf double-p nil))
1128      (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
1129                          (reg-tn-encoding index) 0 (if scale 1 0) 0 0 0
1130                          (or side 0) (if modify 1 0) result-encoding))))
1131
1132 (define-instruction fstx (segment value index base &key modify scale side)
1133   (:declare (type tn index base value)
1134             (type (member t nil) modify scale)
1135             (type (member nil 0 1) side))
1136   (:printer fp-load/store ((op #x0b) (x1 0) (x2 0) (x3 1))
1137             `('FSTDX ,@cmplt-index-print :tab t "," x "(" s b ")"))
1138   (:printer fp-load/store ((op #x09) (x1 0) (x2 0) (x3 1))
1139             `('FSTWX ,@cmplt-index-print :tab t "," x "(" s b ")"))
1140   (:emitter
1141    (multiple-value-bind
1142        (value-encoding double-p)
1143        (fp-reg-tn-encoding value)
1144      (when side
1145        (aver double-p)
1146        (setf double-p nil))
1147      (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
1148                          (reg-tn-encoding index) 0 (if scale 1 0) 0 0 1
1149                          (or side 0) (if modify 1 0) value-encoding))))
1150
1151 (define-instruction flds (segment disp base result &key modify side)
1152   (:declare (type tn base result)
1153             (type (signed-byte 5) disp)
1154             (type (member :before :after nil) modify)
1155             (type (member nil 0 1) side))
1156   (:printer fp-load/store ((op #x0b) (x nil :type 'im5) (x1 1) (x2 0) (x3 0))
1157             `('FLDDS ,@cmplt-disp-print :tab x "(" s b ")," t))
1158   (:printer fp-load/store ((op #x09) (x nil :type 'im5) (x1 1) (x2 0) (x3 0))
1159             `('FLDWS ,@cmplt-disp-print :tab x "(" s b ")," t))
1160   (:emitter
1161    (multiple-value-bind
1162        (result-encoding double-p)
1163        (fp-reg-tn-encoding result)
1164      (when side
1165        (aver double-p)
1166        (setf double-p nil))
1167      (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
1168                          (short-disp-encoding segment disp) 0
1169                          (if (eq modify :before) 1 0) 1 0 0
1170                          (or side 0) (if modify 1 0) result-encoding))))
1171
1172 (define-instruction fsts (segment value disp base &key modify side)
1173   (:declare (type tn base value)
1174             (type (signed-byte 5) disp)
1175             (type (member :before :after nil) modify)
1176             (type (member nil 0 1) side))
1177   (:printer fp-load/store ((op #x0b) (x nil :type 'im5) (x1 1) (x2 0) (x3 1))
1178             `('FSTDS ,@cmplt-disp-print :tab t "," x "(" s b ")"))
1179   (:printer fp-load/store ((op #x09) (x nil :type 'im5) (x1 1) (x2 0) (x3 1))
1180             `('FSTWS ,@cmplt-disp-print :tab t "," x "(" s b ")"))
1181   (:emitter
1182    (multiple-value-bind
1183        (value-encoding double-p)
1184        (fp-reg-tn-encoding value)
1185      (when side
1186        (aver double-p)
1187        (setf double-p nil))
1188      (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
1189                          (short-disp-encoding segment disp) 0
1190                          (if (eq modify :before) 1 0) 1 0 1
1191                          (or side 0) (if modify 1 0) value-encoding))))
1192
1193
1194 (define-bitfield-emitter emit-fp-class-0-inst 32
1195   (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) (byte 2 11) (byte 2 9)
1196   (byte 3 6) (byte 1 5) (byte 5 0))
1197
1198 (define-bitfield-emitter emit-fp-class-1-inst 32
1199   (byte 6 26) (byte 5 21) (byte 4 17) (byte 2 15) (byte 2 13) (byte 2 11)
1200   (byte 2 9) (byte 3 6) (byte 1 5) (byte 5 0))
1201
1202 ;;; Note: classes 2 and 3 are similar enough to class 0 that we don't need
1203 ;;; seperate emitters.
1204
1205 (defconstant-eqx funops '(:copy :abs :sqrt :rnd)
1206   #'equalp)
1207
1208 (deftype funop ()
1209   `(member ,@funops))
1210
1211 (define-instruction funop (segment op from to)
1212   (:declare (type funop op)
1213             (type tn from to))
1214   (:printer fp-class-0-inst ((op1 #x0C) (op2 2) (x2 0))
1215             '('FCPY fmt :tab r "," t))
1216   (:printer fp-class-0-inst ((op1 #x0C) (op2 3) (x2 0))
1217             '('FABS fmt  :tab r "," t))
1218   (:printer fp-class-0-inst ((op1 #x0C) (op2 4) (x2 0))
1219             '('FSQRT fmt :tab r "," t))
1220   (:printer fp-class-0-inst ((op1 #x0C) (op2 5) (x2 0))
1221             '('FRND fmt :tab r "," t))
1222   (:emitter
1223    (multiple-value-bind
1224        (from-encoding from-double-p)
1225        (fp-reg-tn-encoding from)
1226      (multiple-value-bind
1227          (to-encoding to-double-p)
1228          (fp-reg-tn-encoding to)
1229        (aver (eq from-double-p to-double-p))
1230        (emit-fp-class-0-inst segment #x0C from-encoding 0
1231                              (+ 2 (or (position op funops)
1232                                       (error "Bogus FUNOP: ~S" op)))
1233                              (if to-double-p 1 0) 0 0 0 to-encoding)))))
1234
1235 (macrolet ((define-class-1-fp-inst (name subcode)
1236                `(define-instruction ,name (segment from to)
1237                  (:declare (type tn from to))
1238                  (:printer fp-class-1-inst ((op1 #x0C) (x2 ,subcode))
1239                   '(:name sf df :tab r "," t))
1240                  (:emitter
1241                   (multiple-value-bind
1242                         (from-encoding from-double-p)
1243                       (fp-reg-tn-encoding from)
1244                     (multiple-value-bind
1245                           (to-encoding to-double-p)
1246                         (fp-reg-tn-encoding to)
1247                       (emit-fp-class-1-inst segment #x0C from-encoding 0 ,subcode
1248                                             (if to-double-p 1 0) (if from-double-p 1 0)
1249                                             1 0 0 to-encoding)))))))
1250
1251   (define-class-1-fp-inst fcnvff 0)
1252   (define-class-1-fp-inst fcnvxf 1)
1253   (define-class-1-fp-inst fcnvfx 2)
1254   (define-class-1-fp-inst fcnvfxt 3))
1255
1256 (define-instruction fcmp (segment cond r1 r2)
1257   (:declare (type (unsigned-byte 5) cond)
1258             (type tn r1 r2))
1259   (:printer fp-class-0-inst ((op1 #x0C) (op2 0) (x2 2) (t nil :type 'fcmp-cond))
1260             '(:name fmt t :tab r "," x1))
1261   (:emitter
1262    (multiple-value-bind
1263        (r1-encoding r1-double-p)
1264        (fp-reg-tn-encoding r1)
1265      (multiple-value-bind
1266          (r2-encoding r2-double-p)
1267          (fp-reg-tn-encoding r2)
1268        (aver (eq r1-double-p r2-double-p))
1269        (emit-fp-class-0-inst segment #x0C r1-encoding r2-encoding 0
1270                              (if r1-double-p 1 0) 2 0 0 cond)))))
1271
1272 (define-instruction ftest (segment)
1273   (:printer fp-class-0-inst ((op1 #x0c) (op2 1) (x2 2)) '(:name))
1274   (:emitter
1275    (emit-fp-class-0-inst segment #x0C 0 0 1 0 2 0 1 0)))
1276
1277 (defconstant-eqx fbinops '(:add :sub :mpy :div)
1278   #'equalp)
1279
1280 (deftype fbinop ()
1281   `(member ,@fbinops))
1282
1283 (define-instruction fbinop (segment op r1 r2 result)
1284   (:declare (type fbinop op)
1285             (type tn r1 r2 result))
1286   (:printer fp-class-0-inst ((op1 #x0C) (op2 0) (x2 3))
1287             '('FADD fmt :tab r "," x1 "," t))
1288   (:printer fp-class-0-inst ((op1 #x0C) (op2 1) (x2 3))
1289             '('FSUB fmt :tab r "," x1 "," t))
1290   (:printer fp-class-0-inst ((op1 #x0C) (op2 2) (x2 3))
1291             '('FMPY fmt :tab r "," x1 "," t))
1292   (:printer fp-class-0-inst ((op1 #x0C) (op2 3) (x2 3))
1293             '('FDIV fmt :tab r "," x1 "," t))
1294   (:emitter
1295    (multiple-value-bind
1296        (r1-encoding r1-double-p)
1297        (fp-reg-tn-encoding r1)
1298      (multiple-value-bind
1299          (r2-encoding r2-double-p)
1300          (fp-reg-tn-encoding r2)
1301        (aver (eq r1-double-p r2-double-p))
1302        (multiple-value-bind
1303            (result-encoding result-double-p)
1304            (fp-reg-tn-encoding result)
1305          (aver (eq r1-double-p result-double-p))
1306          (emit-fp-class-0-inst segment #x0C r1-encoding r2-encoding
1307                                (or (position op fbinops)
1308                                    (error "Bogus FBINOP: ~S" op))
1309                                (if r1-double-p 1 0) 3 0 0
1310                                result-encoding))))))
1311
1312
1313 \f
1314 ;;;; Instructions built out of other insts.
1315
1316 (define-instruction-macro move (src dst &optional cond)
1317   `(inst or ,src zero-tn ,dst ,cond))
1318
1319 (define-instruction-macro nop (&optional cond)
1320   `(inst or zero-tn zero-tn zero-tn ,cond))
1321
1322 (define-instruction li (segment value reg)
1323   (:declare (type tn reg)
1324             (type (or fixup (signed-byte 32) (unsigned-byte 32)) value))
1325   (:vop-var vop)
1326   (:emitter
1327    (assemble (segment vop)
1328      (etypecase value
1329        (fixup
1330         (inst ldil value reg)
1331         (inst ldo value reg reg))
1332        ((signed-byte 14)
1333         (inst ldo value zero-tn reg))
1334        ((or (signed-byte 32) (unsigned-byte 32))
1335         (let ((hi (ldb (byte 21 11) value))
1336               (lo (ldb (byte 11 0) value)))
1337           (inst ldil hi reg)
1338           (unless (zerop lo)
1339             (inst ldo lo reg reg))))))))
1340
1341 (define-instruction-macro sll (src count result &optional cond)
1342   (once-only ((result result) (src src) (count count) (cond cond))
1343     `(inst zdep ,src (- 31 ,count) (- 32 ,count) ,result ,cond)))
1344
1345 (define-instruction-macro sra (src count result &optional cond)
1346   (once-only ((result result) (src src) (count count) (cond cond))
1347     `(inst extrs ,src (- 31 ,count) (- 32 ,count) ,result ,cond)))
1348
1349 (define-instruction-macro srl (src count result &optional cond)
1350   (once-only ((result result) (src src) (count count) (cond cond))
1351     `(inst extru ,src (- 31 ,count) (- 32 ,count) ,result ,cond)))
1352
1353 (defun maybe-negate-cond (cond negate)
1354   (if negate
1355       (multiple-value-bind
1356           (value negate)
1357           (compare-condition cond)
1358         (if negate
1359             (nth value compare-conditions)
1360             (nth (+ value 8) compare-conditions)))
1361       cond))
1362
1363 (define-instruction bc (segment cond not-p r1 r2 target)
1364   (:declare (type compare-condition cond)
1365             (type (member t nil) not-p)
1366             (type tn r1 r2)
1367             (type label target))
1368   (:vop-var vop)
1369   (:emitter
1370    (emit-chooser segment 8 2
1371      #'(lambda (segment posn delta)
1372          (let ((disp (label-relative-displacement target posn delta)))
1373            (when (<= 0 disp (1- (ash 1 11)))
1374              (assemble (segment vop)
1375                (inst comb (maybe-negate-cond cond not-p) r1 r2 target
1376                      :nullify t))
1377              t)))
1378      #'(lambda (segment posn)
1379          (let ((disp (label-relative-displacement target posn)))
1380            (assemble (segment vop)
1381              (cond ((<= (- (ash 1 11)) disp (1- (ash 1 11)))
1382                     (inst comb (maybe-negate-cond cond not-p) r1 r2 target)
1383                     (inst nop))
1384                    (t
1385                     (inst comclr r1 r2 zero-tn
1386                           (maybe-negate-cond cond (not not-p)))
1387                     (inst b target :nullify t)))))))))
1388
1389 (define-instruction bci (segment cond not-p imm reg target)
1390   (:declare (type compare-condition cond)
1391             (type (member t nil) not-p)
1392             (type (signed-byte 11) imm)
1393             (type tn reg)
1394             (type label target))
1395   (:vop-var vop)
1396   (:emitter
1397    (emit-chooser segment 8 2
1398      #'(lambda (segment posn delta-if-after)
1399          (let ((disp (label-relative-displacement target posn delta-if-after)))
1400            (when (and (<= 0 disp (1- (ash 1 11)))
1401                       (<= (- (ash 1 4)) imm (1- (ash 1 4))))
1402              (assemble (segment vop)
1403                (inst comib (maybe-negate-cond cond not-p) imm reg target
1404                      :nullify t))
1405              t)))
1406      #'(lambda (segment posn)
1407          (let ((disp (label-relative-displacement target posn)))
1408            (assemble (segment vop)
1409              (cond ((and (<= (- (ash 1 11)) disp (1- (ash 1 11)))
1410                          (<= (- (ash 1 4)) imm (1- (ash 1 4))))
1411                     (inst comib (maybe-negate-cond cond not-p) imm reg target)
1412                     (inst nop))
1413                    (t
1414                     (inst comiclr imm reg zero-tn
1415                           (maybe-negate-cond cond (not not-p)))
1416                     (inst b target :nullify t)))))))))
1417
1418 \f
1419 ;;;; Instructions to convert between code ptrs, functions, and lras.
1420
1421 (defun emit-compute-inst (segment vop src label temp dst calc)
1422   (emit-chooser
1423       ;; We emit either 12 or 4 bytes, so we maintain 3 byte alignments.
1424       segment 12 3
1425     #'(lambda (segment posn delta-if-after)
1426         (let ((delta (funcall calc label posn delta-if-after)))
1427           (when (<= (- (ash 1 10)) delta (1- (ash 1 10)))
1428             (emit-back-patch segment 4
1429                              #'(lambda (segment posn)
1430                                  (assemble (segment vop)
1431                                    (inst addi (funcall calc label posn 0) src
1432                                          dst))))
1433             t)))
1434     #'(lambda (segment posn)
1435         (let ((delta (funcall calc label posn 0)))
1436           ;; Note: if we used addil/ldo to do this in 2 instructions then the
1437           ;; intermediate value would be tagged but pointing into space.
1438           (assemble (segment vop)
1439             (inst ldil (ldb (byte 21 11) delta) temp)
1440             (inst ldo (ldb (byte 11 0) delta) temp temp)
1441             (inst add src temp dst))))))
1442
1443 ;; code = lip - header - label-offset + other-pointer-tag
1444 (define-instruction compute-code-from-lip (segment src label temp dst)
1445   (:declare (type tn src dst temp)
1446             (type label label))
1447   (:vop-var vop)
1448   (:emitter
1449    (emit-compute-inst segment vop src label temp dst
1450                       #'(lambda (label posn delta-if-after)
1451                           (- other-pointer-lowtag
1452                              (label-position label posn delta-if-after)
1453                              (component-header-length))))))
1454
1455 ;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
1456 ;;      = lra - (header + label-offset)
1457 (define-instruction compute-code-from-lra (segment src label temp dst)
1458   (:declare (type tn src dst temp)
1459             (type label label))
1460   (:vop-var vop)
1461   (:emitter
1462    (emit-compute-inst segment vop src label temp dst
1463                       #'(lambda (label posn delta-if-after)
1464                           (- (+ (label-position label posn delta-if-after)
1465                                 (component-header-length)))))))
1466
1467 ;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag
1468 ;;     = code + header + label-offset
1469 (define-instruction compute-lra-from-code (segment src label temp dst)
1470   (:declare (type tn src dst temp)
1471             (type label label))
1472   (:vop-var vop)
1473   (:emitter
1474    (emit-compute-inst segment vop src label temp dst
1475                       #'(lambda (label posn delta-if-after)
1476                           (+ (label-position label posn delta-if-after)
1477                              (component-header-length))))))
1478
1479 \f
1480 ;;;; Data instructions.
1481
1482 (define-instruction byte (segment byte)
1483   (:emitter
1484    (emit-byte segment byte)))
1485
1486 (define-bitfield-emitter emit-halfword 16
1487   (byte 16 0))
1488
1489 (define-instruction halfword (segment halfword)
1490   (:emitter
1491    (emit-halfword segment halfword)))
1492
1493 (define-bitfield-emitter emit-word 32
1494   (byte 32 0))
1495
1496 (define-instruction word (segment word)
1497   (:emitter
1498    (emit-word segment word)))
1499
1500 (define-instruction fun-header-word (segment)
1501   (:emitter
1502    (emit-back-patch
1503     segment 4
1504     #'(lambda (segment posn)
1505         (emit-word segment
1506                    (logior simple-fun-header-widetag
1507                            (ash (+ posn (component-header-length))
1508                                 (- n-widetag-bits word-shift))))))))
1509
1510 (define-instruction lra-header-word (segment)
1511   (:emitter
1512    (emit-back-patch
1513     segment 4
1514     #'(lambda (segment posn)
1515         (emit-word segment
1516                    (logior return-pc-header-widetag
1517                            (ash (+ posn (component-header-length))
1518                                 (- n-widetag-bits word-shift))))))))