X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fppc%2Finsts.lisp;h=cdb9f5a50364da3d2504bf8408c2718ce03a01c3;hb=9304704f68a18894fa8eb985b387465e5d25e1d5;hp=8ccf2583fb6745bc71e3505e0111e4fb0318c6cd;hpb=cab2c71bb1bb8a575d9eebdae335e731daa64183;p=sbcl.git diff --git a/src/compiler/ppc/insts.lisp b/src/compiler/ppc/insts.lisp index 8ccf258..cdb9f5a 100644 --- a/src/compiler/ppc/insts.lisp +++ b/src/compiler/ppc/insts.lisp @@ -1,14 +1,24 @@ -;;; -;;; Written by William Lott -;;; - -(in-package "SB!VM") +;;;; the instruction set definition for the PPC -;(def-assembler-params -; :scheduler-p nil ; t when we trust the scheduler not to "fill delay slots" -; :max-locations 70) +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. +(in-package "SB!VM") +;;; needs a little more work in the assembler, to realise that the +;;; delays requested here are not mandatory, so that the assembler +;;; shouldn't fill gaps with NOPs but with real instructions. -- CSR, +;;; 2003-09-08 +#+nil +(eval-when (:compile-toplevel :load-toplevel :execute) + (setf sb!assem:*assem-scheduler-p* t) + (setf sb!assem:*assem-max-locations* 70)) ;;;; Constants, types, conversion functions, some disassembler stuff. @@ -19,8 +29,8 @@ (null null-offset) (t (if (eq (sb-name (sc-sb (tn-sc tn))) 'registers) - (tn-offset tn) - (error "~S isn't a register." tn))))) + (tn-offset tn) + (error "~S isn't a register." tn))))) (defun fp-reg-tn-encoding (tn) (declare (type tn tn)) @@ -32,7 +42,7 @@ (defvar *disassem-use-lisp-reg-names* t) -(!def-vm-support-routine location-number (loc) +(defun location-number (loc) (etypecase loc (null) (number) @@ -41,13 +51,13 @@ (tn (ecase (sb-name (sc-sb (tn-sc loc))) (immediate-constant - ;; Can happen if $ZERO or $NULL are passed in. - nil) + ;; Can happen if $ZERO or $NULL are passed in. + nil) (registers - (unless (zerop (tn-offset loc)) - (tn-offset loc))) + (unless (zerop (tn-offset loc)) + (tn-offset loc))) (float-registers - (+ (tn-offset loc) 32)))) + (+ (tn-offset loc) 32)))) (symbol (ecase loc (:memory 0) @@ -60,36 +70,56 @@ (defparameter reg-symbols (map 'vector #'(lambda (name) - (cond ((null name) nil) - (t (make-symbol (concatenate 'string "$" name))))) + (cond ((null name) nil) + (t (make-symbol (concatenate 'string "$" name))))) *register-names*)) +(defun maybe-add-notes (regno dstate) + (let* ((inst (sb!disassem::sap-ref-int + (sb!disassem::dstate-segment-sap dstate) + (sb!disassem::dstate-cur-offs dstate) + n-word-bytes + (sb!disassem::dstate-byte-order dstate))) + (op (ldb (byte 6 26) inst))) + (case op + ;; lwz + (32 + (when (= regno (ldb (byte 5 16) inst)) ; only for the second + (case (ldb (byte 5 16) inst) + ;; reg_CODE + (19 + (sb!disassem:note-code-constant (ldb (byte 16 0) inst) dstate))))) + ;; addi + (14 + (when (= regno null-offset) + (sb!disassem:maybe-note-nil-indexed-object + (ldb (byte 16 0) inst) dstate)))))) + (sb!disassem:define-arg-type reg - :printer #'(lambda (value stream dstate) - (declare (type stream stream) (fixnum value)) - (let ((regname (aref reg-symbols value))) - (princ regname stream) - (sb!disassem:maybe-note-associated-storage-ref - value - 'registers - regname - dstate)))) + :printer + (lambda (value stream dstate) + (declare (type stream stream) (fixnum value)) + (let ((regname (aref reg-symbols value))) + (princ regname stream) + (sb!disassem:maybe-note-associated-storage-ref + value 'registers regname dstate) + (maybe-add-notes value dstate)))) (defparameter float-reg-symbols - (coerce - (loop for n from 0 to 31 collect (make-symbol (format nil "$F~d" n))) - 'vector)) + #.(coerce + (loop for n from 0 to 31 collect (make-symbol (format nil "$F~d" n))) + 'vector)) (sb!disassem:define-arg-type fp-reg :printer #'(lambda (value stream dstate) - (declare (type stream stream) (fixnum value)) - (let ((regname (aref float-reg-symbols value))) - (princ regname stream) - (sb!disassem:maybe-note-associated-storage-ref - value - 'float-registers - regname - dstate)))) + (declare (type stream stream) (fixnum value)) + (let ((regname (aref float-reg-symbols value))) + (princ regname stream) + (sb!disassem:maybe-note-associated-storage-ref + value + 'float-registers + regname + dstate)))) (eval-when (:compile-toplevel :load-toplevel :execute) (defparameter bo-kind-names @@ -129,17 +159,17 @@ (if error-p (error "Invalid condition bit specifier : ~s" enc)))) (defun valid-cr-field-encoding (enc) - (let* ((field (if (integerp enc) + (let* ((field (if (integerp enc) (and (= enc (logand #x7 enc))) (position enc cr-field-names)))) (if field (ash field 2) (error "Invalid condition register field specifier : ~s" enc)))) - + (defun valid-bi-encoding (enc) (or - (if (atom enc) - (if (integerp enc) + (if (atom enc) + (if (integerp enc) (and (= enc (logand 31 enc)) enc) (position enc cr-bit-names)) (+ (valid-cr-field-encoding (car enc)) @@ -168,21 +198,21 @@ (sb!disassem:define-arg-type relative-label :sign-extend t :use-label #'(lambda (value dstate) - (declare (type (signed-byte 14) value) - (type sb!disassem:disassem-state dstate)) - (+ (ash value 2) (sb!disassem:dstate-cur-addr dstate)))) + (declare (type (signed-byte 14) value) + (type sb!disassem:disassem-state dstate)) + (+ (ash value 2) (sb!disassem:dstate-cur-addr dstate)))) (eval-when (:compile-toplevel :load-toplevel :execute) (defparameter trap-values-alist '((:t . 31) (:lt . 16) (:le . 20) (:eq . 4) (:lng . 6) (:ge .12) (:ne . 24) (:ng . 20) (:llt . 2) (:f . 0) (:lle . 6) (:lge . 5) (:lgt . 1) (:lnl . 5)))) - - + + (defun valid-tcond-encoding (enc) (or (and (if (integerp enc) (= (logand 31 enc) enc)) enc) (cdr (assoc enc trap-values-alist)) (error "Unknown trap condition: ~s" enc))) - + (sb!disassem:define-arg-type to-field :sign-extend nil :printer #'(lambda (value stream dstate) @@ -190,7 +220,7 @@ (type stream stream) (type fixnum value)) (princ (or (car (rassoc value trap-values-alist)) - value) + value) stream))) (defun snarf-error-junk (sap offset &optional length-only) @@ -202,21 +232,19 @@ (cond (length-only (values 0 (1+ length) nil nil)) (t - (sb!kernel:copy-from-system-area sap (* sb!vm:n-byte-bits (1+ offset)) - vector (* sb!vm:n-word-bits - sb!vm:vector-data-offset) - (* length sb!vm:n-byte-bits)) + (sb!kernel:copy-ub8-from-system-area sap (1+ offset) + vector 0 length) (collect ((sc-offsets) (lengths)) (lengths 1) ; the length byte (let* ((index 0) - (error-number (sb!c::read-var-integer vector index))) + (error-number (sb!c:read-var-integer vector index))) (lengths index) (loop (when (>= index length) (return)) (let ((old-index index)) - (sc-offsets (sb!c::read-var-integer vector index)) + (sc-offsets (sb!c:read-var-integer vector index)) (lengths (- index old-index)))) (values error-number (1+ length) @@ -240,26 +268,28 @@ ;; preserving 8 byte alignment segment 8 2 ; 2^2 is 4 byte alignment. I think #'(lambda (segment posn magic-value) - (let ((delta (ash (- (label-position target posn magic-value) posn) - -2))) - (when (typep delta '(signed-byte 14)) - (emit-back-patch segment 4 - #'(lambda (segment posn) - (emit-b-form-inst - segment 16 bo bi - (ash (- (label-position target) posn) -2) - aa-bit lk-bit))) - t))) + (let ((delta (ash (- (label-position target posn magic-value) posn) + -2))) + (when (typep delta '(signed-byte 14)) + (emit-back-patch segment 4 + #'(lambda (segment posn) + (emit-b-form-inst + segment 16 bo bi + (ash (- (label-position target) posn) -2) + aa-bit lk-bit))) + t))) #'(lambda (segment posn) - (let ((bo (logxor 8 bo))) ;; invert the test - (emit-b-form-inst segment 16 bo bi - 2 ; skip over next instruction - 0 0) - (emit-back-patch segment 4 - #'(lambda (segment posn) - (emit-i-form-branch segment target lk-p))))) + (declare (ignore posn)) + (let ((bo (logxor 8 bo))) ;; invert the test + (emit-b-form-inst segment 16 bo bi + 2 ; skip over next instruction + 0 0) + (emit-back-patch segment 4 + #'(lambda (segment posn) + (declare (ignore posn)) + (emit-i-form-branch segment target lk-p))))) )))) - + ; non-absolute I-form: B, BL. @@ -271,8 +301,8 @@ (emit-i-form-inst segment 18 0 0 lk-bit)) (label (emit-back-patch segment 4 - #'(lambda (segment posn) - (emit-i-form-inst + #'(lambda (segment posn) + (emit-i-form-inst segment 18 (ash (- (label-position target) posn) -2) @@ -294,9 +324,9 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defparameter jump-printer #'(lambda (value stream dstate) - (let ((addr (ash value 2))) - (sb!disassem:maybe-note-assembler-routine addr t dstate) - (write addr :base 16 :radix t :stream stream))))) + (let ((addr (ash value 2))) + (sb!disassem:maybe-note-assembler-routine addr t dstate) + (write addr :base 16 :radix t :stream stream))))) @@ -352,7 +382,7 @@ (xo26-30 :field ,(ppc-byte 26 30) :sign-extend nil))) - + (sb!disassem:define-instruction-format (instr 32) (op :field (byte 6 26)) (other :field (byte 26 0))) @@ -368,7 +398,7 @@ (macrolet ((def-ppc-iformat ((name &optional default-printer) &rest specs) - (flet ((specname-field (specname) + (flet ((specname-field (specname) (or (assoc specname *ppc-field-specs-alist*) (error "Unknown ppc instruction field spec ~s" specname)))) (labels ((spec-field (spec) @@ -377,18 +407,18 @@ (cons (car spec) (cdr (specname-field (cadr spec))))))) (collect ((field (list '(op :field (byte 6 26))))) - (dolist (spec specs) + (dolist (spec specs) (field (spec-field spec))) `(sb!disassem:define-instruction-format (,name 32 ,@(if default-printer `(:default-printer ,default-printer))) ,@(field))))))) -(def-ppc-iformat (i '(:name :tab li)) +(def-ppc-iformat (i '(:name :tab li)) li aa lk) -(def-ppc-iformat (i-abs '(:name :tab li-abs)) +(def-ppc-iformat (i-abs '(:name :tab li-abs)) li-abs aa lk) -(def-ppc-iformat (b '(:name :tab bo "," bi "," bd)) +(def-ppc-iformat (b '(:name :tab bo "," bi "," bd)) bo bi bd aa lk) (def-ppc-iformat (d '(:name :tab rt "," d "(" ra ")")) @@ -417,7 +447,7 @@ (def-ppc-iformat (d-frs '(:name :tab frs "," d "(" ra ")")) frs ra d) - + ;;; There are around ... oh, 28 or so ... variants on the "X" format. @@ -593,25 +623,24 @@ (declare (ignore inst)) (flet ((nt (x) (if stream (sb!disassem:note x dstate)))) (case (xinstr-data chunk dstate) - (#.sb!vm:error-trap + (#.error-trap (nt "Error trap") (sb!disassem:handle-break-args #'snarf-error-junk stream dstate)) - (#.sb!vm:cerror-trap + (#.cerror-trap (nt "Cerror trap") (sb!disassem:handle-break-args #'snarf-error-junk stream dstate)) - (#.sb!vm:object-not-list-trap + (#.object-not-list-trap (nt "Object not list trap")) - (#.sb!vm:breakpoint-trap + (#.breakpoint-trap (nt "Breakpoint trap")) - (#.sb!vm:pending-interrupt-trap + (#.pending-interrupt-trap (nt "Pending interrupt trap")) - (#.sb!vm:halt-trap + (#.halt-trap (nt "Halt trap")) - (#.sb!vm:fun-end-breakpoint-trap + (#.fun-end-breakpoint-trap (nt "Function end breakpoint trap")) - (#.sb!vm:object-not-instance-trap - (nt "Object not instance trap")) - ))) + (#.object-not-instance-trap + (nt "Object not instance trap"))))) (eval-when (:compile-toplevel :execute) @@ -627,14 +656,14 @@ (name op xo oe-p rc-p always-reads-xer always-writes-xer cost) `(define-instruction ,name (segment rt ra rb) (:printer xo ((op ,op ) (xo ,xo) (oe ,(if oe-p 1 0)) (rc ,(if rc-p 1 0)))) - (:dependencies (reads ra) (reads rb) ,@(if always-reads-xer '((reads :xer))) + (:dependencies (reads ra) (reads rb) ,@(if always-reads-xer '((reads :xer))) (writes rt) ,@(if rc-p '((writes :ccr))) ,@(if (or oe-p always-writes-xer) '((writes :xer))) ) (:cost ,cost) (:delay ,cost) (:emitter (emit-xo-form-inst segment ,op - (reg-tn-encoding rt) - (reg-tn-encoding ra) + (reg-tn-encoding rt) + (reg-tn-encoding ra) (reg-tn-encoding rb) ,(if oe-p 1 0) ,xo @@ -643,14 +672,14 @@ (name op xo rc-p always-reads-xer always-writes-xer cost) `(define-instruction ,name (segment rt ra rb) (:printer xo-oe ((op ,op) (xo ,xo) (rc ,(if rc-p 1 0)))) - (:dependencies (reads ra) (reads rb) ,@(if always-reads-xer '((reads :xer))) + (:dependencies (reads ra) (reads rb) ,@(if always-reads-xer '((reads :xer))) (writes rt) ,@(if rc-p '((writes :ccr))) ,@(if always-writes-xer '((writes :xer)))) (:cost ,cost) (:delay ,cost) (:emitter (emit-xo-form-inst segment ,op - (reg-tn-encoding rt) - (reg-tn-encoding ra) + (reg-tn-encoding rt) + (reg-tn-encoding ra) (reg-tn-encoding rb) 0 ,xo @@ -667,7 +696,7 @@ `(progn (define-xo-oe-instruction ,base ,op ,xo nil ,always-reads-xer ,always-writes-xer ,cost) (define-xo-oe-instruction ,(symbolicate base ".") ,op ,xo t ,always-reads-xer ,always-writes-xer ,cost))) - + (define-xo-a-instruction (name op xo oe-p rc-p always-reads-xer always-writes-xer cost) `(define-instruction ,name (segment rt ra) (:printer xo-a ((op ,op) (xo ,xo) (rc ,(if rc-p 1 0)) (oe ,(if oe-p 1 0)))) @@ -677,31 +706,31 @@ (:delay ,cost) (:emitter (emit-xo-form-inst segment ,op - (reg-tn-encoding rt) - (reg-tn-encoding ra) + (reg-tn-encoding rt) + (reg-tn-encoding ra) 0 (if ,oe-p 1 0) ,xo (if ,rc-p 1 0))))) - + (define-4-xo-a-instructions (base op xo &key always-reads-xer always-writes-xer (cost 1)) `(progn (define-xo-a-instruction ,base ,op ,xo nil nil ,always-reads-xer ,always-writes-xer ,cost) (define-xo-a-instruction ,(symbolicate base ".") ,op ,xo nil t ,always-reads-xer ,always-writes-xer ,cost) (define-xo-a-instruction ,(symbolicate base "O") ,op ,xo t nil ,always-reads-xer ,always-writes-xer ,cost) (define-xo-a-instruction ,(symbolicate base "O.") ,op ,xo t t ,always-reads-xer ,always-writes-xer ,cost))) - + (define-x-instruction (name op xo &key (cost 2) other-dependencies) (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies) `(define-instruction ,name (segment rt ra rb) (:printer x ((op ,op) (xo ,xo))) (:delay ,cost) (:cost ,cost) - (:dependencies (reads ra) (reads rb) ,@ other-reads + (:dependencies (reads ra) (reads rb) (reads :memory) ,@other-reads (writes rt) ,@other-writes) (:emitter - (emit-x-form-inst segment ,op - (reg-tn-encoding rt) + (emit-x-form-inst segment ,op + (reg-tn-encoding rt) (reg-tn-encoding ra) (reg-tn-encoding rb) ,xo @@ -713,27 +742,27 @@ (:printer x-20 ((op ,op) (xo ,xo))) (:delay ,cost) (:cost ,cost) - (:dependencies (reads ra) (reads rb) ,@other-reads + (:dependencies (reads ra) (reads rb) ,@other-reads (writes frt) ,@other-writes) (:emitter - (emit-x-form-inst segment ,op - (fp-reg-tn-encoding frt) + (emit-x-form-inst segment ,op + (fp-reg-tn-encoding frt) (reg-tn-encoding ra) (reg-tn-encoding rb) ,xo 0))))) - + (define-x-5-instruction (name op xo rc-p &key (cost 1) other-dependencies) (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies) `(define-instruction ,name (segment ra rs rb) (:printer x-5 ((op ,op) (xo ,xo) (rc ,(if rc-p 1 0)))) (:delay ,cost) (:cost ,cost) - (:dependencies (reads rb) (reads rs) ,@other-reads + (:dependencies (reads rb) (reads rs) ,@other-reads (writes ra) ,@other-writes) (:emitter - (emit-x-form-inst segment ,op - (reg-tn-encoding rs) + (emit-x-form-inst segment ,op + (reg-tn-encoding rs) (reg-tn-encoding ra) (reg-tn-encoding rb) ,xo @@ -746,27 +775,27 @@ (:printer x-5 ((op ,op) (xo ,xo) (rc ,(if rc-p 1 0)))) (:delay ,cost) (:cost ,cost) - (:dependencies (reads ra) (reads rb) (reads rs) ,@other-reads - ,@other-writes) + (:dependencies (reads ra) (reads rb) (reads rs) ,@other-reads + (writes :memory :partially t) ,@other-writes) (:emitter - (emit-x-form-inst segment ,op - (reg-tn-encoding rs) + (emit-x-form-inst segment ,op + (reg-tn-encoding rs) (reg-tn-encoding ra) (reg-tn-encoding rb) ,xo ,(if rc-p 1 0)))))) - + (define-x-23-st-instruction (name op xo &key (cost 1) other-dependencies) (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies) `(define-instruction ,name (segment frs ra rb) (:printer x-23 ((op ,op) (xo ,xo))) (:delay ,cost) (:cost ,cost) - (:dependencies (reads ra) (reads rb) (reads frs) ,@other-reads - ,@other-writes) + (:dependencies (reads ra) (reads rb) (reads frs) ,@other-reads + (writes :memory :partially t) ,@other-writes) (:emitter - (emit-x-form-inst segment ,op - (fp-reg-tn-encoding frs) + (emit-x-form-inst segment ,op + (fp-reg-tn-encoding frs) (reg-tn-encoding ra) (reg-tn-encoding rb) ,xo @@ -778,11 +807,11 @@ (:printer x-10 ((op ,op) (xo ,xo) (rc ,(if rc-p 1 0)))) (:delay ,cost) (:cost ,cost) - (:dependencies (reads rs) ,@other-reads + (:dependencies (reads rs) ,@other-reads (writes ra) ,@other-writes) (:emitter - (emit-x-form-inst segment ,op - (reg-tn-encoding rs) + (emit-x-form-inst segment ,op + (reg-tn-encoding rs) (reg-tn-encoding ra) 0 ,xo @@ -791,23 +820,23 @@ (define-2-x-5-instructions (name op xo &key (cost 1) other-dependencies) `(progn (define-x-5-instruction ,name ,op ,xo nil :cost ,cost :other-dependencies ,other-dependencies) - (define-x-5-instruction ,(symbolicate name ".") ,op ,xo t :cost ,cost + (define-x-5-instruction ,(symbolicate name ".") ,op ,xo t :cost ,cost :other-dependencies ,other-dependencies))) - + (define-2-x-10-instructions (name op xo &key (cost 1) other-dependencies) `(progn (define-x-10-instruction ,name ,op ,xo nil :cost ,cost :other-dependencies ,other-dependencies) - (define-x-10-instruction ,(symbolicate name ".") ,op ,xo t :cost ,cost + (define-x-10-instruction ,(symbolicate name ".") ,op ,xo t :cost ,cost :other-dependencies ,other-dependencies))) - - + + (define-x-21-instruction (name op xo rc-p &key (cost 4) other-dependencies) (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies) `(define-instruction ,name (segment frt frb) (:printer x-21 ((op ,op) (xo ,xo) (rc ,(if rc-p 1 0)))) (:cost ,cost) (:delay ,cost) - (:dependencies (reads frb) ,@other-reads + (:dependencies (reads frb) ,@other-reads (writes frt) ,@other-writes) (:emitter (emit-x-form-inst segment ,op @@ -816,30 +845,32 @@ (fp-reg-tn-encoding frb) ,xo ,(if rc-p 1 0)))))) - + (define-2-x-21-instructions (name op xo &key (cost 4) other-dependencies) `(progn (define-x-21-instruction ,name ,op ,xo nil :cost ,cost :other-dependencies ,other-dependencies) - (define-x-21-instruction ,(symbolicate name ".") ,op ,xo t :cost ,cost + (define-x-21-instruction ,(symbolicate name ".") ,op ,xo t :cost ,cost :other-dependencies ,other-dependencies))) - + (define-d-si-instruction (name op &key (fixup nil) (cost 1) other-dependencies) (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies) `(define-instruction ,name (segment rt ra si) - (:declare (type (signed-byte 16))) + (:declare (type (or ,@(when fixup '(fixup)) + (unsigned-byte 16) (signed-byte 16)) + si)) (:printer d-si ((op ,op))) (:delay ,cost) (:cost ,cost) - (:dependencies (reads ra) ,@other-reads + (:dependencies (reads ra) ,@other-reads (writes rt) ,@other-writes) (:emitter (when (typep si 'fixup) (ecase ,fixup ((:ha :l) (note-fixup segment ,fixup si))) - (setq si 0)) + (setq si (or (fixup-offset si) 0))) (emit-d-form-inst segment ,op (reg-tn-encoding rt) (reg-tn-encoding ra) si))))) - + (define-d-rs-ui-instruction (name op &key (cost 1) other-dependencies) (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies) `(define-instruction ,name (segment ra rs ui) @@ -847,11 +878,11 @@ (:printer d-rs-ui ((op ,op))) (:cost ,cost) (:delay ,cost) - (:dependencies (reads rs) ,@other-reads + (:dependencies (reads rs) ,@other-reads (writes ra) ,@other-writes) (:emitter (emit-d-form-inst segment ,op (reg-tn-encoding rs) (reg-tn-encoding ra) ui))))) - + (define-d-instruction (name op &key (cost 2) other-dependencies pinned) (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies) `(define-instruction ,name (segment rt ra si) @@ -860,11 +891,11 @@ (:delay ,cost) (:cost ,cost) ,@(when pinned '(:pinned)) - (:dependencies (reads ra) ,@other-reads + (:dependencies (reads ra) (reads :memory) ,@other-reads (writes rt) ,@other-writes) (:emitter (emit-d-form-inst segment ,op (reg-tn-encoding rt) (reg-tn-encoding ra) si))))) - + (define-d-frt-instruction (name op &key (cost 3) other-dependencies) (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies) `(define-instruction ,name (segment frt ra si) @@ -872,7 +903,7 @@ (:printer d-frt ((op ,op))) (:delay ,cost) (:cost ,cost) - (:dependencies (reads ra) ,@other-reads + (:dependencies (reads ra) (reads :memory) ,@other-reads (writes frt) ,@other-writes) (:emitter (emit-d-form-inst segment ,op (fp-reg-tn-encoding frt) (reg-tn-encoding ra) si))))) @@ -885,7 +916,7 @@ (:delay ,cost) (:cost ,cost) ,@(when pinned '(:pinned)) - (:dependencies (reads rs) (reads ra) ,@other-reads + (:dependencies (reads rs) (reads ra) ,@other-reads (writes :memory :partially t) ,@other-writes) (:emitter (emit-d-form-inst segment ,op (reg-tn-encoding rs) (reg-tn-encoding ra) si))))) @@ -897,7 +928,7 @@ (:printer d-frs ((op ,op))) (:delay ,cost) (:cost ,cost) - (:dependencies (reads frs) (reads ra) ,@other-reads + (:dependencies (reads frs) (reads ra) ,@other-reads (writes :memory :partially t) ,@other-writes) (:emitter (emit-d-form-inst segment ,op (fp-reg-tn-encoding frs) (reg-tn-encoding ra) si))))) @@ -909,21 +940,21 @@ (:delay ,cost) (:dependencies (writes frt) (reads fra) (reads frb) (reads frc) ,@other-dependencies) (:emitter - (emit-a-form-inst segment - ,op - (fp-reg-tn-encoding frt) - (fp-reg-tn-encoding fra) + (emit-a-form-inst segment + ,op + (fp-reg-tn-encoding frt) + (fp-reg-tn-encoding fra) (fp-reg-tn-encoding frb) (fp-reg-tn-encoding frb) ,xo ,rc)))) - + (define-2-a-instructions (name op xo &key (cost 1) other-dependencies) `(progn (define-a-instruction ,name ,op ,xo 0 :cost ,cost :other-dependencies ,other-dependencies) (define-a-instruction ,(symbolicate name ".") ,op ,xo 1 :cost ,cost :other-dependencies ,other-dependencies))) - + (define-a-tab-instruction (name op xo rc &key (cost 1) other-dependencies) (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies) `(define-instruction ,name (segment frt fra frb) @@ -933,45 +964,45 @@ (:dependencies (reads fra) (reads frb) ,@other-reads (writes frt) ,@other-writes) (:emitter - (emit-a-form-inst segment - ,op - (fp-reg-tn-encoding frt) - (fp-reg-tn-encoding fra) + (emit-a-form-inst segment + ,op + (fp-reg-tn-encoding frt) + (fp-reg-tn-encoding fra) (fp-reg-tn-encoding frb) 0 ,xo ,rc))))) - + (define-2-a-tab-instructions (name op xo &key (cost 1) other-dependencies) `(progn (define-a-tab-instruction ,name ,op ,xo 0 :cost ,cost :other-dependencies ,other-dependencies) (define-a-tab-instruction ,(symbolicate name ".") ,op ,xo 1 :cost ,cost :other-dependencies ,other-dependencies))) - + (define-a-tac-instruction (name op xo rc &key (cost 1) other-dependencies) (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies) - `(define-instruction ,name (segment frt fra frc) + `(define-instruction ,name (segment frt fra frb) (:printer a-tac ((op ,op) (xo ,xo) (rc ,rc))) (:cost ,cost) (:delay 1) (:dependencies (reads fra) (reads frb) ,@other-reads (writes frt) ,@other-writes) (:emitter - (emit-a-form-inst segment - ,op - (fp-reg-tn-encoding frt) - (fp-reg-tn-encoding fra) + (emit-a-form-inst segment + ,op + (fp-reg-tn-encoding frt) + (fp-reg-tn-encoding fra) 0 - (fp-reg-tn-encoding frc) + (fp-reg-tn-encoding frb) ,xo ,rc))))) - + (define-2-a-tac-instructions (name op xo &key (cost 1) other-dependencies) `(progn (define-a-tac-instruction ,name ,op ,xo 0 :cost ,cost :other-dependencies ,other-dependencies) (define-a-tac-instruction ,(symbolicate name ".") ,op ,xo 1 :cost ,cost :other-dependencies ,other-dependencies))) - + (define-crbit-instruction (name op xo) `(define-instruction ,name (segment dbit abit bbit) (:printer xl ((op ,op ) (xo ,xo))) @@ -984,7 +1015,7 @@ (valid-bi-encoding bbit) ,xo 0))))) - + ;;; The instructions, in numerical order (define-instruction unimp (segment data) @@ -997,183 +1028,199 @@ (define-instruction twi (segment tcond ra si) (:printer d-to ((op 3))) - (:delay 1) + (:delay 0) :pinned (:emitter (emit-d-form-inst segment 3 (valid-tcond-encoding tcond) (reg-tn-encoding ra) si))) - + (define-d-si-instruction mulli 7 :cost 5) (define-d-si-instruction subfic 8) - + (define-instruction cmplwi (segment crf ra &optional (ui nil ui-p)) (:printer d-crf-ui ((op 10) (l 0)) '(:name :tab bf "," ra "," ui)) (:dependencies (if ui-p (reads ra) (reads crf)) (writes :ccr)) (:delay 1) - (:emitter + (:emitter (unless ui-p (setq ui ra ra crf crf :cr0)) - (emit-d-form-inst segment + (emit-d-form-inst segment 10 - (valid-cr-field-encoding crf) + (valid-cr-field-encoding crf) (reg-tn-encoding ra) ui))) - + (define-instruction cmpwi (segment crf ra &optional (si nil si-p)) (:printer d-crf-si ((op 11) (l 0)) '(:name :tab bf "," ra "," si)) (:dependencies (if si-p (reads ra) (reads crf)) (writes :ccr)) (:delay 1) - (:emitter + (:emitter (unless si-p (setq si ra ra crf crf :cr0)) - (emit-d-form-inst segment + (emit-d-form-inst segment 11 - (valid-cr-field-encoding crf) + (valid-cr-field-encoding crf) (reg-tn-encoding ra) si))) - + (define-d-si-instruction addic 12 :other-dependencies ((writes :xer))) (define-d-si-instruction addic. 13 :other-dependencies ((writes :xer) (writes :ccr))) - + (define-d-si-instruction addi 14 :fixup :l) (define-d-si-instruction addis 15 :fixup :ha) - + ;; There's no real support here for branch options that decrement ;; and test the CTR : - ;; (a) the instruction scheduler doesn't know that anything's happening + ;; (a) the instruction scheduler doesn't know that anything's happening ;; to the CTR - ;; (b) Lisp may have to assume that the CTR always has a lisp + ;; (b) Lisp may have to assume that the CTR always has a lisp ;; object/locative in it. - + (define-instruction bc (segment bo bi target) (:declare (type label target)) (:printer b ((op 16) (aa 0) (lk 0))) - (:delay 1) + (:attributes branch) + (:delay 0) (:dependencies (reads :ccr)) (:emitter (emit-conditional-branch segment bo bi target))) - + (define-instruction bcl (segment bo bi target) (:declare (type label target)) (:printer b ((op 16) (aa 0) (lk 1))) - (:delay 1) + (:attributes branch) + (:delay 0) (:dependencies (reads :ccr)) (:emitter (emit-conditional-branch segment bo bi target nil t))) - + (define-instruction bca (segment bo bi target) (:declare (type label target)) (:printer b ((op 16) (aa 1) (lk 0))) - (:delay 1) + (:attributes branch) + (:delay 0) (:dependencies (reads :ccr)) (:emitter (emit-conditional-branch segment bo bi target t))) - + (define-instruction bcla (segment bo bi target) (:declare (type label target)) (:printer b ((op 16) (aa 1) (lk 1))) - (:delay 1) + (:attributes branch) + (:delay 0) (:dependencies (reads :ccr)) (:emitter (emit-conditional-branch segment bo bi target t t))) - -;;; There may (or may not) be a good reason to use this in preference to "b[la] target". -;;; I can't think of a -bad- reason ... - + +;;; There may (or may not) be a good reason to use this in preference +;;; to "b[la] target". I can't think of a -bad- reason ... + (define-instruction bu (segment target) (:declare (type label target)) - (:printer b ((op 16) (bo #.(valid-bo-encoding :bo-u)) (bi 0) (aa 0) (lk 0)) + (:printer b ((op 16) (bo #.(valid-bo-encoding :bo-u)) (bi 0) (aa 0) (lk 0)) '(:name :tab bd)) - (:delay 1) + (:attributes branch) + (:delay 0) (:emitter (emit-conditional-branch segment #.(valid-bo-encoding :bo-u) 0 target nil nil))) - - + + (define-instruction bt (segment bi target) (:printer b ((op 16) (bo #.(valid-bo-encoding :bo-t)) (aa 0) (lk 0)) '(:name :tab bi "," bd)) - (:delay 1) + (:attributes branch) + (:delay 0) (:emitter (emit-conditional-branch segment #.(valid-bo-encoding :bo-t) bi target nil nil))) - + (define-instruction bf (segment bi target) (:printer b ((op 16) (bo #.(valid-bo-encoding :bo-f)) (aa 0) (lk 0)) '(:name :tab bi "," bd)) - (:delay 1) + (:attributes branch) + (:delay 0) (:emitter (emit-conditional-branch segment #.(valid-bo-encoding :bo-f) bi target nil nil))) - + (define-instruction b? (segment cr-field-name cr-name &optional (target nil target-p)) - (:delay 1) - (:emitter + (:attributes branch) + (:delay 0) + (:emitter (unless target-p (setq target cr-name cr-name cr-field-name cr-field-name :cr0)) (let* ((+cond (position cr-name cr-bit-names)) (-cond (position cr-name cr-bit-inverse-names)) - (b0 (if +cond :bo-t - (if -cond + (b0 (if +cond :bo-t + (if -cond :bo-f (error "Unknown branch condition ~s" cr-name)))) (cr-form (list cr-field-name (if +cond cr-name (svref cr-bit-names -cond))))) (emit-conditional-branch segment b0 cr-form target)))) - + (define-instruction sc (segment) (:printer sc ((op 17))) - (:delay 1) + (:attributes branch) + (:delay 0) :pinned (:emitter (emit-sc-form-inst segment 17 2))) (define-instruction b (segment target) (:printer i ((op 18) (aa 0) (lk 0))) - (:delay 1) + (:attributes branch) + (:delay 0) (:emitter (emit-i-form-branch segment target nil))) - + (define-instruction ba (segment target) (:printer i-abs ((op 18) (aa 1) (lk 0))) - (:delay 1) + (:attributes branch) + (:delay 0) (:emitter (when (typep target 'fixup) (note-fixup segment :ba target) (setq target 0)) (emit-i-form-inst segment 18 (ash target -2) 1 0))) - - + + (define-instruction bl (segment target) (:printer i ((op 18) (aa 0) (lk 1))) - (:delay 1) + (:attributes branch) + (:delay 0) (:emitter (emit-i-form-branch segment target t))) - + (define-instruction bla (segment target) (:printer i-abs ((op 18) (aa 1) (lk 1))) - (:delay 1) + (:attributes branch) + (:delay 0) (:emitter (when (typep target 'fixup) (note-fixup segment :ba target) (setq target 0)) (emit-i-form-inst segment 18 (ash target -2) 1 1))) - + (define-instruction blr (segment) (:printer xl-bo-bi ((op 19) (xo 16) (bo #.(valid-bo-encoding :bo-u))(bi 0) (lk 0)) '(:name)) - (:delay 1) + (:attributes branch) + (:delay 0) (:dependencies (reads :ccr) (reads :ctr)) (:emitter (emit-x-form-inst segment 19 (valid-bo-encoding :bo-u) 0 0 16 0))) - + (define-instruction bclr (segment bo bi) (:printer xl-bo-bi ((op 19) (xo 16))) - (:delay 1) + (:attributes branch) + (:delay 0) (:dependencies (reads :ccr) (reads :lr)) (:emitter (emit-x-form-inst segment 19 (valid-bo-encoding bo) (valid-bi-encoding bi) 0 16 0))) - + (define-instruction bclrl (segment bo bi) (:printer xl-bo-bi ((op 19) (xo 16) (lk 1))) - (:delay 1) + (:attributes branch) + (:delay 0) (:dependencies (reads :ccr) (reads :lr)) (:emitter (emit-x-form-inst segment 19 (valid-bo-encoding bo) (valid-bi-encoding bi) 0 16 1))) - + (define-crbit-instruction crnor 19 33) (define-crbit-instruction crandc 19 129) (define-instruction isync (segment) @@ -1181,63 +1228,67 @@ (:delay 1) :pinned (:emitter (emit-x-form-inst segment 19 0 0 0 150 0))) - + (define-crbit-instruction crxor 19 193) (define-crbit-instruction crnand 19 225) (define-crbit-instruction crand 19 257) (define-crbit-instruction creqv 19 289) (define-crbit-instruction crorc 19 417) (define-crbit-instruction cror 19 449) - + (define-instruction bcctr (segment bo bi) (:printer xl-bo-bi ((op 19) (xo 528))) - (:delay 1) + (:attributes branch) + (:delay 0) (:dependencies (reads :ccr) (reads :ctr)) (:emitter (emit-x-form-inst segment 19 (valid-bo-encoding bo) (valid-bi-encoding bi) 0 528 0))) - + (define-instruction bcctrl (segment bo bi) (:printer xl-bo-bi ((op 19) (xo 528) (lk 1))) - (:delay 1) + (:attributes branch) + (:delay 0) (:dependencies (reads :ccr) (reads :ctr) (writes :lr)) (:emitter (emit-x-form-inst segment 19 (valid-bo-encoding bo) (valid-bi-encoding bi) 0 528 1))) - + (define-instruction bctr (segment) (:printer xl-bo-bi ((op 19) (xo 528) (bo #.(valid-bo-encoding :bo-u)) (bi 0) (lk 0)) '(:name)) - (:delay 1) + (:attributes branch) + (:delay 0) (:dependencies (reads :ccr) (reads :ctr)) (:emitter (emit-x-form-inst segment 19 #.(valid-bo-encoding :bo-u) 0 0 528 0))) - + (define-instruction bctrl (segment) (:printer xl-bo-bi ((op 19) (xo 528) (bo #.(valid-bo-encoding :bo-u)) (bi 0) (lk 1)) '(:name)) - (:delay 1) + (:attributes branch) + (:delay 0) (:dependencies (reads :ccr) (reads :ctr)) (:emitter (emit-x-form-inst segment 19 #.(valid-bo-encoding :bo-u) 0 0 528 1))) - + (define-instruction rlwimi (segment ra rs sh mb me) (:printer m-sh ((op 20) (rc 0))) (:dependencies (reads rs) (writes ra)) (:delay 1) (:emitter (emit-a-form-inst segment 20 (reg-tn-encoding rs) (reg-tn-encoding ra) sh mb me 0))) - + (define-instruction rlwimi. (segment ra rs sh mb me) (:printer m-sh ((op 20) (rc 1))) (:dependencies (reads rs) (writes ra) (writes :ccr)) (:delay 1) (:emitter (emit-a-form-inst segment 20 (reg-tn-encoding rs) (reg-tn-encoding ra) sh mb me 1))) - + (define-instruction rlwinm (segment ra rs sh mb me) (:printer m-sh ((op 21) (rc 0))) (:delay 1) (:dependencies (reads rs) (writes ra)) (:emitter (emit-a-form-inst segment 21 (reg-tn-encoding rs) (reg-tn-encoding ra) sh mb me 0))) - + (define-instruction rlwinm. (segment ra rs sh mb me) (:printer m-sh ((op 21) (rc 1))) (:delay 1) @@ -1251,115 +1302,116 @@ (:dependencies (reads rs) (writes ra) (reads rb)) (:emitter (emit-a-form-inst segment 23 (reg-tn-encoding rs) (reg-tn-encoding ra) (reg-tn-encoding rb) mb me 0))) - + (define-instruction rlwnm. (segment ra rs rb mb me) (:printer m ((op 23) (rc 1) (rb nil :type 'reg))) (:delay 1) (:dependencies (reads rs) (reads rb) (writes ra) (writes :ccr)) (:emitter (emit-a-form-inst segment 23 (reg-tn-encoding rs) (reg-tn-encoding ra) (reg-tn-encoding rb) mb me 1))) - - + + (define-d-rs-ui-instruction ori 24) - + (define-instruction nop (segment) (:printer d-rs-ui ((op 24) (rs 0) (ra 0) (ui 0)) '(:name)) (:cost 1) (:delay 1) (:emitter (emit-d-form-inst segment 24 0 0 0))) - + (define-d-rs-ui-instruction oris 25) (define-d-rs-ui-instruction xori 26) (define-d-rs-ui-instruction xoris 27) (define-d-rs-ui-instruction andi. 28 :other-dependencies ((writes :ccr))) (define-d-rs-ui-instruction andis. 29 :other-dependencies ((writes :ccr))) - + (define-instruction cmpw (segment crf ra &optional (rb nil rb-p)) (:printer x-14 ((op 31) (xo 0) (l 0)) '(:name :tab bf "," ra "," rb)) (:delay 1) (:dependencies (reads ra) (if rb-p (reads rb) (reads crf)) (reads :xer) (writes :ccr)) - (:emitter + (:emitter (unless rb-p (setq rb ra ra crf crf :cr0)) - (emit-x-form-inst segment + (emit-x-form-inst segment 31 - (valid-cr-field-encoding crf) + (valid-cr-field-encoding crf) (reg-tn-encoding ra) (reg-tn-encoding rb) 0 0))) - + (define-instruction tw (segment tcond ra rb) (:printer x-19 ((op 31) (xo 4))) - (:delay 1) + (:attributes branch) + (:delay 0) :pinned (:emitter (emit-x-form-inst segment 31 (valid-tcond-encoding tcond) (reg-tn-encoding ra) (reg-tn-encoding rb) 4 0))) - + (define-4-xo-instructions subfc 31 8 :always-writes-xer t) (define-4-xo-instructions addc 31 10 :always-writes-xer t) (define-2-xo-oe-instructions mulhwu 31 11 :cost 5) - + (define-instruction mfcr (segment rd) (:printer x-4 ((op 31) (xo 19))) (:delay 1) (:dependencies (reads :ccr) (writes rd)) (:emitter (emit-x-form-inst segment 31 (reg-tn-encoding rd) 0 0 19 0))) - + (define-x-instruction lwarx 31 20) (define-x-instruction lwzx 31 23) (define-2-x-5-instructions slw 31 24) (define-2-x-10-instructions cntlzw 31 26) (define-2-x-5-instructions and 31 28) - + (define-instruction cmplw (segment crf ra &optional (rb nil rb-p)) (:printer x-14 ((op 31) (xo 32) (l 0)) '(:name :tab bf "," ra "," rb)) (:delay 1) (:dependencies (reads ra) (if rb-p (reads rb) (reads crf)) (reads :xer) (writes :ccr)) - (:emitter + (:emitter (unless rb-p (setq rb ra ra crf crf :cr0)) - (emit-x-form-inst segment + (emit-x-form-inst segment 31 - (valid-cr-field-encoding crf) + (valid-cr-field-encoding crf) (reg-tn-encoding ra) (reg-tn-encoding rb) 32 0))) - - + + (define-4-xo-instructions subf 31 40) ; dcbst (define-x-instruction lwzux 31 55 :other-dependencies ((writes rt))) (define-2-x-5-instructions andc 31 60) (define-2-xo-oe-instructions mulhw 31 75 :cost 5) - + (define-x-instruction lbzx 31 87) (define-4-xo-a-instructions neg 31 104) (define-x-instruction lbzux 31 119 :other-dependencies ((writes rt))) (define-2-x-5-instructions nor 31 124) (define-4-xo-instructions subfe 31 136 :always-reads-xer t :always-writes-xer t) - + (define-instruction-macro sube (rt ra rb) `(inst subfe ,rt ,rb ,ra)) - + (define-instruction-macro sube. (rt ra rb) `(inst subfe. ,rt ,rb ,ra)) - + (define-instruction-macro subeo (rt ra rb) `(inst subfeo ,rt ,rb ,ra)) - + (define-instruction-macro subeo. (rt ra rb) `(inst subfeo ,rt ,rb ,ra)) - + (define-4-xo-instructions adde 31 138 :always-reads-xer t :always-writes-xer t) - + (define-instruction mtcrf (segment mask rt) (:printer xfx-fxm ((op 31) (xo 144))) (:delay 1) (:dependencies (reads rt) (writes :ccr)) (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash mask 1) 144 0))) - + (define-x-5-st-instruction stwcx. 31 150 t :other-dependencies ((writes :ccr))) (define-x-5-st-instruction stwx 31 151 nil) (define-x-5-st-instruction stwux 31 183 nil :other-dependencies ((writes ra))) @@ -1375,38 +1427,38 @@ (define-2-x-5-instructions eqv 31 284) (define-x-instruction lhzux 31 311 :other-dependencies ((writes ra))) (define-2-x-5-instructions xor 31 316) - + (define-instruction mfmq (segment rt) (:printer xfx ((op 31) (xo 339) (spr 0)) '(:name :tab rt)) (:delay 1) (:dependencies (reads :xer) (writes rt)) (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 0 5) 339 0))) - + (define-instruction mfxer (segment rt) (:printer xfx ((op 31) (xo 339) (spr 1)) '(:name :tab rt)) (:delay 1) (:dependencies (reads :xer) (writes rt)) (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 1 5) 339 0))) - + (define-instruction mflr (segment rt) (:printer xfx ((op 31) (xo 339) (spr 8)) '(:name :tab rt)) (:delay 1) (:dependencies (reads :lr) (writes rt)) (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 8 5) 339 0))) - + (define-instruction mfctr (segment rt) (:printer xfx ((op 31) (xo 339) (spr 9)) '(:name :tab rt)) (:delay 1) (:dependencies (reads rt) (reads :ctr)) (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 9 5) 339 0))) - - + + (define-x-instruction lhax 31 343) (define-x-instruction lhaux 31 375 :other-dependencies ((writes ra))) (define-x-5-st-instruction sthx 31 407 nil) (define-2-x-5-instructions orc 31 412) (define-x-5-st-instruction sthux 31 439 nil :other-dependencies ((writes ra))) - + (define-instruction or (segment ra rs rb) (:printer x-5 ((op 31) (xo 444) (rc 0)) '((:cond ((rs :same-as rb) 'mr) @@ -1420,12 +1472,12 @@ (:emitter (emit-x-form-inst segment 31 - (reg-tn-encoding rs) + (reg-tn-encoding rs) (reg-tn-encoding ra) (reg-tn-encoding rb) 444 0))) - + (define-instruction or. (segment ra rs rb) (:printer x-5 ((op 31) (xo 444) (rc 1)) '((:cond ((rs :same-as rb) 'mr.) @@ -1435,53 +1487,53 @@ (:unless (:same-as rs) "," rb))) (:delay 1) (:cost 1) - (:dependencies (reads rb) (reads rs) (writes ra)) + (:dependencies (reads rb) (reads rs) (writes ra) (writes :ccr)) (:emitter (emit-x-form-inst segment 31 - (reg-tn-encoding rs) + (reg-tn-encoding rs) (reg-tn-encoding ra) (reg-tn-encoding rb) 444 1))) - + (define-instruction-macro mr (ra rs) `(inst or ,ra ,rs ,rs)) - + (define-instruction-macro mr. (ra rs) `(inst or. ,ra ,rs ,rs)) - + (define-4-xo-instructions divwu 31 459 :cost 36) - + ; This is a 601-specific instruction class. (define-4-xo-instructions div 31 331 :cost 36) - + ; This is a 601-specific instruction. (define-instruction mtmq (segment rt) (:printer xfx ((op 31) (xo 467) (spr (ash 0 5))) '(:name :tab rt)) (:delay 1) (:dependencies (reads rt) (writes :xer)) (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 0 5) 467 0))) - + (define-instruction mtxer (segment rt) (:printer xfx ((op 31) (xo 467) (spr (ash 1 5))) '(:name :tab rt)) (:delay 1) (:dependencies (reads rt) (writes :xer)) (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 1 5) 467 0))) - + (define-instruction mtlr (segment rt) (:printer xfx ((op 31) (xo 467) (spr (ash 8 5))) '(:name :tab rt)) (:delay 1) (:dependencies (reads rt) (writes :lr)) (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 8 5) 467 0))) - + (define-instruction mtctr (segment rt) (:printer xfx ((op 31) (xo 467) (spr (ash 9 5))) '(:name :tab rt)) (:delay 1) (:dependencies (reads rt) (writes :ctr)) (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 9 5) 467 0))) - - + + (define-2-x-5-instructions nand 31 476) (define-4-xo-instructions divw 31 491 :cost 36) (define-instruction mcrxr (segment crf) @@ -1489,25 +1541,25 @@ (:delay 1) (:dependencies (reads :xer) (writes :ccr) (writes :xer)) (:emitter (emit-x-form-inst segment 31 (valid-cr-field-encoding crf) 0 0 512 0))) - - (define-instruction lswx (segment rs ra rb) + + (define-instruction lswx (segment rs ra rb) (:printer x ((op 31) (xo 533) (rc 0))) (:delay 1) :pinned - (:cost 8) + (:cost 8) (:emitter (emit-x-form-inst sb!assem:segment 31 (reg-tn-encoding rs) (reg-tn-encoding ra) (reg-tn-encoding rb) 533 0))) (define-x-instruction lwbrx 31 534) (define-x-20-instruction lfsx 31 535) (define-2-x-5-instructions srw 31 536) (define-x-20-instruction lfsux 31 567 :other-dependencies ((writes ra))) - - (define-instruction lswi (segment rt ra rb) + + (define-instruction lswi (segment rt ra rb) (:printer x-1 ((op 31) (xo 597) (rc 0))) :pinned (:delay 8) - (:cost 8) + (:cost 8) (:emitter (emit-x-form-inst sb!assem:segment 31 (reg-tn-encoding rt) (reg-tn-encoding ra) rb 597 0))) - + (define-instruction sync (segment) (:printer x-27 ((op 31) (xo 598))) (:delay 1) @@ -1515,16 +1567,16 @@ (:emitter (emit-x-form-inst segment 31 0 0 0 598 0))) (define-x-20-instruction lfdx 31 599) (define-x-20-instruction lfdux 31 631 :other-dependencies ((writes ra))) - (define-instruction stswx (segment rs ra rb) + (define-instruction stswx (segment rs ra rb) (:printer x-5 ((op 31) (xo 661))) :pinned - (:cost 8) + (:cost 8) (:delay 1) - (:emitter (emit-x-form-inst sb!assem:segment 31 - (reg-tn-encoding rs) - (reg-tn-encoding ra) - (reg-tn-encoding rb) - 661 + (:emitter (emit-x-form-inst sb!assem:segment 31 + (reg-tn-encoding rs) + (reg-tn-encoding ra) + (reg-tn-encoding rb) + 661 0))) (define-x-5-st-instruction stwbrx 31 662 nil) (define-x-23-st-instruction stfsx 31 663) @@ -1535,17 +1587,17 @@ (:delay 1) (:emitter (emit-x-form-inst segment 31 - (reg-tn-encoding rs) + (reg-tn-encoding rs) (reg-tn-encoding ra) nb 725 0))) - + (define-x-23-st-instruction stfdx 31 727) (define-x-23-st-instruction stfdux 31 759 :other-dependencies ((writes ra))) (define-x-instruction lhbrx 31 790) (define-2-x-5-instructions sraw 31 792) - + (define-instruction srawi (segment ra rs rb) (:printer x-9 ((op 31) (xo 824) (rc 0))) (:cost 1) @@ -1553,49 +1605,49 @@ (:dependencies (reads rs) (writes ra)) (:emitter (emit-x-form-inst segment 31 - (reg-tn-encoding rs) + (reg-tn-encoding rs) (reg-tn-encoding ra) rb 824 0))) - + (define-instruction srawi. (segment ra rs rb) (:printer x-9 ((op 31) (xo 824) (rc 1))) (:cost 1) (:delay 1) - (:dependencies (reads rs) (writes ra)) + (:dependencies (reads rs) (writes ra) (writes :ccr)) (:emitter (emit-x-form-inst segment 31 - (reg-tn-encoding rs) + (reg-tn-encoding rs) (reg-tn-encoding ra) rb 824 1))) - + (define-instruction eieio (segment) (:printer x-27 ((op 31) (xo 854))) :pinned (:delay 1) (:emitter (emit-x-form-inst segment 31 0 0 0 854 0))) - + (define-x-5-st-instruction sthbrx 31 918 nil) - + (define-2-x-10-instructions extsb 31 954) (define-2-x-10-instructions extsh 31 922) ; Whew. - + (define-instruction lwz (segment rt ra si) (:declare (type (or fixup (signed-byte 16)) si)) (:printer d ((op 32))) (:delay 2) (:cost 2) - (:dependencies (reads ra) (writes rt)) + (:dependencies (reads ra) (writes rt) (reads :memory)) (:emitter (when (typep si 'fixup) (note-fixup segment :l si) (setq si 0)) (emit-d-form-inst segment 32 (reg-tn-encoding rt) (reg-tn-encoding ra) si))) - + (define-d-instruction lwzu 33 :other-dependencies ((writes ra))) (define-d-instruction lbz 34) (define-d-instruction lbzu 35 :other-dependencies ((writes ra))) @@ -1619,7 +1671,7 @@ (define-d-frs-instruction stfsu 53 :other-dependencies ((writes ra))) (define-d-frs-instruction stfd 54) (define-d-frs-instruction stfdu 55 :other-dependencies ((writes ra))) - + (define-2-a-tab-instructions fdivs 59 18 :cost 17) (define-2-a-tab-instructions fsubs 59 20) (define-2-a-tab-instructions fadds 59 21) @@ -1631,23 +1683,23 @@ (define-instruction fcmpu (segment crfd fra frb) (:printer x-15 ((op 63) (xo 0))) - (:dependencies (reads fra) (reads frb) (reads :fpscr) + (:dependencies (reads fra) (reads frb) (reads :fpscr) (writes :fpscr) (writes :ccr)) (:cost 4) (:delay 4) - (:emitter (emit-x-form-inst segment - 63 + (:emitter (emit-x-form-inst segment + 63 (valid-cr-field-encoding crfd) - (fp-reg-tn-encoding fra) + (fp-reg-tn-encoding fra) (fp-reg-tn-encoding frb) 0 0))) - - + + (define-2-x-21-instructions frsp 63 12) (define-2-x-21-instructions fctiw 63 14) (define-2-x-21-instructions fctiwz 63 15) - + (define-2-a-tab-instructions fdiv 63 18 :cost 31) (define-2-a-tab-instructions fsub 63 20) (define-2-a-tab-instructions fadd 63 21) @@ -1656,35 +1708,35 @@ (define-2-a-instructions fmadd 63 29 :cost 5) (define-2-a-instructions fnmsub 63 30 :cost 5) (define-2-a-instructions fnmadd 63 31 :cost 5) - + (define-instruction fcmpo (segment crfd fra frb) (:printer x-15 ((op 63) (xo 32))) - (:dependencies (reads fra) (reads frb) (reads :fpscr) + (:dependencies (reads fra) (reads frb) (reads :fpscr) (writes :fpscr) (writes :ccr)) (:cost 4) (:delay 1) - (:emitter (emit-x-form-inst segment - 63 + (:emitter (emit-x-form-inst segment + 63 (valid-cr-field-encoding crfd) - (fp-reg-tn-encoding fra) + (fp-reg-tn-encoding fra) (fp-reg-tn-encoding frb) 32 0))) - + (define-2-x-21-instructions fneg 63 40) - + (define-2-x-21-instructions fmr 63 72) (define-2-x-21-instructions fnabs 63 136) (define-2-x-21-instructions fabs 63 264) - + (define-instruction mffs (segment frd) (:printer x-22 ((op 63) (xo 583) (rc 0))) (:delay 1) (:dependencies (reads :fpscr) (writes frd)) - (:emitter (emit-x-form-inst segment - 63 + (:emitter (emit-x-form-inst segment + 63 (fp-reg-tn-encoding frd) - 0 + 0 0 583 0))) @@ -1692,11 +1744,11 @@ (define-instruction mffs. (segment frd) (:printer x-22 ((op 63) (xo 583) (rc 1))) (:delay 1) - (:dependencies (reads :fpscr) (writes frd)) - (:emitter (emit-x-form-inst segment - 63 + (:dependencies (reads :fpscr) (writes frd) (writes :ccr)) + (:emitter (emit-x-form-inst segment + 63 (fp-reg-tn-encoding frd) - 0 + 0 0 583 1))) @@ -1720,7 +1772,7 @@ (define-instruction-macro subis (rt ra simm) `(inst addis ,rt ,ra (- ,simm))) - + (define-instruction-macro sub (rt rb ra) `(inst subf ,rt ,ra ,rb)) (define-instruction-macro sub. (rt rb ra) @@ -1733,13 +1785,13 @@ (define-instruction-macro subic (rt ra simm) `(inst addic ,rt ,ra (- ,simm))) - + (define-instruction-macro subic. (rt ra simm) `(inst addic. ,rt ,ra (- ,simm))) - - - + + + (define-instruction-macro subc (rt rb ra) `(inst subfc ,rt ,ra ,rb)) (define-instruction-macro subc. (rt rb ra) @@ -1748,68 +1800,86 @@ `(inst subfco ,rt ,ra ,rb)) (define-instruction-macro subco. (rt rb ra) `(inst subfco. ,rt ,ra ,rb)) - + (define-instruction-macro subi (rt ra simm) `(inst addi ,rt ,ra (- ,simm))) - + (define-instruction-macro li (rt val) `(inst addi ,rt zero-tn ,val)) - + (define-instruction-macro lis (rt val) `(inst addis ,rt zero-tn ,val)) - - + + (define-instruction-macro not (ra rs) `(inst nor ,ra ,rs ,rs)) - + (define-instruction-macro not. (ra rs) `(inst nor. ,ra ,rs ,rs)) - - - (!def-vm-support-routine emit-nop (segment) + + + (defun emit-nop (segment) (emit-word segment #x60000000)) - + (define-instruction-macro extlwi (ra rs n b) `(inst rlwinm ,ra ,rs ,b 0 (1- ,n))) - + (define-instruction-macro extlwi. (ra rs n b) `(inst rlwinm. ,ra ,rs ,b 0 (1- ,n))) - + + (define-instruction-macro extrwi (ra rs n b) + `(inst rlwinm ,ra ,rs (mod (+ ,b ,n) 32) (- 32 ,n) 31)) + + (define-instruction-macro extrwi. (ra rs n b) + `(inst rlwinm. ,ra ,rs (mod (+ ,b ,n) 32) (- 32 ,n) 31)) + (define-instruction-macro srwi (ra rs n) `(inst rlwinm ,ra ,rs (- 32 ,n) ,n 31)) - + (define-instruction-macro srwi. (ra rs n) `(inst rlwinm. ,ra ,rs (- 32 ,n) ,n 31)) - + + (define-instruction-macro clrlwi (ra rs n) + `(inst rlwinm ,ra ,rs 0 ,n 31)) + + (define-instruction-macro clrlwi. (ra rs n) + `(inst rlwinm. ,ra ,rs 0 ,n 31)) + (define-instruction-macro clrrwi (ra rs n) `(inst rlwinm ,ra ,rs 0 0 (- 31 ,n))) - + (define-instruction-macro clrrwi. (ra rs n) `(inst rlwinm. ,ra ,rs 0 0 (- 31 ,n))) - + (define-instruction-macro inslw (ra rs n b) `(inst rlwimi ,ra ,rs (- 32 ,b) ,b (+ ,b (1- ,n)))) - + (define-instruction-macro inslw. (ra rs n b) `(inst rlwimi. ,ra ,rs (- 32 ,b) ,b (+ ,b (1- ,n)))) - + (define-instruction-macro rotlw (ra rs rb) `(inst rlwnm ,ra ,rs ,rb 0 31)) - + (define-instruction-macro rotlw. (ra rs rb) `(inst rlwnm. ,ra ,rs ,rb 0 31)) - + + (define-instruction-macro rotlwi (ra rs n) + `(inst rlwinm ,ra ,rs ,n 0 31)) + + (define-instruction-macro rotrwi (ra rs n) + `(inst rlwinm ,ra ,rs (- 32 ,n) 0 31)) + (define-instruction-macro slwi (ra rs n) `(inst rlwinm ,ra ,rs ,n 0 (- 31 ,n))) (define-instruction-macro slwi. (ra rs n) `(inst rlwinm. ,ra ,rs ,n 0 (- 31 ,n)))) - + #| -(macrolet +(macrolet ((define-conditional-branches (name bo-name) (let* ((bo-enc (valid-bo-encoding bo-name))) `(progn @@ -1831,7 +1901,7 @@ (define-conditional-branches bf :bo-f)) |# -(macrolet +(macrolet ((define-positive-conditional-branches (name cr-bit-name) `(progn (define-instruction-macro ,name (crf &optional (target nil target-p)) @@ -1862,7 +1932,7 @@ (define-positive-conditional-branches bun :so)) -(macrolet +(macrolet ((define-negative-conditional-branches (name cr-bit-name) `(progn (define-instruction-macro ,name (crf &optional (target nil target-p)) @@ -1912,20 +1982,13 @@ (define-instruction-macro bula (target) `(inst bcla :bo-u 0 ,target)) - +|# (define-instruction-macro blrl () `(inst bclrl :bo-u 0)) - - -|# - - - - -;;; Some more macros +;;; Some more macros (defun %lr (reg value) (etypecase value @@ -1937,10 +2000,14 @@ (let* ((high-half (ldb (byte 16 16) value)) (low-half (ldb (byte 16 0) value))) (declare (type (unsigned-byte 16) high-half low-half)) - (cond ((if (logbitp 15 low-half) (= high-half #xffff) (zerop high-half)) + (cond ((and (logbitp 15 low-half) (= high-half #xffff)) + (inst li reg (dpb low-half (byte 16 0) -1))) + ((and (not (logbitp 15 low-half)) (zerop high-half)) (inst li reg low-half)) (t - (inst lis reg high-half) + (inst lis reg (if (logbitp 15 high-half) + (dpb high-half (byte 16 0) -1) + high-half)) (unless (zerop low-half) (inst ori reg reg low-half)))))) (fixup @@ -1949,7 +2016,7 @@ (define-instruction-macro lr (reg value) `(%lr ,reg ,value)) - + ;;;; Instructions for dumping data and header objects. @@ -1983,9 +2050,9 @@ segment 4 #'(lambda (segment posn) (emit-word segment - (logior type - (ash (+ posn (component-header-length)) - (- n-widetag-bits word-shift))))))) + (logior type + (ash (+ posn (component-header-length)) + (- n-widetag-bits word-shift))))))) (define-instruction simple-fun-header-word (segment) :pinned @@ -2007,24 +2074,22 @@ segment 12 3 #'(lambda (segment posn delta-if-after) (let ((delta (funcall calc label posn delta-if-after))) - (when (<= (- (ash 1 15)) delta (1- (ash 1 15))) - (emit-back-patch segment 4 - #'(lambda (segment posn) - (assemble (segment vop) - (inst addi dst src - (funcall calc label posn 0))))) - t))) + (when (<= (- (ash 1 15)) delta (1- (ash 1 15))) + (emit-back-patch segment 4 + #'(lambda (segment posn) + (assemble (segment vop) + (inst addi dst src + (funcall calc label posn 0))))) + t))) #'(lambda (segment posn) (let ((delta (funcall calc label posn 0))) - (assemble (segment vop) - (inst lis temp (ldb (byte 16 16) delta)) - (inst ori temp temp (ldb (byte 16 0) delta)) - (inst add dst src temp)))))) - -;; this function is misnamed. should be compute-code-from-lip, -;; if the use in xep-allocate-frame is typical -;; (someone says code = fn - header - label-offset + other-pointer-tag) -(define-instruction compute-code-from-fn (segment dst src label temp) + (assemble (segment vop) + (inst lis temp (ldb (byte 16 16) delta)) + (inst ori temp temp (ldb (byte 16 0) delta)) + (inst add dst src temp)))))) + +;; code = lip - header - label-offset + other-pointer-tag +(define-instruction compute-code-from-lip (segment dst src label temp) (:declare (type tn dst src temp) (type label label)) (:attributes variable-length) (:dependencies (reads src) (writes dst) (writes temp)) @@ -2032,13 +2097,14 @@ (:vop-var vop) (:emitter (emit-compute-inst segment vop dst src label temp - #'(lambda (label posn delta-if-after) - (- other-pointer-lowtag - ;;function-pointer-type - (label-position label posn delta-if-after) - (component-header-length)))))) + #'(lambda (label posn delta-if-after) + (- other-pointer-lowtag + ;;function-pointer-type + (label-position label posn delta-if-after) + (component-header-length)))))) ;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag +;; = lra - (header + label-offset) (define-instruction compute-code-from-lra (segment dst src label temp) (:declare (type tn dst src temp) (type label label)) (:attributes variable-length) @@ -2047,11 +2113,12 @@ (:vop-var vop) (:emitter (emit-compute-inst segment vop dst src label temp - #'(lambda (label posn delta-if-after) - (- (+ (label-position label posn delta-if-after) - (component-header-length))))))) + #'(lambda (label posn delta-if-after) + (- (+ (label-position label posn delta-if-after) + (component-header-length))))))) ;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag +;; = code + header + label-offset (define-instruction compute-lra-from-code (segment dst src label temp) (:declare (type tn dst src temp) (type label label)) (:attributes variable-length) @@ -2060,6 +2127,6 @@ (:vop-var vop) (:emitter (emit-compute-inst segment vop dst src label temp - #'(lambda (label posn delta-if-after) - (+ (label-position label posn delta-if-after) - (component-header-length)))))) + #'(lambda (label posn delta-if-after) + (+ (label-position label posn delta-if-after) + (component-header-length))))))