X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fppc%2Finsts.lisp;h=bac1efae84e08b74e18af8ed6860d9e7e94d709b;hb=774bf2a2d0442bd8d854ae83db86a65bd9914f26;hp=aff233ff5d8c0cea871cd18ed4e6e341d7f0e221;hpb=ed3bd9c7d61a3c1bf8ad81d82a671359117bd235;p=sbcl.git diff --git a/src/compiler/ppc/insts.lisp b/src/compiler/ppc/insts.lisp index aff233f..bac1efa 100644 --- a/src/compiler/ppc/insts.lisp +++ b/src/compiler/ppc/insts.lisp @@ -1,14 +1,24 @@ -;;; -;;; Written by William Lott -;;; +;;;; the instruction set definition for the PPC -(in-package "SB!VM") - -;(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. @@ -64,16 +74,36 @@ (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 @@ -202,10 +232,10 @@ (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-from-system-area sap (* n-byte-bits (1+ offset)) + vector (* n-word-bits + vector-data-offset) + (* length n-byte-bits)) (collect ((sc-offsets) (lengths)) (lengths 1) ; the length byte @@ -251,12 +281,14 @@ aa-bit lk-bit))) t))) #'(lambda (segment posn) + (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))))) )))) @@ -593,23 +625,23 @@ (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 + (#.object-not-instance-trap (nt "Object not instance trap")) ))) @@ -697,7 +729,7 @@ (: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 @@ -747,7 +779,7 @@ (:delay ,cost) (:cost ,cost) (:dependencies (reads ra) (reads rb) (reads rs) ,@other-reads - ,@other-writes) + (writes :memory :partially t) ,@other-writes) (:emitter (emit-x-form-inst segment ,op (reg-tn-encoding rs) @@ -763,7 +795,7 @@ (:delay ,cost) (:cost ,cost) (:dependencies (reads ra) (reads rb) (reads frs) ,@other-reads - ,@other-writes) + (writes :memory :partially t) ,@other-writes) (:emitter (emit-x-form-inst segment ,op (fp-reg-tn-encoding frs) @@ -827,7 +859,9 @@ (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) @@ -860,7 +894,7 @@ (: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))))) @@ -872,7 +906,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))))) @@ -950,7 +984,7 @@ (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) @@ -962,7 +996,7 @@ (fp-reg-tn-encoding frt) (fp-reg-tn-encoding fra) 0 - (fp-reg-tn-encoding frc) + (fp-reg-tn-encoding frb) ,xo ,rc))))) @@ -997,7 +1031,7 @@ (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))) @@ -1046,7 +1080,8 @@ (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))) @@ -1054,7 +1089,8 @@ (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))) @@ -1062,7 +1098,8 @@ (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))) @@ -1070,19 +1107,21 @@ (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)) '(:name :tab bd)) - (:delay 1) + (:attributes branch) + (:delay 0) (:emitter (emit-conditional-branch segment #.(valid-bo-encoding :bo-u) 0 target nil nil))) @@ -1090,19 +1129,22 @@ (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) + (:attributes branch) + (:delay 0) (:emitter (unless target-p (setq target cr-name cr-name cr-field-name cr-field-name :cr0)) @@ -1117,19 +1159,22 @@ (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) @@ -1139,13 +1184,15 @@ (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) @@ -1154,21 +1201,24 @@ (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) @@ -1191,28 +1241,32 @@ (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))) @@ -1292,7 +1346,8 @@ (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))) @@ -1435,7 +1490,7 @@ (: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 @@ -1563,7 +1618,7 @@ (: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) @@ -1589,7 +1644,7 @@ (: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) @@ -1692,7 +1747,7 @@ (define-instruction mffs. (segment frd) (:printer x-22 ((op 63) (xo 583) (rc 1))) (:delay 1) - (:dependencies (reads :fpscr) (writes frd)) + (:dependencies (reads :fpscr) (writes frd) (writes :ccr)) (:emitter (emit-x-form-inst segment 63 (fp-reg-tn-encoding frd) @@ -1799,6 +1854,12 @@ (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))) @@ -1937,10 +1998,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)) - (inst li reg low-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