(in-package "SB!VM")
-;(def-assembler-params
-; :scheduler-p nil ; t when we trust the scheduler not to "fill delay slots"
-; :max-locations 70)
+;;; 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))
\f
;;;; Constants, types, conversion functions, some disassembler stuff.
(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
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)))))
))))
(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"))
)))
(: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
(: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)
(: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)
(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)
(: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)))))
(: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)))))
(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)
(fp-reg-tn-encoding frt)
(fp-reg-tn-encoding fra)
0
- (fp-reg-tn-encoding frc)
+ (fp-reg-tn-encoding frb)
,xo
,rc)))))
(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-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))
'(: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)
+ (:attributes branch)
+ (:delay 0)
(:emitter
(unless target-p
(setq target cr-name cr-name cr-field-name cr-field-name :cr0))
(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)
(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)
(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)
(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 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)))
(: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
(: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)
(: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)
(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)
(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
projects / sbcl.git / blobdiff