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