X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fhppa%2Finsts.lisp;h=24b3fc862164c93ce22eb893c994c3a10b122212;hb=711f75f20284c41f53485fda882fc7cc9e8e930f;hp=74d96c7a5290dbe34bed0738de0454c410e6417a;hpb=0d74ed478e7f3af5d3292153726373763631aa8e;p=sbcl.git diff --git a/src/compiler/hppa/insts.lisp b/src/compiler/hppa/insts.lisp index 74d96c7..24b3fc8 100644 --- a/src/compiler/hppa/insts.lisp +++ b/src/compiler/hppa/insts.lisp @@ -34,7 +34,9 @@ (fp-single-zero (values 0 nil)) (single-reg (values (tn-offset tn) nil)) (fp-double-zero (values 0 t)) - (double-reg (values (tn-offset tn) t)))) + (double-reg (values (tn-offset tn) t)) + (complex-single-reg (values (tn-offset tn) nil)) + (complex-double-reg (values (tn-offset tn) t)))) (defconstant-eqx compare-conditions '(:never := :< :<= :<< :<<= :sv :od :tr :<> :>= :> :>>= :>> :nsv :ev) @@ -123,8 +125,9 @@ ;;;; Initial disassembler setup. -;FIX-lav: is this still used, if so , why use package prefix -;(setf sb!disassem:*disassem-inst-alignment-bytes* 4) + +;;; FIXME-lav: is this still used, if so , why use package prefix +;;; (setf sb!disassem:*disassem-inst-alignment-bytes* 4) (defvar *disassem-use-lisp-reg-names* t) @@ -135,7 +138,7 @@ ; immediate or anything else. ; this routine will return an location-number ; this number must be less than *assem-max-locations* -(!def-vm-support-routine location-number (loc) +(defun location-number (loc) (etypecase loc (null) (number) @@ -780,7 +783,7 @@ (emit-back-patch segment 4 (lambda (segment posn) (let ((disp (label-relative-displacement target posn))) - (aver (<= (- (ash 1 16)) disp (1- (ash 1 16)))) + (aver (typep disp '(signed-byte 17))) (multiple-value-bind (w1 w2 w) (decompose-branch-disp segment disp) @@ -860,15 +863,12 @@ (emit-back-patch segment 4 (lambda (segment posn) (let ((disp (label-relative-displacement target posn))) - (when (not (<= (- (ash 1 11)) disp (1- (ash 1 11)))) - (format t "AVER fail: disp = ~s~%" disp) - (format t "target = ~s~%" target) - (format t "posn = ~s~%" posn) - ) - (aver (<= (- (ash 1 11)) disp (1- (ash 1 11)))) + ; emit-conditional-branch is used by instruction emitters: MOVB, COMB, ADDB and BB + ; which assembles an immediate of total 12 bits (including sign bit). + (aver (typep disp '(signed-byte 12))) (let ((w1 (logior (ash (ldb (byte 10 0) disp) 1) (ldb (byte 1 10) disp))) - (w (ldb (byte 1 11) disp))) + (w (ldb (byte 1 11) disp))) ; take out the sign bit (emit-branch segment opcode r2 r1 cond w1 (if nullify 1 0) w)))))) (defun im5-encoding (value) @@ -983,8 +983,7 @@ (:printer r3-inst ((op ,opcode) (c nil :type ',(symbolicate cond-kind "-CONDITION")))) - ;FIX-lav, change opcode test to name test - ,@(when (= opcode #x12) + ,@(when (eq name 'or) `((:printer r3-inst ((op ,opcode) (r2 0) (c nil :type ',(symbolicate cond-kind "-CONDITION"))) @@ -1529,9 +1528,9 @@ (lambda (segment posn) (let ((disp (label-relative-displacement target posn))) (assemble (segment vop) - (cond ((<= (- (ash 1 11)) disp (1- (ash 1 11))) + (cond ((typep disp '(signed-byte 12)) (inst comb (maybe-negate-cond cond not-p) r1 r2 target) - (inst nop)) ;FIX-lav, cant nullify when backward branch + (inst nop)) ; FIXME-lav, cant nullify when backward branch (t (inst comclr r1 r2 zero-tn (maybe-negate-cond cond (not not-p))) @@ -1551,7 +1550,7 @@ (lambda (segment posn delta-if-after) (let ((disp (label-relative-displacement target posn delta-if-after))) (when (and (<= 0 disp (1- (ash 1 11))) - (<= (- (ash 1 4)) imm (1- (ash 1 4)))) + (typep imm '(signed-byte 5))) (assemble (segment vop) (inst comib (maybe-negate-cond cond not-p) imm reg target :nullify t)) @@ -1559,8 +1558,8 @@ (lambda (segment posn) (let ((disp (label-relative-displacement target posn))) (assemble (segment vop) - (cond ((and (<= (- (ash 1 11)) disp (1- (ash 1 11))) - (<= (- (ash 1 4)) imm (1- (ash 1 4)))) + (cond ((and (typep disp '(signed-byte 12)) + (typep imm '(signed-byte 5))) (inst comib (maybe-negate-cond cond not-p) imm reg target) (inst nop)) (t @@ -1599,30 +1598,30 @@ (emit-chooser ;; We emit either 12 or 4 bytes, so we maintain 3 byte alignments. segment 12 3 - ; This is the best-case that emits one instruction ( 4 bytes ) + ;; This is the best-case that emits one instruction ( 4 bytes ) (lambda (segment posn delta-if-after) (let ((delta (funcall calc label posn delta-if-after))) - ; WHEN, Why not AVER ? - (when (<= (- (ash 1 10)) delta (1- (ash 1 10))) + ;; WHEN, Why not AVER ? + (when (typep delta '(signed-byte 11)) (emit-back-patch segment 4 (lambda (segment posn) (assemble (segment vop) (inst addi (funcall calc label posn 0) src dst)))) t))) - ; This is the worst-case that emits three instruction ( 12 bytes ) + ;; This is the worst-case that emits three instruction ( 12 bytes ) (lambda (segment posn) (let ((delta (funcall calc label posn 0))) - ; FIX-lav: why do we hit below check ? - ;(when (<= (- (ash 1 10)) delta (1- (ash 1 10))) - ; (error "emit-compute-inst selected worst-case, but is shrinkable, delta is ~s" delta)) + ;; FIXME-lav: why do we hit below check ? + ;; (when (<= (- (ash 1 10)) delta (1- (ash 1 10))) + ;; (error "emit-compute-inst selected worst-case, but is shrinkable, delta is ~s" delta)) ;; Note: if we used addil/ldo to do this in 2 instructions then the ;; intermediate value would be tagged but pointing into space. ;; Does above note mean that the intermediate value would be ;; a bogus pointer that would be GCed wrongly ? ;; Also what I can see addil would also overwrite NFP (r1) ??? (assemble (segment vop) - ; Three instructions (4 * 3) this is the reason for 12 bytes + ;; Three instructions (4 * 3) this is the reason for 12 bytes (inst ldil delta temp) (inst ldo (ldb (byte 11 0) delta) temp temp :unsigned t) (inst add src temp dst))))))