From: Daniel Barlow Date: Mon, 18 Mar 2002 17:56:09 +0000 (+0000) Subject: Merge PPC port X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=cab2c71bb1bb8a575d9eebdae335e731daa64183;p=sbcl.git Merge PPC port ... new directories src/compiler/ppc, src/assembly/ppc ... other new files ... new clause in genesis for PPC fixups ... new files in runtime, PPC conditionals added in other .[ch] files Small Makefile cleanups in runtime ... actually _use_ the dependency information ... regenerate depends on source changes We don't actually use sigreturn() in _any_ present port: conditionals changed to make this obvious --- diff --git a/src/assembly/ppc/alloc.lisp b/src/assembly/ppc/alloc.lisp new file mode 100644 index 0000000..fb05a59 --- /dev/null +++ b/src/assembly/ppc/alloc.lisp @@ -0,0 +1,3 @@ +(in-package "SB!VM") + +;;; But we do everything inline now that we have a better pseudo-atomic. diff --git a/src/assembly/ppc/arith.lisp b/src/assembly/ppc/arith.lisp new file mode 100644 index 0000000..8cb8c42 --- /dev/null +++ b/src/assembly/ppc/arith.lisp @@ -0,0 +1,432 @@ +(in-package "SB!VM") + + + +;;;; Addition and subtraction. + +;;; static-fun-offset returns the address of the raw_addr slot of +;;; a static function's fdefn. + +;;; Note that there is only one use of static-fun-offset outside this +;;; file (in genesis.lisp) + +(define-assembly-routine + (generic-+ + (:cost 10) + (:return-style :full-call) + (:translate +) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res (descriptor-reg any-reg) a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp temp2 non-descriptor-reg nl1-offset) + (:temp flag non-descriptor-reg nl3-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp lip interior-reg lip-offset) + (:temp ocfp any-reg ocfp-offset)) + + ; Clear the damned "sticky overflow" bit in :cr0 and :xer + (inst mcrxr :cr0) + (inst or temp x y) + (inst andi. temp temp 3) + (inst bne DO-STATIC-FUN) + (inst addo. temp x y) + (inst bns done) + + (inst srawi temp x 2) + (inst srawi temp2 y 2) + (inst add temp2 temp2 temp) + (with-fixed-allocation (res flag temp bignum-widetag (1+ bignum-digits-offset)) + (storew temp2 res bignum-digits-offset other-pointer-lowtag)) + (lisp-return lra lip :offset 2) + + DO-STATIC-FUN + (inst lwz lip null-tn (static-fun-offset 'two-arg-+) ) + (inst li nargs (fixnumize 2)) + (inst mr ocfp cfp-tn) + (inst mr cfp-tn csp-tn) + (inst j lip 0) + + DONE + (move res temp)) + + +(define-assembly-routine + (generic-- + (:cost 10) + (:return-style :full-call) + (:translate -) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res (descriptor-reg any-reg) a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp temp2 non-descriptor-reg nl1-offset) + (:temp flag non-descriptor-reg nl3-offset) + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + + ; Clear the damned "sticky overflow" bit in :cr0 + (inst mcrxr :cr0) + + (inst or temp x y) + (inst andi. temp temp 3) + (inst bne DO-STATIC-FUN) + + (inst subo. temp x y) + (inst bns done) + + (inst srawi temp x 2) + (inst srawi temp2 y 2) + (inst sub temp2 temp temp2) + (with-fixed-allocation (res flag temp bignum-widetag (1+ bignum-digits-offset)) + (storew temp2 res bignum-digits-offset other-pointer-lowtag)) + (lisp-return lra lip :offset 2) + + DO-STATIC-FUN + (inst lwz lip null-tn (static-fun-offset 'two-arg--)) + (inst li nargs (fixnumize 2)) + (inst mr ocfp cfp-tn) + (inst mr cfp-tn csp-tn) + (inst j lip 0) + + DONE + (move res temp)) + + + +;;;; Multiplication + + +(define-assembly-routine + (generic-* + (:cost 50) + (:return-style :full-call) + (:translate *) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res (descriptor-reg any-reg) a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp lo non-descriptor-reg nl1-offset) + (:temp hi non-descriptor-reg nl2-offset) + (:temp pa-flag non-descriptor-reg nl3-offset) + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + + ;; If either arg is not a fixnum, call the static function. But first ... + (inst mcrxr :cr0) + + (inst or temp x y) + (inst andi. temp temp 3) + ;; Remove the tag from both args, so I don't get so confused. + (inst srawi temp x 2) + (inst srawi nargs y 2) + (inst bne DO-STATIC-FUN) + + + (inst mullwo. lo nargs temp) + (inst srawi hi lo 31) ; hi = 32 copies of lo's sign bit + (inst bns ONE-WORD-ANSWER) + (inst mulhw hi nargs temp) + (inst b CONS-BIGNUM) + + ONE-WORD-ANSWER ; We know that all of the overflow bits are clear. + (inst addo temp lo lo) + (inst addo. res temp temp) + (inst bns GO-HOME) + + CONS-BIGNUM + ;; Allocate a BIGNUM for the result. + (pseudo-atomic (pa-flag :extra (pad-data-block (1+ bignum-digits-offset))) + (let ((one-word (gen-label))) + (inst ori res alloc-tn other-pointer-lowtag) + ;; We start out assuming that we need one word. Is that correct? + (inst srawi temp lo 31) + (inst xor. temp temp hi) + (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag)) + (inst beq one-word) + ;; Nope, we need two, so allocate the additional space. + (inst addi alloc-tn alloc-tn (- (pad-data-block (+ 2 bignum-digits-offset)) + (pad-data-block (1+ bignum-digits-offset)))) + (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag)) + (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag) + (emit-label one-word) + (storew temp res 0 other-pointer-lowtag) + (storew lo res bignum-digits-offset other-pointer-lowtag))) + ;; Out of here + GO-HOME + (lisp-return lra lip :offset 2) + + DO-STATIC-FUN + (inst lwz lip null-tn (static-fun-offset 'two-arg-*)) + (inst li nargs (fixnumize 2)) + (inst mr ocfp cfp-tn) + (inst mr cfp-tn csp-tn) + (inst j lip 0) + + LOW-FITS-IN-FIXNUM + (move res lo)) + +(macrolet + ((frob (name note cost type sc) + `(define-assembly-routine (,name + (:note ,note) + (:cost ,cost) + (:translate *) + (:policy :fast-safe) + (:arg-types ,type ,type) + (:result-types ,type)) + ((:arg x ,sc nl0-offset) + (:arg y ,sc nl1-offset) + (:res res ,sc nl0-offset)) + ,@(when (eq type 'tagged-num) + `((inst srawi x x 2))) + (inst mullw res x y)))) + (frob unsigned-* "unsigned *" 40 unsigned-num unsigned-reg) + (frob signed-* "unsigned *" 41 signed-num signed-reg) + (frob fixnum-* "fixnum *" 30 tagged-num any-reg)) + + + +;;;; Division. + + +(define-assembly-routine (positive-fixnum-truncate + (:note "unsigned fixnum truncate") + (:cost 45) + (:translate truncate) + (:policy :fast-safe) + (:arg-types positive-fixnum positive-fixnum) + (:result-types positive-fixnum positive-fixnum)) + ((:arg dividend any-reg nl0-offset) + (:arg divisor any-reg nl1-offset) + + (:res quo any-reg nl2-offset) + (:res rem any-reg nl0-offset)) + (assert (location= rem dividend)) + (let ((error (generate-error-code nil division-by-zero-error + dividend divisor))) + (inst cmpwi divisor 0) + (inst beq error)) + (inst divwu quo dividend divisor) + (inst mullw divisor quo divisor) + (inst sub rem dividend divisor) + (inst slwi quo quo 2)) + + + +(define-assembly-routine (fixnum-truncate + (:note "fixnum truncate") + (:cost 50) + (:policy :fast-safe) + (:translate truncate) + (:arg-types tagged-num tagged-num) + (:result-types tagged-num tagged-num)) + ((:arg dividend any-reg nl0-offset) + (:arg divisor any-reg nl1-offset) + + (:res quo any-reg nl2-offset) + (:res rem any-reg nl0-offset)) + + (assert (location= rem dividend)) + (let ((error (generate-error-code nil division-by-zero-error + dividend divisor))) + (inst cmpwi divisor 0) + (inst beq error)) + + (inst divw quo dividend divisor) + (inst mullw divisor quo divisor) + (inst subf rem divisor dividend) + (inst slwi quo quo 2)) + + +(define-assembly-routine (signed-truncate + (:note "(signed-byte 32) truncate") + (:cost 60) + (:policy :fast-safe) + (:translate truncate) + (:arg-types signed-num signed-num) + (:result-types signed-num signed-num)) + + ((:arg dividend signed-reg nl0-offset) + (:arg divisor signed-reg nl1-offset) + + (:res quo signed-reg nl2-offset) + (:res rem signed-reg nl0-offset)) + + (let ((error (generate-error-code nil division-by-zero-error + dividend divisor))) + (inst cmpwi divisor 0) + (inst beq error)) + + (inst divw quo dividend divisor) + (inst mullw divisor quo divisor) + (inst subf rem divisor dividend)) + + +;;;; Comparison + +(macrolet + ((define-cond-assem-rtn (name translate static-fn cmp) + `(define-assembly-routine + (,name + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate ,translate) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp lip interior-reg lip-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + + (inst or nargs x y) + (inst andi. nargs nargs 3) + (inst cmpw :cr1 x y) + (inst beq DO-COMPARE) + + DO-STATIC-FN + (inst lwz lip null-tn (static-fun-offset ',static-fn)) + (inst li nargs (fixnumize 2)) + (inst mr ocfp cfp-tn) + (inst mr cfp-tn csp-tn) + (inst j lip 0) + + DO-COMPARE + (load-symbol res t) + (inst b? :cr1 ,cmp done) + (inst mr res null-tn) + DONE))) + + (define-cond-assem-rtn generic-< < two-arg-< :lt) + (define-cond-assem-rtn generic-<= <= two-arg-<= :le) + (define-cond-assem-rtn generic-> > two-arg-> :gt) + (define-cond-assem-rtn generic->= >= two-arg->= :ge)) + + +(define-assembly-routine (generic-eql + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate eql) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp lra descriptor-reg lra-offset) + (:temp lip interior-reg lip-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst cmpw :cr1 x y) + (inst andi. nargs x 3) + (inst beq :cr1 RETURN-T) + (inst beq RETURN-NIL) ; x was fixnum, not eq y + (inst andi. nargs y 3) + (inst bne DO-STATIC-FN) + + RETURN-NIL + (inst mr res null-tn) + (lisp-return lra lip :offset 2) + + DO-STATIC-FN + (inst lwz lip null-tn (static-fun-offset 'eql)) + (inst li nargs (fixnumize 2)) + (inst mr ocfp cfp-tn) + (inst mr cfp-tn csp-tn) + (inst j lip 0) + + RETURN-T + (load-symbol res t)) + +(define-assembly-routine + (generic-= + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate =) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + + (inst or nargs x y) + (inst andi. nargs nargs 3) + (inst cmpw :cr1 x y) + (inst bne DO-STATIC-FN) + (inst beq :cr1 RETURN-T) + + (inst mr res null-tn) + (lisp-return lra lip :offset 2) + + DO-STATIC-FN + (inst lwz lip null-tn (static-fun-offset 'two-arg-=)) + (inst li nargs (fixnumize 2)) + (inst mr ocfp cfp-tn) + (inst mr cfp-tn csp-tn) + (inst j lip 0) + + RETURN-T + (load-symbol res t)) + +(define-assembly-routine (generic-/= + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate /=) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp lra descriptor-reg lra-offset) + (:temp lip interior-reg lip-offset) + + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst or nargs x y) + (inst andi. nargs nargs 3) + (inst cmpw :cr1 x y) + (inst bne DO-STATIC-FN) + (inst beq :cr1 RETURN-NIL) + + (load-symbol res t) + (lisp-return lra lip :offset 2) + + DO-STATIC-FN + (inst lwz lip null-tn (static-fun-offset 'two-arg-=)) + (inst li nargs (fixnumize 2)) + (inst mr ocfp cfp-tn) + (inst j lip 0) + (inst mr cfp-tn csp-tn) + + RETURN-NIL + (inst mr res null-tn)) diff --git a/src/assembly/ppc/array.lisp b/src/assembly/ppc/array.lisp new file mode 100644 index 0000000..a584f5c --- /dev/null +++ b/src/assembly/ppc/array.lisp @@ -0,0 +1,97 @@ +(in-package "SB!VM") + + +(define-assembly-routine (allocate-vector + (:policy :fast-safe) + (:translate allocate-vector) + (:arg-types positive-fixnum + positive-fixnum + positive-fixnum)) + ((:arg type any-reg a0-offset) + (:arg length any-reg a1-offset) + (:arg words any-reg a2-offset) + (:res result descriptor-reg a0-offset) + + (:temp ndescr non-descriptor-reg nl0-offset) + (:temp pa-flag non-descriptor-reg nl3-offset) + (:temp vector descriptor-reg a3-offset)) + (pseudo-atomic (pa-flag) + (inst ori vector alloc-tn sb!vm:other-pointer-lowtag) + (inst addi ndescr words (* (1+ sb!vm:vector-data-offset) sb!vm:n-word-bytes)) + (inst clrrwi ndescr ndescr n-lowtag-bits) + (inst add alloc-tn alloc-tn ndescr) + (inst srwi ndescr type sb!vm:word-shift) + (storew ndescr vector 0 sb!vm:other-pointer-lowtag) + (storew length vector sb!vm:vector-length-slot sb!vm:other-pointer-lowtag)) + (move result vector)) + + + +;;;; Hash primitives + +#+sb-assembling +(defparameter sxhash-simple-substring-entry (gen-label)) + +(define-assembly-routine (sxhash-simple-string + (:translate %sxhash-simple-string) + (:policy :fast-safe) + (:result-types positive-fixnum)) + ((:arg string descriptor-reg a0-offset) + (:res result any-reg a0-offset) + + (:temp length any-reg a1-offset) + (:temp accum non-descriptor-reg nl0-offset) + (:temp data non-descriptor-reg nl1-offset) + (:temp temp non-descriptor-reg nl2-offset) + (:temp offset non-descriptor-reg nl3-offset)) + + (declare (ignore result accum data temp offset)) + + (loadw length string sb!vm:vector-length-slot sb!vm:other-pointer-lowtag) + (inst b sxhash-simple-substring-entry)) + + +(define-assembly-routine (sxhash-simple-substring + (:translate %sxhash-simple-substring) + (:policy :fast-safe) + (:arg-types * positive-fixnum) + (:result-types positive-fixnum)) + ((:arg string descriptor-reg a0-offset) + (:arg length any-reg a1-offset) + (:res result any-reg a0-offset) + + (:temp accum non-descriptor-reg nl0-offset) + (:temp data non-descriptor-reg nl1-offset) + (:temp temp non-descriptor-reg nl2-offset) + (:temp offset non-descriptor-reg nl3-offset)) + (emit-label sxhash-simple-substring-entry) + + (inst li offset (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)) + (move accum zero-tn) + (inst b test) + + LOOP + + (inst xor accum accum data) + (inst slwi temp accum 27) + (inst srwi accum accum 5) + (inst or accum accum temp) + (inst addi offset offset 4) + + TEST + + (inst subic. length length (fixnumize 4)) + (inst lwzx data string offset) + (inst bge loop) + + (inst addic. length length (fixnumize 4)) + (inst neg length length) + (inst beq done) + (inst slwi length length 1) + (inst srw data data length) + (inst xor accum accum data) + + DONE + + (inst slwi result accum 5) + (inst srwi result result 3)) diff --git a/src/assembly/ppc/assem-rtns.lisp b/src/assembly/ppc/assem-rtns.lisp new file mode 100644 index 0000000..b84f882 --- /dev/null +++ b/src/assembly/ppc/assem-rtns.lisp @@ -0,0 +1,210 @@ +(in-package "SB!VM") + + +;;;; Return-multiple with other than one value + +#+sb-assembling ;; we don't want a vop for this one. +(define-assembly-routine + (return-multiple + (:return-style :none)) + + ;; These four are really arguments. + ((:temp nvals any-reg nargs-offset) + (:temp vals any-reg nl0-offset) + (:temp ocfp any-reg nl1-offset) + (:temp lra descriptor-reg lra-offset) + + ;; These are just needed to facilitate the transfer + (:temp lip interior-reg lip-offset) + (:temp count any-reg nl2-offset) + (:temp src any-reg nl3-offset) + (:temp dst any-reg cfunc-offset) + (:temp temp descriptor-reg l0-offset) + + + ;; These are needed so we can get at the register args. + (:temp a0 descriptor-reg a0-offset) + (:temp a1 descriptor-reg a1-offset) + (:temp a2 descriptor-reg a2-offset) + (:temp a3 descriptor-reg a3-offset)) + + ;; Note, because of the way the return-multiple vop is written, we can + ;; assume that we are never called with nvals == 1 and that a0 has already + ;; been loaded. + (inst cmpwi nvals 0) + (inst ble default-a0-and-on) + (inst cmpwi nvals (fixnumize 2)) + (inst lwz a1 vals (* 1 n-word-bytes)) + (inst ble default-a2-and-on) + (inst cmpwi nvals (fixnumize 3)) + (inst lwz a2 vals (* 2 n-word-bytes)) + (inst ble default-a3-and-on) + (inst cmpwi nvals (fixnumize 4)) + (inst lwz a3 vals (* 3 n-word-bytes)) + (inst ble done) + + ;; Copy the remaining args to the top of the stack. + (inst addi src vals (* 4 n-word-bytes)) + (inst addi dst cfp-tn (* 4 n-word-bytes)) + (inst addic. count nvals (- (fixnumize 4))) + + LOOP + (inst subic. count count (fixnumize 1)) + (inst lwz temp src 0) + (inst addi src src n-word-bytes) + (inst stw temp dst 0) + (inst addi dst dst n-word-bytes) + (inst bge loop) + + (inst b done) + + DEFAULT-A0-AND-ON + (inst mr a0 null-tn) + (inst mr a1 null-tn) + DEFAULT-A2-AND-ON + (inst mr a2 null-tn) + DEFAULT-A3-AND-ON + (inst mr a3 null-tn) + DONE + + ;; Clear the stack. + (move ocfp-tn cfp-tn) + (move cfp-tn ocfp) + (inst add csp-tn ocfp-tn nvals) + + ;; Return. + (lisp-return lra lip)) + + + +;;;; tail-call-variable. + +#+sb-assembling ;; no vop for this one either. +(define-assembly-routine + (tail-call-variable + (:return-style :none)) + + ;; These are really args. + ((:temp args any-reg nl0-offset) + (:temp lexenv descriptor-reg lexenv-offset) + + ;; We need to compute this + (:temp nargs any-reg nargs-offset) + + ;; These are needed by the blitting code. + (:temp src any-reg nl1-offset) + (:temp dst any-reg nl2-offset) + (:temp count any-reg nl3-offset) + (:temp temp descriptor-reg l0-offset) + (:temp lip interior-reg lip-offset) + + ;; These are needed so we can get at the register args. + (:temp a0 descriptor-reg a0-offset) + (:temp a1 descriptor-reg a1-offset) + (:temp a2 descriptor-reg a2-offset) + (:temp a3 descriptor-reg a3-offset)) + + + ;; Calculate NARGS (as a fixnum) + (inst sub nargs csp-tn args) + + ;; Load the argument regs (must do this now, 'cause the blt might + ;; trash these locations) + (inst lwz a0 args (* 0 n-word-bytes)) + (inst lwz a1 args (* 1 n-word-bytes)) + (inst lwz a2 args (* 2 n-word-bytes)) + (inst lwz a3 args (* 3 n-word-bytes)) + + ;; Calc SRC, DST, and COUNT + (inst addic. count nargs (fixnumize (- register-arg-count))) + (inst addi src args (* n-word-bytes register-arg-count)) + (inst ble done) + (inst addi dst cfp-tn (* n-word-bytes register-arg-count)) + + LOOP + ;; Copy one arg. + (inst lwz temp src 0) + (inst addi src src n-word-bytes) + (inst stw temp dst 0) + (inst addic. count count (fixnumize -1)) + (inst addi dst dst n-word-bytes) + (inst bgt loop) + + DONE + ;; We are done. Do the jump. + (loadw temp lexenv closure-fun-slot fun-pointer-lowtag) + (lisp-jump temp lip)) + + + +;;;; Non-local exit noise. + +(define-assembly-routine (unwind + (:return-style :none) + (:translate %continue-unwind) + (:policy :fast-safe)) + ((:arg block (any-reg descriptor-reg) a0-offset) + (:arg start (any-reg descriptor-reg) ocfp-offset) + (:arg count (any-reg descriptor-reg) nargs-offset) + (:temp lra descriptor-reg lra-offset) + (:temp lip interior-reg lip-offset) + (:temp cur-uwp any-reg nl0-offset) + (:temp next-uwp any-reg nl1-offset) + (:temp target-uwp any-reg nl2-offset)) + (declare (ignore start count)) + + (let ((error (generate-error-code nil invalid-unwind-error))) + (inst cmpwi block 0) + (inst beq error)) + + (load-symbol-value cur-uwp *current-unwind-protect-block*) + (loadw target-uwp block unwind-block-current-uwp-slot) + (inst cmpw cur-uwp target-uwp) + (inst bne do-uwp) + + (move cur-uwp block) + + DO-EXIT + + (loadw cfp-tn cur-uwp unwind-block-current-cont-slot) + (loadw code-tn cur-uwp unwind-block-current-code-slot) + (loadw lra cur-uwp unwind-block-entry-pc-slot) + (lisp-return lra lip :frob-code nil) + + DO-UWP + + (loadw next-uwp cur-uwp unwind-block-current-uwp-slot) + (store-symbol-value next-uwp *current-unwind-protect-block*) + (inst b do-exit)) + +(define-assembly-routine (throw + (:return-style :none)) + ((:arg target descriptor-reg a0-offset) + (:arg start any-reg ocfp-offset) + (:arg count any-reg nargs-offset) + (:temp catch any-reg a1-offset) + (:temp tag descriptor-reg a2-offset)) + + (declare (ignore start count)) + + (load-symbol-value catch *current-catch-block*) + + loop + + (let ((error (generate-error-code nil unseen-throw-tag-error target))) + (inst cmpwi catch 0) + (inst beq error)) + + (loadw tag catch catch-block-tag-slot) + (inst cmpw tag target) + (inst beq exit) + (loadw catch catch catch-block-previous-catch-slot) + (inst b loop) + + exit + + (move target catch) + (inst ba (make-fixup 'unwind :assembly-routine))) + + + diff --git a/src/assembly/ppc/foo.lisp b/src/assembly/ppc/foo.lisp new file mode 100644 index 0000000..016d0f1 --- /dev/null +++ b/src/assembly/ppc/foo.lisp @@ -0,0 +1,210 @@ +(in-package "SB!VM") + + +;;;; Return-multiple with other than one value + +(define-assembly-routine + (return-multiple + (:return-style :none)) + + ;; These four are really arguments. + ((:temp nvals any-reg nargs-offset) + (:temp vals any-reg nl0-offset) + (:temp ocfp any-reg nl1-offset) + (:temp lra descriptor-reg lra-offset) + + ;; These are just needed to facilitate the transfer + (:temp lip interior-reg lip-offset) + (:temp count any-reg nl2-offset) + (:temp src any-reg nl3-offset) + (:temp dst any-reg cfunc-offset) + (:temp temp descriptor-reg l0-offset) + + + ;; These are needed so we can get at the register args. + (:temp a0 descriptor-reg a0-offset) + (:temp a1 descriptor-reg a1-offset) + (:temp a2 descriptor-reg a2-offset) + (:temp a3 descriptor-reg a3-offset)) + + ;; Note, because of the way the return-multiple vop is written, we can + ;; assume that we are never called with nvals == 1 and that a0 has already + ;; been loaded. + (inst cmpwi nvals 0)) +#| + (inst ble default-a0-and-on) + (inst cmpwi nvals (fixnumize 2)) + (inst lwz a1 vals (* 1 n-word-bytes)) + (inst ble default-a2-and-on) + (inst cmpwi nvals (fixnumize 3)) + (inst lwz a2 vals (* 2 n-word-bytes)) + (inst ble default-a3-and-on) + (inst cmpwi nvals (fixnumize 4)) + (inst lwz a3 vals (* 3 n-word-bytes)) + (inst ble done) + + ;; Copy the remaining args to the top of the stack. + (inst addi src vals (* 4 n-word-bytes)) + (inst addi dst cfp-tn (* 4 n-word-bytes)) + (inst addic. count nvals (- (fixnumize 4))) + + LOOP + (inst subic. count count (fixnumize 1)) + (inst lwz temp src 0) + (inst addi src src n-word-bytes) + (inst stw temp dst 0) + (inst addi dst dst n-word-bytes) + (inst bge loop) + + (inst b done) + + DEFAULT-A0-AND-ON + (inst mr a0 null-tn) + (inst mr a1 null-tn) + DEFAULT-A2-AND-ON + (inst mr a2 null-tn) + DEFAULT-A3-AND-ON + (inst mr a3 null-tn) + DONE + + ;; Clear the stack. + (move ocfp-tn cfp-tn) + (move cfp-tn ocfp) + (inst add csp-tn ocfp-tn nvals) + + ;; Return. + (lisp-return lra lip)) + + +;;;; tail-call-variable. + +#+sb-assembling ;; no vop for this one either. +(define-assembly-routine + (tail-call-variable + (:return-style :none)) + + ;; These are really args. + ((:temp args any-reg nl0-offset) + (:temp lexenv descriptor-reg lexenv-offset) + + ;; We need to compute this + (:temp nargs any-reg nargs-offset) + + ;; These are needed by the blitting code. + (:temp src any-reg nl1-offset) + (:temp dst any-reg nl2-offset) + (:temp count any-reg nl3-offset) + (:temp temp descriptor-reg l0-offset) + (:temp lip interior-reg lip-offset) + + ;; These are needed so we can get at the register args. + (:temp a0 descriptor-reg a0-offset) + (:temp a1 descriptor-reg a1-offset) + (:temp a2 descriptor-reg a2-offset) + (:temp a3 descriptor-reg a3-offset)) + + + ;; Calculate NARGS (as a fixnum) + (inst sub nargs csp-tn args) + + ;; Load the argument regs (must do this now, 'cause the blt might + ;; trash these locations) + (inst lwz a0 args (* 0 n-word-bytes)) + (inst lwz a1 args (* 1 n-word-bytes)) + (inst lwz a2 args (* 2 n-word-bytes)) + (inst lwz a3 args (* 3 n-word-bytes)) + + ;; Calc SRC, DST, and COUNT + (inst addic. count nargs (fixnumize (- register-arg-count))) + (inst addi src args (* n-word-bytes register-arg-count)) + (inst ble done) + (inst addi dst cfp-tn (* n-word-bytes register-arg-count)) + + LOOP + ;; Copy one arg. + (inst lwz temp src 0) + (inst addi src src n-word-bytes) + (inst stw temp dst 0) + (inst addic. count count (fixnumize -1)) + (inst addi dst dst n-word-bytes) + (inst bgt loop) + + DONE + ;; We are done. Do the jump. + (loadw temp lexenv closure-fun-slot fun-pointer-lowtag) + (lisp-jump temp lip)) + + + +;;;; Non-local exit noise. + +(define-assembly-routine (unwind + (:return-style :none) + (:translate %continue-unwind) + (:policy :fast-safe)) + ((:arg block (any-reg descriptor-reg) a0-offset) + (:arg start (any-reg descriptor-reg) ocfp-offset) + (:arg count (any-reg descriptor-reg) nargs-offset) + (:temp lra descriptor-reg lra-offset) + (:temp lip interior-reg lip-offset) + (:temp cur-uwp any-reg nl0-offset) + (:temp next-uwp any-reg nl1-offset) + (:temp target-uwp any-reg nl2-offset)) + (declare (ignore start count)) + + (let ((error (generate-error-code nil invalid-unwind-error))) + (inst cmpwi block 0) + (inst beq error)) + + (load-symbol-value cur-uwp *current-unwind-protect-block*) + (loadw target-uwp block unwind-block-current-uwp-slot) + (inst cmpw cur-uwp target-uwp) + (inst bne do-uwp) + + (move cur-uwp block) + + DO-EXIT + + (loadw cfp-tn cur-uwp unwind-block-current-cont-slot) + (loadw code-tn cur-uwp unwind-block-current-code-slot) + (loadw lra cur-uwp unwind-block-entry-pc-slot) + (lisp-return lra lip :frob-code nil) + + DO-UWP + + (loadw next-uwp cur-uwp unwind-block-current-uwp-slot) + (store-symbol-value next-uwp *current-unwind-protect-block*) + (inst b do-exit)) + +(define-assembly-routine (throw + (:return-style :none)) + ((:arg target descriptor-reg a0-offset) + (:arg start any-reg ocfp-offset) + (:arg count any-reg nargs-offset) + (:temp catch any-reg a1-offset) + (:temp tag descriptor-reg a2-offset)) + + (declare (ignore start count)) + + (load-symbol-value catch *current-catch-block*) + + loop + + (let ((error (generate-error-code nil unseen-throw-tag-error target))) + (inst cmpwi catch 0) + (inst beq error)) + + (loadw tag catch catch-block-tag-slot) + (inst cmpw tag target) + (inst beq exit) + (loadw catch catch catch-block-previous-catch-slot) + (inst b loop) + + exit + + (move target catch) + (inst ba (make-fixup 'unwind :assembly-routine))) + + + +|# \ No newline at end of file diff --git a/src/assembly/ppc/support.lisp b/src/assembly/ppc/support.lisp new file mode 100644 index 0000000..3d736ac --- /dev/null +++ b/src/assembly/ppc/support.lisp @@ -0,0 +1,55 @@ +(in-package "SB!VM") + +(!def-vm-support-routine generate-call-sequence (name style vop) + (ecase style + (:raw + (values + `((inst bla (make-fixup ',name :assembly-routine))) + `())) + (:full-call + (let ((temp (make-symbol "TEMP")) + (nfp-save (make-symbol "NFP-SAVE")) + (lra (make-symbol "LRA"))) + (values + `((let ((lra-label (gen-label)) + (cur-nfp (current-nfp-tn ,vop))) + (when cur-nfp + (store-stack-tn ,nfp-save cur-nfp)) + (inst compute-lra-from-code ,lra code-tn lra-label ,temp) + (note-next-instruction ,vop :call-site) + (inst ba (make-fixup ',name :assembly-routine)) + (emit-return-pc lra-label) + (note-this-location ,vop :single-value-return) + (without-scheduling () + (move csp-tn ocfp-tn) + (inst nop)) + (inst compute-code-from-lra code-tn code-tn + lra-label ,temp) + (when cur-nfp + (load-stack-tn cur-nfp ,nfp-save)))) + `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1)) + ,temp) + (:temporary (:sc descriptor-reg :offset lra-offset + :from (:eval 0) :to (:eval 1)) + ,lra) + (:temporary (:scs (control-stack) :offset nfp-save-offset) + ,nfp-save) + (:save-p :compute-only))))) + (:none + (values + `((inst ba (make-fixup ',name :assembly-routine))) + `())))) + +(!def-vm-support-routine generate-return-sequence (style) + (ecase style + (:raw + `((inst blr))) + (:full-call + `((lisp-return (make-random-tn :kind :normal + :sc (sc-or-lose 'descriptor-reg ) + :offset lra-offset) + (make-random-tn :kind :normal + :sc (sc-or-lose 'interior-reg ) + :offset lip-offset) + :offset 2))) + (:none))) diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index db17f75..d261c82 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -3139,9 +3139,9 @@ (breakpoint-do-displaced-inst signal-context (breakpoint-data-instruction data)) ;; Some platforms have no usable sigreturn() call. If your - ;; implementation of arch_do_displaced_inst() doesn't sigreturn(), - ;; add it to this list. - #!-(or hpux irix x86 alpha) + ;; implementation of arch_do_displaced_inst() _does_ sigreturn(), + ;; it's polite to warn here + #!+(and sparc solaris) (error "BREAKPOINT-DO-DISPLACED-INST returned?")))) (defun invoke-breakpoint-hooks (breakpoints component offset) diff --git a/src/code/ppc-vm.lisp b/src/code/ppc-vm.lisp new file mode 100644 index 0000000..ee2eaa3 --- /dev/null +++ b/src/code/ppc-vm.lisp @@ -0,0 +1,191 @@ +;;; This file contains the PPC specific runtime stuff. +;;; +(in-package "SB!VM") + +(defvar *number-of-signals* 64) +(defvar *bits-per-word* 32) + +(define-alien-type os-context-t (struct os-context-t-struct)) + + +;;;; MACHINE-TYPE and MACHINE-VERSION + +(defun machine-type () + "Returns a string describing the type of the local machine." + "PowerPC") + +(defun machine-version () + "Returns a string describing the version of the local machine." + "who-knows?") + + + +;;; FIXUP-CODE-OBJECT -- Interface +;;; +(defun fixup-code-object (code offset fixup kind) + (declare (type index offset)) + (unless (zerop (rem offset n-word-bytes)) + (error "Unaligned instruction? offset=#x~X." offset)) + (sb!sys:without-gcing + (let ((sap (truly-the system-area-pointer + (%primitive sb!kernel::code-instructions code)))) + (ecase kind + (:b + (error "Can't deal with CALL fixups, yet.")) + (:ba + (setf (ldb (byte 24 2) (sap-ref-32 sap offset)) + (ash fixup -2))) + (:ha + (let* ((h (ldb (byte 16 16) fixup)) + (l (ldb (byte 16 0) fixup))) + ; Compensate for possible sign-extension when the low half + ; is added to the high. We could avoid this by ORI-ing + ; the low half in 32-bit absolute loads, but it'd be + ; nice to be able to do: + ; lis rX,foo@ha + ; lwz rY,foo@l(rX) + ; and lwz/stw and friends all use a signed 16-bit offset. + (setf (ldb (byte 16 0) (sap-ref-32 sap offset)) + (if (logbitp 15 l) (ldb (byte 16 0) (1+ h)) h)))) + (:l + (setf (ldb (byte 16 0) (sap-ref-32 sap offset)) + (ldb (byte 16 0) fixup))))))) + + +;;;; "Sigcontext" access functions, cut & pasted from x86-vm.lisp then +;;;; hacked for types. + +(define-alien-routine ("os_context_pc_addr" context-pc-addr) (* unsigned-long) + (context (* os-context-t))) + +(defun context-pc (context) + (declare (type (alien (* os-context-t)) context)) + (int-sap (deref (context-pc-addr context)))) + +(define-alien-routine ("os_context_register_addr" context-register-addr) + (* unsigned-long) + (context (* os-context-t)) + (index int)) + +(defun context-register (context index) + (declare (type (alien (* os-context-t)) context)) + (deref (context-register-addr context index))) + +(defun %set-context-register (context index new) +(declare (type (alien (* os-context-t)) context)) +(setf (deref (context-register-addr context index)) + new)) +;;; This is like CONTEXT-REGISTER, but returns the value of a float +;;; register. FORMAT is the type of float to return. + +;;; FIXME: Whether COERCE actually knows how to make a float out of a +;;; long is another question. This stuff still needs testing. +#+nil +(define-alien-routine ("os_context_fpregister_addr" context-float-register-addr) + (* long) + (context (* os-context-t)) + (index int)) +#+nil +(defun context-float-register (context index format) + (declare (type (alien (* os-context-t)) context)) + (coerce (deref (context-float-register-addr context index)) format)) +#+nil +(defun %set-context-float-register (context index format new) + (declare (type (alien (* os-context-t)) context)) + (setf (deref (context-float-register-addr context index)) + (coerce new format))) + +;;; Given a signal context, return the floating point modes word in +;;; the same format as returned by FLOATING-POINT-MODES. +(defun context-floating-point-modes (context) + ;; FIXME: As of sbcl-0.6.7 and the big rewrite of signal handling + ;; for POSIXness and (at the Lisp level) opaque signal contexts, + ;; this is needs to be rewritten as an alien function. + (warn "stub CONTEXT-FLOATING-POINT-MODES") + 0) + + + +;;;; INTERNAL-ERROR-ARGS. + +;;; GIVEN a (POSIX) signal context, extract the internal error +;;; arguments from the instruction stream. This is e.g. + +;;; INTERNAL-ERROR-ARGS -- interface. +;;; +;;; Given the sigcontext, extract the internal error arguments from the +;;; instruction stream. +;;; +(defun internal-error-args (context) + (declare (type (alien (* os-context-t)) context)) + (let* ((pc (context-pc context)) + (bad-inst (sap-ref-32 pc 0)) + (op (ldb (byte 16 16) bad-inst))) + (declare (type system-area-pointer pc)) + (cond ((= op (logior (ash 3 10) (ash 6 5))) + (args-for-unimp-inst context)) + ((and (= (ldb (byte 6 10) op) 3) + (= (ldb (byte 5 5) op) 24)) + (let* ((regnum (ldb (byte 5 0) op)) + (prev (sap-ref-32 (int-sap (- (sap-int pc) 4)) 0))) + (if (and (= (ldb (byte 6 26) prev) 3) + (= (ldb (byte 5 21) prev) 0)) + (values (ldb (byte 16 0) prev) + (list (sb!c::make-sc-offset sb!vm:any-reg-sc-number + (ldb (byte 5 16) prev)))) + (values #.(sb!kernel:error-number-or-lose + 'sb!kernel:invalid-arg-count-error) + (list (sb!c::make-sc-offset sb!vm:any-reg-sc-number regnum)))))) + + (t + (values #.(error-number-or-lose 'unknown-error) nil))))) + +(defun args-for-unimp-inst (context) + (declare (type (alien (* os-context-t)) context)) + (let* ((pc (context-pc context)) + (length (sap-ref-8 pc 4)) + (vector (make-array length :element-type '(unsigned-byte 8)))) + (declare (type system-area-pointer pc) + (type (unsigned-byte 8) length) + (type (simple-array (unsigned-byte 8) (*)) vector)) + (copy-from-system-area pc (* sb!vm:n-byte-bits 5) + vector (* sb!vm:n-word-bits + sb!vm:vector-data-offset) + (* length sb!vm:n-byte-bits)) + (let* ((index 0) + (error-number (sb!c::read-var-integer vector index))) + (collect ((sc-offsets)) + (loop + (when (>= index length) + (return)) + (sc-offsets (sb!c::read-var-integer vector index))) + (values error-number (sc-offsets)))))) + + + +;;; The loader uses this to convert alien names to the form they +;;; occur in the symbol table. This is ELF, so do nothing + +(defun extern-alien-name (name) + (declare (type simple-base-string name)) + name) + + + +;;; SANCTIFY-FOR-EXECUTION -- Interface. +;;; +;;; Do whatever is necessary to make the given code component executable. +;;; On the 601, we have less to do than on some other PowerPC chips. +;;; This should what needs to be done in the general case. +;;; +(defun sanctify-for-execution (component) + (without-gcing + (alien-funcall (extern-alien "ppc_flush_icache" + (function void + system-area-pointer + unsigned-long)) + (code-instructions component) + (* (code-header-ref component code-code-size-slot) + n-word-bytes))) + nil) + diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index b803202..4eca659 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -1612,11 +1612,7 @@ (:alpha (ecase kind (:jmp-hint - (assert (zerop (ldb (byte 2 0) value))) - #+nil ;; was commented out in cmucl source too. Don't know what - ;; it does -dan 2001.05.03 - (setf (sap-ref-16 sap 0) - (logior (sap-ref-16 sap 0) (ldb (byte 14 0) (ash value -2))))) + (assert (zerop (ldb (byte 2 0) value)))) (:bits-63-48 (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value)) (value (if (logbitp 31 value) (+ value (ash 1 32)) value)) @@ -1643,6 +1639,20 @@ (ldb (byte 8 0) value) (byte-vector-ref-8 gspace-bytes (1+ gspace-byte-offset)) (ldb (byte 8 8) value))))) + (:ppc + (ecase kind + (:ba + (setf (byte-vector-ref-32 gspace-bytes gspace-byte-offset) + (dpb (ash value -2) (byte 24 2) + (byte-vector-ref-32 gspace-bytes gspace-byte-offset)))) + (:ha + (let* ((h (ldb (byte 16 16) value)) + (l (ldb (byte 16 0) value))) + (setf (byte-vector-ref-16 gspace-bytes (+ gspace-byte-offset 2)) + (if (logbitp 15 l) (ldb (byte 16 0) (1+ h)) h)))) + (:l + (setf (byte-vector-ref-16 gspace-bytes (+ gspace-byte-offset 2)) + (ldb (byte 16 0) value))))) (:sparc (ecase kind (:call diff --git a/src/compiler/ppc/alloc.lisp b/src/compiler/ppc/alloc.lisp new file mode 100644 index 0000000..9c5c896 --- /dev/null +++ b/src/compiler/ppc/alloc.lisp @@ -0,0 +1,187 @@ +;;; +;;; Written by William Lott. +;;; + +(in-package "SB!VM") + + +;;;; LIST and LIST* + +(define-vop (list-or-list*) + (:args (things :more t)) + (:temporary (:scs (descriptor-reg) :type list) ptr) + (:temporary (:scs (descriptor-reg)) temp) + (:temporary (:scs (descriptor-reg) :type list :to (:result 0) :target result) + res) + (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag) + (:info num) + (:results (result :scs (descriptor-reg))) + (:variant-vars star) + (:policy :safe) + (:generator 0 + (cond ((zerop num) + (move result null-tn)) + ((and star (= num 1)) + (move result (tn-ref-tn things))) + (t + (macrolet + ((maybe-load (tn) + (once-only ((tn tn)) + `(sc-case ,tn + ((any-reg descriptor-reg zero null) + ,tn) + (control-stack + (load-stack-tn temp ,tn) + temp))))) + (let* ((cons-cells (if star (1- num) num)) + (alloc (* (pad-data-block cons-size) cons-cells))) + (pseudo-atomic (pa-flag :extra alloc) + (inst clrrwi res alloc-tn n-lowtag-bits) + (inst ori res res list-pointer-lowtag) + (move ptr res) + (dotimes (i (1- cons-cells)) + (storew (maybe-load (tn-ref-tn things)) ptr + cons-car-slot list-pointer-lowtag) + (setf things (tn-ref-across things)) + (inst addi ptr ptr (pad-data-block cons-size)) + (storew ptr ptr + (- cons-cdr-slot cons-size) + list-pointer-lowtag)) + (storew (maybe-load (tn-ref-tn things)) ptr + cons-car-slot list-pointer-lowtag) + (storew (if star + (maybe-load (tn-ref-tn (tn-ref-across things))) + null-tn) + ptr cons-cdr-slot list-pointer-lowtag)) + (move result res))))))) + +(define-vop (list list-or-list*) + (:variant nil)) + +(define-vop (list* list-or-list*) + (:variant t)) + + +;;;; Special purpose inline allocators. + +(define-vop (allocate-code-object) + (:args (boxed-arg :scs (any-reg)) + (unboxed-arg :scs (any-reg))) + (:results (result :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:temporary (:scs (any-reg) :from (:argument 0)) boxed) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed) + (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag) + (:generator 100 + (inst addi boxed boxed-arg (fixnumize (1+ code-trace-table-offset-slot))) + (inst clrrwi boxed boxed n-lowtag-bits) + (inst srwi unboxed unboxed-arg word-shift) + (inst addi unboxed unboxed lowtag-mask) + (inst clrrwi unboxed unboxed n-lowtag-bits) + (pseudo-atomic (pa-flag) + ;; Note: we don't have to subtract off the 4 that was added by + ;; pseudo-atomic, because oring in other-pointer-lowtag just adds + ;; it right back. + (inst ori result alloc-tn other-pointer-lowtag) + (inst add alloc-tn alloc-tn boxed) + (inst add alloc-tn alloc-tn unboxed) + (inst slwi ndescr boxed (- n-widetag-bits word-shift)) + (inst ori ndescr ndescr code-header-widetag) + (storew ndescr result 0 other-pointer-lowtag) + (storew unboxed result code-code-size-slot other-pointer-lowtag) + (storew null-tn result code-entry-points-slot other-pointer-lowtag) + (storew null-tn result code-debug-info-slot other-pointer-lowtag)))) + +(define-vop (make-fdefn) + (:args (name :scs (descriptor-reg) :to :eval)) + (:temporary (:scs (non-descriptor-reg)) temp) + (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag) + (:results (result :scs (descriptor-reg) :from :argument)) + (:policy :fast-safe) + (:translate make-fdefn) + (:generator 37 + (with-fixed-allocation (result pa-flag temp fdefn-widetag fdefn-size) + (inst lr temp (make-fixup "undefined_tramp" :foreign)) + (storew name result fdefn-name-slot other-pointer-lowtag) + (storew null-tn result fdefn-fun-slot other-pointer-lowtag) + (storew temp result fdefn-raw-addr-slot other-pointer-lowtag)))) + + +(define-vop (make-closure) + (:args (function :to :save :scs (descriptor-reg))) + (:info length) + (:temporary (:scs (non-descriptor-reg)) temp) + (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag) + (:results (result :scs (descriptor-reg))) + (:generator 10 + (let ((size (+ length closure-info-offset))) + (pseudo-atomic (pa-flag :extra (pad-data-block size)) + (inst clrrwi. result alloc-tn n-lowtag-bits) + (inst ori result result fun-pointer-lowtag) + (inst lr temp (logior (ash (1- size) n-widetag-bits) closure-header-widetag)) + (storew temp result 0 fun-pointer-lowtag))) + ;(inst lis temp (ash 18 10)) + ;(storew temp result closure-jump-insn-slot function-pointer-type) + (storew function result closure-fun-slot fun-pointer-lowtag))) + +;;; The compiler likes to be able to directly make value cells. +;;; +(define-vop (make-value-cell) + (:args (value :to :save :scs (descriptor-reg any-reg))) + (:temporary (:scs (non-descriptor-reg)) temp) + (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag) + (:results (result :scs (descriptor-reg))) + (:generator 10 + (with-fixed-allocation + (result pa-flag temp value-cell-header-widetag value-cell-size)) + (storew value result value-cell-value-slot other-pointer-lowtag))) + + + +;;;; Automatic allocators for primitive objects. + +(define-vop (make-unbound-marker) + (:args) + (:results (result :scs (any-reg))) + (:generator 1 + (inst li result unbound-marker-widetag))) + +(define-vop (fixed-alloc) + (:args) + (:info name words type lowtag) + (:ignore name) + (:results (result :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) temp) + (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag) + (:generator 4 + (pseudo-atomic (pa-flag :extra (pad-data-block words)) + (cond ((logbitp 2 lowtag) + (inst ori result alloc-tn lowtag)) + (t + (inst clrrwi result alloc-tn n-lowtag-bits) + (inst ori result result lowtag))) + (when type + (inst lr temp (logior (ash (1- words) n-widetag-bits) type)) + (storew temp result 0 lowtag))))) + +(define-vop (var-alloc) + (:args (extra :scs (any-reg))) + (:arg-types positive-fixnum) + (:info name words type lowtag) + (:ignore name) + (:results (result :scs (descriptor-reg))) + (:temporary (:scs (any-reg)) bytes header) + (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag) + (:generator 6 + (inst addi bytes extra (* (1+ words) n-word-bytes)) + (inst slwi header bytes (- n-widetag-bits 2)) + (inst addi header header (+ (ash -2 n-widetag-bits) type)) + (inst clrrwi bytes bytes n-lowtag-bits) + (pseudo-atomic (pa-flag) + (cond ((logbitp 2 lowtag) + (inst ori result alloc-tn lowtag)) + (t + (inst clrrwi result alloc-tn n-lowtag-bits) + (inst ori result result lowtag))) + (storew header result 0 lowtag) + (inst add alloc-tn alloc-tn bytes)))) diff --git a/src/compiler/ppc/arith.lisp b/src/compiler/ppc/arith.lisp new file mode 100644 index 0000000..aafd5cf --- /dev/null +++ b/src/compiler/ppc/arith.lisp @@ -0,0 +1,924 @@ +;;; +;;; Converted by William Lott. +;;; + +(in-package "SB!VM") + + + +;;;; Unary operations. + +(define-vop (fast-safe-arith-op) + (:policy :fast-safe) + (:effects) + (:affected)) + + +(define-vop (fixnum-unop fast-safe-arith-op) + (:args (x :scs (any-reg))) + (:results (res :scs (any-reg))) + (:note "inline fixnum arithmetic") + (:arg-types tagged-num) + (:result-types tagged-num)) + +(define-vop (signed-unop fast-safe-arith-op) + (:args (x :scs (signed-reg))) + (:results (res :scs (signed-reg))) + (:note "inline (signed-byte 32) arithmetic") + (:arg-types signed-num) + (:result-types signed-num)) + +(define-vop (fast-negate/fixnum fixnum-unop) + (:translate %negate) + (:generator 1 + (inst neg res x))) + +(define-vop (fast-negate/signed signed-unop) + (:translate %negate) + (:generator 2 + (inst neg res x))) + +(define-vop (fast-lognot/fixnum fixnum-unop) + (:translate lognot) + (:generator 2 + (inst xori res x (fixnumize -1)))) + +(define-vop (fast-lognot/signed signed-unop) + (:translate lognot) + (:generator 1 + (inst not res x))) + + + +;;;; Binary fixnum operations. + +;;; Assume that any constant operand is the second arg... + +(define-vop (fast-fixnum-binop fast-safe-arith-op) + (:args (x :target r :scs (any-reg zero)) + (y :target r :scs (any-reg zero))) + (:arg-types tagged-num tagged-num) + (:results (r :scs (any-reg))) + (:result-types tagged-num) + (:note "inline fixnum arithmetic")) + +(define-vop (fast-unsigned-binop fast-safe-arith-op) + (:args (x :target r :scs (unsigned-reg zero)) + (y :target r :scs (unsigned-reg zero))) + (:arg-types unsigned-num unsigned-num) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num) + (:note "inline (unsigned-byte 32) arithmetic")) + +(define-vop (fast-signed-binop fast-safe-arith-op) + (:args (x :target r :scs (signed-reg zero)) + (y :target r :scs (signed-reg zero))) + (:arg-types signed-num signed-num) + (:results (r :scs (signed-reg))) + (:result-types signed-num) + (:note "inline (signed-byte 32) arithmetic")) + + +(define-vop (fast-fixnum-binop-c fast-safe-arith-op) + (:args (x :target r :scs (any-reg zero))) + (:info y) + (:arg-types tagged-num + (:constant (and (signed-byte 14) (not (integer 0 0))))) + (:results (r :scs (any-reg))) + (:result-types tagged-num) + (:note "inline fixnum arithmetic")) + +(define-vop (fast-fixnum-logop-c fast-safe-arith-op) + (:args (x :target r :scs (any-reg zero))) + (:info y) + (:arg-types tagged-num + (:constant (and (unsigned-byte 14) (not (integer 0 0))))) + (:results (r :scs (any-reg))) + (:result-types tagged-num) + (:note "inline fixnum logical op")) + +(define-vop (fast-unsigned-binop-c fast-safe-arith-op) + (:args (x :target r :scs (unsigned-reg zero))) + (:info y) + (:arg-types unsigned-num + (:constant (and (signed-byte 16) (not (integer 0 0))))) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num) + (:note "inline (unsigned-byte 32) arithmetic")) + +(define-vop (fast-unsigned-logop-c fast-safe-arith-op) + (:args (x :target r :scs (unsigned-reg zero))) + (:info y) + (:arg-types unsigned-num + (:constant (and (unsigned-byte 16) (not (integer 0 0))))) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num) + (:note "inline (unsigned-byte 32) logical op")) + +(define-vop (fast-signed-binop-c fast-safe-arith-op) + (:args (x :target r :scs (signed-reg zero))) + (:info y) + (:arg-types signed-num + (:constant (and (signed-byte 16) (not (integer 0 0))))) + (:results (r :scs (signed-reg))) + (:result-types signed-num) + (:note "inline (signed-byte 32) arithmetic")) + +(define-vop (fast-signed-logop-c fast-safe-arith-op) + (:args (x :target r :scs (signed-reg zero))) + (:info y) + (:arg-types signed-num + (:constant (and (unsigned-byte 16) (not (integer 0 0))))) + (:results (r :scs (signed-reg))) + (:result-types signed-num) + (:note "inline (signed-byte 32) arithmetic")) + + +(eval-when (:compile-toplevel :load-toplevel :execute) + +(defmacro define-var-binop (translate untagged-penalty op) + `(progn + (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM") + fast-fixnum-binop) + (:translate ,translate) + (:generator 2 + (inst ,op r x y))) + (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED") + fast-signed-binop) + (:translate ,translate) + (:generator ,(1+ untagged-penalty) + (inst ,op r x y))) + (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED") + fast-unsigned-binop) + (:translate ,translate) + (:generator ,(1+ untagged-penalty) + (inst ,op r x y))))) + + +(defmacro define-const-binop (translate untagged-penalty op) + `(progn + + (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum) + fast-fixnum-binop-c) + (:translate ,translate) + (:generator 1 + (inst ,op r x (fixnumize y)))) + (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed) + fast-signed-binop-c) + (:translate ,translate) + (:generator ,untagged-penalty + (inst ,op r x y))) + (define-vop (,(symbolicate 'fast- translate '-c/unsigned=>unsigned) + fast-unsigned-binop-c) + (:translate ,translate) + (:generator ,untagged-penalty + (inst ,op r x y))))) + +(defmacro define-const-logop (translate untagged-penalty op) + `(progn + + (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum) + fast-fixnum-logop-c) + (:translate ,translate) + (:generator 1 + (inst ,op r x (fixnumize y)))) + (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed) + fast-signed-logop-c) + (:translate ,translate) + (:generator ,untagged-penalty + (inst ,op r x y))) + (define-vop (,(symbolicate 'fast- translate '-c/unsigned=>unsigned) + fast-unsigned-logop-c) + (:translate ,translate) + (:generator ,untagged-penalty + (inst ,op r x y))))) + +); eval-when + +(define-var-binop + 4 add) +(define-var-binop - 4 sub) +(define-var-binop logand 2 and) +(define-var-binop logandc2 2 andc) +(define-var-binop logior 2 or) +(define-var-binop logorc2 2 orc) +(define-var-binop logxor 2 xor) +(define-var-binop logeqv 2 eqv) + +(define-const-binop + 4 addi) +(define-const-binop - 4 subi) +(define-const-logop logand 2 andi.) +(define-const-logop logior 2 ori) +(define-const-logop logxor 2 xori) + + +;;; Special case fixnum + and - that trap on overflow. Useful when we +;;; don't know that the output type is a fixnum. +;;; +(define-vop (+/fixnum fast-+/fixnum=>fixnum) + (:policy :safe) + (:results (r :scs (any-reg descriptor-reg))) + (:result-types tagged-num) + (:note "safe inline fixnum arithmetic") + (:generator 4 + (let* ((no-overflow (gen-label))) + (inst mcrxr :cr0) + (inst addo. r x y) + (inst bns no-overflow) + (inst unimp (logior (ash (reg-tn-encoding r) 5) + fixnum-additive-overflow-trap)) + (emit-label no-overflow)))) + + +(define-vop (-/fixnum fast--/fixnum=>fixnum) + (:policy :safe) + (:results (r :scs (any-reg descriptor-reg))) + (:result-types tagged-num) + (:note "safe inline fixnum arithmetic") + (:generator 4 + (let* ((no-overflow (gen-label))) + (inst mcrxr :cr0) + (inst subo. r x y) + (inst bns no-overflow) + (inst unimp (logior (ash (reg-tn-encoding r) 5) + fixnum-additive-overflow-trap)) + (emit-label no-overflow)))) + + +;;; Shifting + +(define-vop (fast-ash/unsigned=>unsigned) + (:note "inline ASH") + (:args (number :scs (unsigned-reg) :to :save) + (amount :scs (signed-reg immediate))) + (:arg-types (:or unsigned-num) signed-num) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:translate ash) + (:policy :fast-safe) + (:temporary (:sc non-descriptor-reg) ndesc) + (:generator 3 + (sc-case amount + (signed-reg + (let ((positive (gen-label)) + (done (gen-label))) + (inst cmpwi amount 0) + (inst neg ndesc amount) + (inst bge positive) + (inst cmpwi ndesc 31) + (inst srw result number ndesc) + (inst ble done) + (inst srwi result number 31) + (inst b done) + + (emit-label positive) + ;; The result-type assures us that this shift will not overflow. + (inst slw result number amount) + + (emit-label done))) + + (immediate + (let ((amount (tn-value amount))) + (if (minusp amount) + (let ((amount (min 31 (- amount)))) + (inst srwi result number amount)) + (inst slwi result number amount))))))) + + +(define-vop (fast-ash/signed=>signed) + (:note "inline ASH") + (:args (number :scs (signed-reg) :to :save) + (amount :scs (signed-reg immediate))) + (:arg-types (:or signed-num) signed-num) + (:results (result :scs (signed-reg))) + (:result-types (:or signed-num)) + (:translate ash) + (:policy :fast-safe) + (:temporary (:sc non-descriptor-reg) ndesc) + (:generator 3 + (sc-case amount + (signed-reg + (let ((positive (gen-label)) + (done (gen-label))) + (inst cmpwi amount 0) + (inst neg ndesc amount) + (inst bge positive) + (inst cmpwi ndesc 31) + (inst sraw result number ndesc) + (inst ble done) + (inst srawi result number 31) + (inst b done) + + (emit-label positive) + ;; The result-type assures us that this shift will not overflow. + (inst slw result number amount) + + (emit-label done))) + + (immediate + (let ((amount (tn-value amount))) + (if (minusp amount) + (let ((amount (min 31 (- amount)))) + (inst srawi result number amount)) + (inst slwi result number amount))))))) + + + +(define-vop (signed-byte-32-len) + (:translate integer-length) + (:note "inline (signed-byte 32) integer-length") + (:policy :fast-safe) + (:args (arg :scs (signed-reg))) + (:arg-types signed-num) + (:results (res :scs (any-reg))) + (:result-types positive-fixnum) + (:temporary (:scs (non-descriptor-reg) :to (:argument 0)) shift) + (:generator 6 + ; (integer-length arg) = (- 32 (cntlz (if (>= arg 0) arg (lognot arg)))) + (let ((nonneg (gen-label))) + (inst cntlzw. shift arg) + (inst bne nonneg) + (inst not shift arg) + (inst cntlzw shift shift) + (emit-label nonneg) + (inst slwi shift shift 2) + (inst subfic res shift (fixnumize 32))))) + +(define-vop (unsigned-byte-32-count) + (:translate logcount) + (:note "inline (unsigned-byte 32) logcount") + (:policy :fast-safe) + (:args (arg :scs (unsigned-reg) :target shift)) + (:arg-types unsigned-num) + (:results (res :scs (any-reg))) + (:result-types positive-fixnum) + (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift temp) + (:generator 30 + (let ((loop (gen-label)) + (done (gen-label))) + (inst add. shift zero-tn arg) + (move res zero-tn) + (inst beq done) + + (emit-label loop) + (inst subi temp shift 1) + (inst and. shift shift temp) + (inst addi res res (fixnumize 1)) + (inst bne loop) + + (emit-label done)))) + + +;;;; Binary conditional VOPs: + +(define-vop (fast-conditional) + (:conditional) + (:info target not-p) + (:effects) + (:affected) + (:policy :fast-safe)) + +(deftype integer-with-a-bite-out (s bite) + (cond ((eq s '*) 'integer) + ((and (integerp s) (> s 1)) + (let ((bound (ash 1 (1- s)))) + `(integer ,(- bound) ,(- bound bite 1)))) + (t + (error "Bad size specified for SIGNED-BYTE type specifier: ~S." s)))) + +(define-vop (fast-conditional/fixnum fast-conditional) + (:args (x :scs (any-reg zero)) + (y :scs (any-reg zero))) + (:arg-types tagged-num tagged-num) + (:note "inline fixnum comparison")) + +(define-vop (fast-conditional-c/fixnum fast-conditional/fixnum) + (:args (x :scs (any-reg zero))) + (:arg-types tagged-num (:constant (signed-byte 14))) + (:info target not-p y)) + +(define-vop (fast-conditional/signed fast-conditional) + (:args (x :scs (signed-reg zero)) + (y :scs (signed-reg zero))) + (:arg-types signed-num signed-num) + (:note "inline (signed-byte 32) comparison")) + +(define-vop (fast-conditional-c/signed fast-conditional/signed) + (:args (x :scs (signed-reg zero))) + (:arg-types signed-num (:constant (signed-byte 16))) + (:info target not-p y)) + +(define-vop (fast-conditional/unsigned fast-conditional) + (:args (x :scs (unsigned-reg zero)) + (y :scs (unsigned-reg zero))) + (:arg-types unsigned-num unsigned-num) + (:note "inline (unsigned-byte 32) comparison")) + +(define-vop (fast-conditional-c/unsigned fast-conditional/unsigned) + (:args (x :scs (unsigned-reg zero))) + (:arg-types unsigned-num (:constant (unsigned-byte 16))) + (:info target not-p y)) + + +(define-vop (fast-if-/fixnum fast-conditional/fixnum) + (:translate >) + (:generator 4 + (inst cmpw x y) + (inst b? (if not-p :le :gt) target))) + +(define-vop (fast-if->-c/fixnum fast-conditional-c/fixnum) + (:translate >) + (:generator 3 + (inst cmpwi x (fixnumize y)) + (inst b? (if not-p :le :gt) target))) + +(define-vop (fast-if->/signed fast-conditional/signed) + (:translate >) + (:generator 6 + (inst cmpw x y) + (inst b? (if not-p :le :gt) target))) + +(define-vop (fast-if->-c/signed fast-conditional-c/signed) + (:translate >) + (:generator 5 + (inst cmpwi x y) + (inst b? (if not-p :le :gt) target))) + +(define-vop (fast-if->/unsigned fast-conditional/unsigned) + (:translate >) + (:generator 6 + (inst cmplw x y) + (inst b? (if not-p :le :gt) target))) + +(define-vop (fast-if->-c/unsigned fast-conditional-c/unsigned) + (:translate >) + (:generator 5 + (inst cmplwi x y) + (inst b? (if not-p :le :gt) target))) + +(define-vop (fast-if-eql/signed fast-conditional/signed) + (:translate eql) + (:generator 6 + (inst cmpw x y) + (inst b? (if not-p :ne :eq) target))) + +(define-vop (fast-if-eql-c/signed fast-conditional-c/signed) + (:translate eql) + (:generator 5 + (inst cmpwi x y) + (inst b? (if not-p :ne :eq) target))) + +(define-vop (fast-if-eql/unsigned fast-conditional/unsigned) + (:translate eql) + (:generator 6 + (inst cmplw x y) + (inst b? (if not-p :ne :eq) target))) + +(define-vop (fast-if-eql-c/unsigned fast-conditional-c/unsigned) + (:translate eql) + (:generator 5 + (inst cmplwi x y) + (inst b? (if not-p :ne :eq) target))) + + +;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a +;;; known fixnum. + +;;; These versions specify a fixnum restriction on their first arg. We have +;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on +;;; the first arg and a higher cost. The reason for doing this is to prevent +;;; fixnum specific operations from being used on word integers, spuriously +;;; consing the argument. +;;; + +(define-vop (fast-eql/fixnum fast-conditional) + (:args (x :scs (any-reg descriptor-reg zero)) + (y :scs (any-reg zero))) + (:arg-types tagged-num tagged-num) + (:note "inline fixnum comparison") + (:translate eql) + (:generator 4 + (inst cmpw x y) + (inst b? (if not-p :ne :eq) target))) +;;; +(define-vop (generic-eql/fixnum fast-eql/fixnum) + (:arg-types * tagged-num) + (:variant-cost 7)) + +(define-vop (fast-eql-c/fixnum fast-conditional/fixnum) + (:args (x :scs (any-reg descriptor-reg zero))) + (:arg-types tagged-num (:constant (signed-byte 14))) + (:info target not-p y) + (:translate eql) + (:generator 2 + (inst cmpwi x (fixnumize y)) + (inst b? (if not-p :ne :eq) target))) +;;; +(define-vop (generic-eql-c/fixnum fast-eql-c/fixnum) + (:arg-types * (:constant (signed-byte 11))) + (:variant-cost 6)) + + +;;;; 32-bit logical operations + +(define-vop (merge-bits) + (:translate merge-bits) + (:args (shift :scs (signed-reg unsigned-reg)) + (prev :scs (unsigned-reg)) + (next :scs (unsigned-reg))) + (:arg-types tagged-num unsigned-num unsigned-num) + (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) + (:temporary (:scs (unsigned-reg) :to (:result 0) :target result) res) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:policy :fast-safe) + (:generator 4 + (let ((done (gen-label))) + (inst cmpwi shift 0) + (inst beq done) + (inst srw res next shift) + (inst sub temp zero-tn shift) + (inst slw temp prev temp) + (inst or res res temp) + (emit-label done) + (move result res)))) + + +(define-vop (32bit-logical) + (:args (x :scs (unsigned-reg zero)) + (y :scs (unsigned-reg zero))) + (:arg-types unsigned-num unsigned-num) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num) + (:policy :fast-safe)) + +(define-vop (32bit-logical-not 32bit-logical) + (:translate 32bit-logical-not) + (:args (x :scs (unsigned-reg zero))) + (:arg-types unsigned-num) + (:generator 1 + (inst not r x))) + +(define-vop (32bit-logical-and 32bit-logical) + (:translate 32bit-logical-and) + (:generator 1 + (inst and r x y))) + +(deftransform 32bit-logical-nand ((x y) (* *)) + '(32bit-logical-not (32bit-logical-and x y))) + +(define-vop (32bit-logical-or 32bit-logical) + (:translate 32bit-logical-or) + (:generator 1 + (inst or r x y))) + +(deftransform 32bit-logical-nor ((x y) (* *)) + '(32bit-logical-not (32bit-logical-or x y))) + +(define-vop (32bit-logical-xor 32bit-logical) + (:translate 32bit-logical-xor) + (:generator 1 + (inst xor r x y))) + +(define-vop (32bit-logical-eqv 32bit-logical) + (:translate 32bit-logical-eqv) + (:generator 1 + (inst eqv r x y))) + +(define-vop (32bit-logical-orc2 32bit-logical) + (:translate 32bit-logical-orc2) + (:generator 1 + (inst orc r x y))) + +(deftransform 32bit-logical-orc1 ((x y) (* *)) + '(32bit-logical-orc2 y x)) + +(define-vop (32bit-logical-andc2 32bit-logical) + (:translate 32bit-logical-andc2) + (:generator 1 + (inst andc r x y))) + +(deftransform 32bit-logical-andc1 ((x y) (* *)) + '(32bit-logical-andc2 y x)) + + +(define-vop (shift-towards-someplace) + (:policy :fast-safe) + (:args (num :scs (unsigned-reg)) + (amount :scs (signed-reg))) + (:arg-types unsigned-num tagged-num) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num)) + +(define-vop (shift-towards-start shift-towards-someplace) + (:translate shift-towards-start) + (:note "shift-towards-start") + (:generator 1 + (inst rlwinm amount amount 0 27 31) + (inst slw r num amount))) + +(define-vop (shift-towards-end shift-towards-someplace) + (:translate shift-towards-end) + (:note "shift-towards-end") + (:generator 1 + (inst rlwinm amount amount 0 27 31) + (inst srw r num amount))) + + + + +;;;; Bignum stuff. + +(define-vop (bignum-length get-header-data) + (:translate sb!bignum::%bignum-length) + (:policy :fast-safe)) + +(define-vop (bignum-set-length set-header-data) + (:translate sb!bignum::%bignum-set-length) + (:policy :fast-safe)) + +(define-vop (bignum-ref word-index-ref) + (:variant sb!vm:bignum-digits-offset sb!vm:other-pointer-lowtag) + (:translate sb!bignum::%bignum-ref) + (:results (value :scs (unsigned-reg))) + (:result-types unsigned-num)) + +(define-vop (bignum-set word-index-set) + (:variant sb!vm:bignum-digits-offset sb!vm:other-pointer-lowtag) + (:translate sb!bignum::%bignum-set) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg immediate zero)) + (value :scs (unsigned-reg))) + (:arg-types t positive-fixnum unsigned-num) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num)) + +(define-vop (digit-0-or-plus) + (:translate sb!bignum::%digit-0-or-plusp) + (:policy :fast-safe) + (:args (digit :scs (unsigned-reg))) + (:arg-types unsigned-num) + (:results (result :scs (descriptor-reg))) + (:generator 3 + (let ((done (gen-label))) + (inst cmpwi digit 0) + (move result null-tn) + (inst blt done) + (load-symbol result t) + (emit-label done)))) + +(define-vop (add-w/carry) + (:translate sb!bignum::%add-with-carry) + (:policy :fast-safe) + (:args (a :scs (unsigned-reg)) + (b :scs (unsigned-reg)) + (c :scs (any-reg))) + (:arg-types unsigned-num unsigned-num positive-fixnum) + (:temporary (:scs (unsigned-reg)) temp) + (:results (result :scs (unsigned-reg)) + (carry :scs (unsigned-reg))) + (:result-types unsigned-num positive-fixnum) + (:generator 3 + (inst addic temp c -1) + (inst adde result a b) + (inst addze carry zero-tn))) + +(define-vop (sub-w/borrow) + (:translate sb!bignum::%subtract-with-borrow) + (:policy :fast-safe) + (:args (a :scs (unsigned-reg)) + (b :scs (unsigned-reg)) + (c :scs (any-reg))) + (:arg-types unsigned-num unsigned-num positive-fixnum) + (:temporary (:scs (unsigned-reg)) temp) + (:results (result :scs (unsigned-reg)) + (borrow :scs (unsigned-reg))) + (:result-types unsigned-num positive-fixnum) + (:generator 4 + (inst addic temp c -1) + (inst sube result a b) + (inst addze borrow zero-tn))) + +(define-vop (bignum-mult-and-add-3-arg) + (:translate sb!bignum::%multiply-and-add) + (:policy :fast-safe) + (:args (x :scs (unsigned-reg)) + (y :scs (unsigned-reg)) + (carry-in :scs (unsigned-reg) :to (:eval 1))) + (:arg-types unsigned-num unsigned-num unsigned-num) + (:temporary (:scs (unsigned-reg) :to (:result 0) :target hi) hi-temp) + (:temporary (:scs (unsigned-reg) :from (:eval 0) :to (:result 1) + :target lo) lo-temp) + (:results (hi :scs (unsigned-reg)) + (lo :scs (unsigned-reg))) + (:result-types unsigned-num unsigned-num) + (:generator 40 + (inst mulhwu hi-temp x y) + (inst mullw lo-temp x y) + (inst addc lo lo-temp carry-in) + (inst addze hi hi-temp))) + +(define-vop (bignum-mult-and-add-4-arg) + (:translate sb!bignum::%multiply-and-add) + (:policy :fast-safe) + (:args (x :scs (unsigned-reg)) + (y :scs (unsigned-reg)) + (prev :scs (unsigned-reg) :to (:eval 1)) + (carry-in :scs (unsigned-reg) :to (:eval 1))) + (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num) + (:temporary (:scs (unsigned-reg) :to (:result 0) :target hi) hi-temp) + (:temporary (:scs (unsigned-reg) :from (:eval 0) :to (:result 1) + :target lo) lo-temp) + (:results (hi :scs (unsigned-reg)) + (lo :scs (unsigned-reg))) + (:result-types unsigned-num unsigned-num) + (:generator 40 + (inst mulhwu hi-temp x y) + (inst mullw lo-temp x y) + (inst addc lo-temp lo-temp carry-in) + (inst addze hi-temp hi-temp) + (inst addc lo lo-temp prev) + (inst addze hi hi-temp))) + +(define-vop (bignum-mult) + (:translate sb!bignum::%multiply) + (:policy :fast-safe) + (:args (x :scs (unsigned-reg) :to (:result 1)) + (y :scs (unsigned-reg) :to (:result 1))) + (:arg-types unsigned-num unsigned-num) + (:results (hi :scs (unsigned-reg)) + (lo :scs (unsigned-reg))) + (:result-types unsigned-num unsigned-num) + (:generator 40 + (inst mullw lo x y) + (inst mulhwu hi x y))) + +(define-vop (bignum-lognot) + (:translate sb!bignum::%lognot) + (:policy :fast-safe) + (:args (x :scs (unsigned-reg))) + (:arg-types unsigned-num) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 1 + (inst not r x))) + +(define-vop (fixnum-to-digit) + (:translate sb!bignum::%fixnum-to-digit) + (:policy :fast-safe) + (:args (fixnum :scs (any-reg))) + (:arg-types tagged-num) + (:results (digit :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 1 + (inst srawi digit fixnum 2))) + + +(define-vop (bignum-floor) + (:translate sb!bignum::%floor) + (:policy :fast-safe) + (:args (num-high :scs (unsigned-reg) :target rem) + (num-low :scs (unsigned-reg) :target rem-low) + (denom :scs (unsigned-reg) :to (:eval 1))) + (:arg-types unsigned-num unsigned-num unsigned-num) + (:temporary (:scs (unsigned-reg) :from (:argument 1)) rem-low) + (:temporary (:scs (unsigned-reg) :from (:eval 0)) temp) + (:results (quo :scs (unsigned-reg) :from (:eval 0)) + (rem :scs (unsigned-reg) :from (:argument 0))) + (:result-types unsigned-num unsigned-num) + (:generator 325 ; number of inst assuming targeting works. + (move rem num-high) + (move rem-low num-low) + (flet ((maybe-subtract (&optional (guess temp)) + (inst subi temp guess 1) + (inst and temp temp denom) + (inst sub rem rem temp)) + (sltu (res x y) + (inst subfc res y x) + (inst subfe res res res) + (inst neg res res))) + (sltu quo rem denom) + (maybe-subtract quo) + (dotimes (i 32) + (inst slwi rem rem 1) + (inst srwi temp rem-low 31) + (inst or rem rem temp) + (inst slwi rem-low rem-low 1) + (sltu temp rem denom) + (inst slwi quo quo 1) + (inst or quo quo temp) + (maybe-subtract))) + (inst not quo quo))) + +#| + +(define-vop (bignum-floor) + (:translate sb!bignum::%floor) + (:policy :fast-safe) + (:args (div-high :scs (unsigned-reg) :target rem) + (div-low :scs (unsigned-reg) :target quo) + (divisor :scs (unsigned-reg))) + (:arg-types unsigned-num unsigned-num unsigned-num) + (:results (quo :scs (unsigned-reg) :from (:argument 1)) + (rem :scs (unsigned-reg) :from (:argument 0))) + (:result-types unsigned-num unsigned-num) + (:generator 300 + (inst mtmq div-low) + (inst div quo div-high divisor) + (inst mfmq rem))) +|# + +(define-vop (signify-digit) + (:translate sb!bignum::%fixnum-digit-with-correct-sign) + (:policy :fast-safe) + (:args (digit :scs (unsigned-reg) :target res)) + (:arg-types unsigned-num) + (:results (res :scs (any-reg signed-reg))) + (:result-types signed-num) + (:generator 1 + (sc-case res + (any-reg + (inst slwi res digit 2)) + (signed-reg + (move res digit))))) + + +(define-vop (digit-ashr) + (:translate sb!bignum::%ashr) + (:policy :fast-safe) + (:args (digit :scs (unsigned-reg)) + (count :scs (unsigned-reg))) + (:arg-types unsigned-num positive-fixnum) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 1 + (inst sraw result digit count))) + +(define-vop (digit-lshr digit-ashr) + (:translate sb!bignum::%digit-logical-shift-right) + (:generator 1 + (inst srw result digit count))) + +(define-vop (digit-ashl digit-ashr) + (:translate sb!bignum::%ashl) + (:generator 1 + (inst slw result digit count))) + + +;;;; Static funs. + +(define-static-fun two-arg-gcd (x y) :translate gcd) +(define-static-fun two-arg-lcm (x y) :translate lcm) + +(define-static-fun two-arg-+ (x y) :translate +) +(define-static-fun two-arg-- (x y) :translate -) +(define-static-fun two-arg-* (x y) :translate *) +(define-static-fun two-arg-/ (x y) :translate /) + +(define-static-fun two-arg-< (x y) :translate <) +(define-static-fun two-arg-<= (x y) :translate <=) +(define-static-fun two-arg-> (x y) :translate >) +(define-static-fun two-arg->= (x y) :translate >=) +(define-static-fun two-arg-= (x y) :translate =) +(define-static-fun two-arg-/= (x y) :translate /=) + +(define-static-fun %negate (x) :translate %negate) + +(define-static-fun two-arg-and (x y) :translate logand) +(define-static-fun two-arg-ior (x y) :translate logior) +(define-static-fun two-arg-xor (x y) :translate logxor) diff --git a/src/compiler/ppc/array.lisp b/src/compiler/ppc/array.lisp new file mode 100644 index 0000000..8239a8f --- /dev/null +++ b/src/compiler/ppc/array.lisp @@ -0,0 +1,597 @@ +;;; +;;; Written by William Lott +;;; +(in-package "SB!VM") + + +;;;; Allocator for the array header. + +(define-vop (make-array-header) + (:translate make-array-header) + (:policy :fast-safe) + (:args (type :scs (any-reg)) + (rank :scs (any-reg))) + (:arg-types tagged-num tagged-num) + (:temporary (:scs (descriptor-reg) :to (:result 0) :target result) header) + (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:results (result :scs (descriptor-reg))) + (:generator 0 + (pseudo-atomic (pa-flag) + (inst ori header alloc-tn other-pointer-lowtag) + (inst addi ndescr rank (* (1+ array-dimensions-offset) sb!vm:n-word-bytes)) + (inst clrrwi ndescr ndescr n-lowtag-bits) + (inst add alloc-tn alloc-tn ndescr) + (inst addi ndescr rank (fixnumize (1- sb!vm:array-dimensions-offset))) + (inst slwi ndescr ndescr sb!vm:n-widetag-bits) + (inst or ndescr ndescr type) + (inst srwi ndescr ndescr 2) + (storew ndescr header 0 sb!vm:other-pointer-lowtag)) + (move result header))) + + +;;;; Additional accessors and setters for the array header. + +(defknown sb!impl::%array-dimension (t fixnum) fixnum + (flushable)) +(defknown sb!impl::%set-array-dimension (t fixnum fixnum) fixnum + ()) + +(define-vop (%array-dimension word-index-ref) + (:translate sb!impl::%array-dimension) + (:policy :fast-safe) + (:variant sb!vm:array-dimensions-offset sb!vm:other-pointer-lowtag)) + +(define-vop (%set-array-dimension word-index-set) + (:translate sb!impl::%set-array-dimension) + (:policy :fast-safe) + (:variant sb!vm:array-dimensions-offset sb!vm:other-pointer-lowtag)) + + + +(defknown sb!impl::%array-rank (t) fixnum (flushable)) + +(define-vop (array-rank-vop) + (:translate sb!impl::%array-rank) + (:policy :fast-safe) + (:args (x :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) temp) + (:results (res :scs (any-reg descriptor-reg))) + (:generator 6 + (loadw temp x 0 sb!vm:other-pointer-lowtag) + (inst srawi temp temp sb!vm:n-widetag-bits) + (inst subi temp temp (1- sb!vm:array-dimensions-offset)) + (inst slwi res temp 2))) + + + +;;;; Bounds checking routine. + + +(define-vop (check-bound) + (:translate %check-bound) + (:policy :fast-safe) + (:args (array :scs (descriptor-reg)) + (bound :scs (any-reg descriptor-reg)) + (index :scs (any-reg descriptor-reg) :target result)) + (:results (result :scs (any-reg descriptor-reg))) + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (let ((error (generate-error-code vop invalid-array-index-error + array bound index))) + (inst cmplw index bound) + (inst bge error) + (move result index)))) + + + +;;;; Accessors/Setters + +;;; Variants built on top of word-index-ref, etc. I.e. those vectors whos +;;; elements are represented in integer registers and are built out of +;;; 8, 16, or 32 bit elements. + +(macrolet ((def-data-vector-frobs (type variant element-type &rest scs) + `(progn + (define-vop (,(intern (concatenate 'simple-string + "DATA-VECTOR-REF/" + (string type))) + ,(intern (concatenate 'simple-string + (string variant) + "-REF"))) + (:note "inline array access") + (:variant sb!vm:vector-data-offset sb!vm:other-pointer-lowtag) + (:translate data-vector-ref) + (:arg-types ,type positive-fixnum) + (:results (value :scs ,scs)) + (:result-types ,element-type)) + (define-vop (,(intern (concatenate 'simple-string + "DATA-VECTOR-SET/" + (string type))) + ,(intern (concatenate 'simple-string + (string variant) + "-SET"))) + (:note "inline array store") + (:variant sb!vm:vector-data-offset sb!vm:other-pointer-lowtag) + (:translate data-vector-set) + (:arg-types ,type positive-fixnum ,element-type) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg zero immediate)) + (value :scs ,scs)) + (:results (result :scs ,scs)) + (:result-types ,element-type))))) + (def-data-vector-frobs simple-string byte-index + base-char base-char-reg) + (def-data-vector-frobs simple-vector word-index + * descriptor-reg any-reg) + + (def-data-vector-frobs simple-array-unsigned-byte-8 byte-index + positive-fixnum unsigned-reg) + (def-data-vector-frobs simple-array-unsigned-byte-16 halfword-index + positive-fixnum unsigned-reg) + (def-data-vector-frobs simple-array-unsigned-byte-32 word-index + unsigned-num unsigned-reg) + + (def-data-vector-frobs simple-array-signed-byte-30 word-index + tagged-num any-reg) + (def-data-vector-frobs simple-array-signed-byte-32 word-index + signed-num signed-reg)) + + +;;; Integer vectors whos elements are smaller than a byte. I.e. bit, 2-bit, +;;; and 4-bit vectors. +;;; + +(macrolet ((def-small-data-vector-frobs (type bits) + (let* ((elements-per-word (floor sb!vm:n-word-bits bits)) + (bit-shift (1- (integer-length elements-per-word)))) + `(progn + (define-vop (,(symbolicate 'data-vector-ref/ type)) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (unsigned-reg))) + (:arg-types ,type positive-fixnum) + (:results (value :scs (any-reg))) + (:result-types positive-fixnum) + (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp result) + (:generator 20 + (inst srwi temp index ,bit-shift) + (inst slwi temp temp 2) + (inst addi temp temp (- (* sb!vm:vector-data-offset sb!vm:n-word-bytes) + sb!vm:other-pointer-lowtag)) + (inst lwzx result object temp) + (inst andi. temp index ,(1- elements-per-word)) + (inst xori temp temp ,(1- elements-per-word)) + ,@(unless (= bits 1) + `((inst slwi temp temp ,(1- (integer-length bits))))) + (inst srw result result temp) + (inst andi. result result ,(1- (ash 1 bits))) + (inst slwi value result 2))) + (define-vop (,(symbolicate 'data-vector-ref-c/ type)) + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:arg-types ,type (:constant index)) + (:info index) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 15 + (multiple-value-bind (word extra) (floor index ,elements-per-word) + (setf extra (logxor extra (1- ,elements-per-word))) + (let ((offset (- (* (+ word sb!vm:vector-data-offset) sb!vm:n-word-bytes) + sb!vm:other-pointer-lowtag))) + (cond ((typep offset '(signed-byte 16)) + (inst lwz result object offset)) + (t + (inst lr temp offset) + (inst lwzx result object temp)))) + (unless (zerop extra) + (inst srwi result result + (logxor (* extra ,bits) ,(1- elements-per-word)))) + (unless (= extra ,(1- elements-per-word)) + (inst andi. result result ,(1- (ash 1 bits))))))) + (define-vop (,(symbolicate 'data-vector-set/ type)) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (unsigned-reg) :target shift) + (value :scs (unsigned-reg zero immediate) :target result)) + (:arg-types ,type positive-fixnum positive-fixnum) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:temporary (:scs (non-descriptor-reg)) temp old offset) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) shift) + (:generator 25 + (inst srwi offset index ,bit-shift) + (inst slwi offset offset 2) + (inst addi offset offset (- (* sb!vm:vector-data-offset sb!vm:n-word-bytes) + sb!vm:other-pointer-lowtag)) + (inst lwzx old object offset) + (inst andi. shift index ,(1- elements-per-word)) + (inst xori shift shift ,(1- elements-per-word)) + ,@(unless (= bits 1) + `((inst slwi shift shift ,(1- (integer-length bits))))) + (unless (and (sc-is value immediate) + (= (tn-value value) ,(1- (ash 1 bits)))) + (inst lr temp ,(1- (ash 1 bits))) + (inst slw temp temp shift) + (inst not temp temp) + (inst and old old temp)) + (unless (sc-is value zero) + (sc-case value + (immediate + (inst lr temp (logand (tn-value value) ,(1- (ash 1 bits))))) + (unsigned-reg + (inst andi. temp value ,(1- (ash 1 bits))))) + (inst slw temp temp shift) + (inst or old old temp)) + (inst stwx old object offset) + (sc-case value + (immediate + (inst lr result (tn-value value))) + (t + (move result value))))) + (define-vop (,(symbolicate 'data-vector-set-c/ type)) + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (value :scs (unsigned-reg zero immediate) :target result)) + (:arg-types ,type + (:constant index) + positive-fixnum) + (:info index) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:temporary (:scs (non-descriptor-reg)) offset-reg temp old) + (:generator 20 + (multiple-value-bind (word extra) (floor index ,elements-per-word) + (let ((offset (- (* (+ word sb!vm:vector-data-offset) sb!vm:n-word-bytes) + sb!vm:other-pointer-lowtag))) + (cond ((typep offset '(signed-byte 16)) + (inst lwz old object offset)) + (t + (inst lr offset-reg offset) + (inst lwzx old object offset-reg))) + (unless (and (sc-is value immediate) + (= (tn-value value) ,(1- (ash 1 bits)))) + (cond ((zerop extra) + (inst slwi old old ,bits) + (inst srwi old old ,bits)) + (t + (inst lr temp + (lognot (ash ,(1- (ash 1 bits)) + (* (logxor extra + ,(1- elements-per-word)) + ,bits)))) + (inst and old old temp)))) + (sc-case value + (zero) + (immediate + (let ((value (ash (logand (tn-value value) + ,(1- (ash 1 bits))) + (* (logxor extra + ,(1- elements-per-word)) + ,bits)))) + (cond ((typep value '(unsigned-byte 16)) + (inst ori old old value)) + (t + (inst lr temp value) + (inst or old old temp))))) + (unsigned-reg + (inst slwi temp value + (* (logxor extra ,(1- elements-per-word)) ,bits)) + (inst or old old temp))) + (if (typep offset '(signed-byte 16)) + (inst stw old object offset) + (inst stwx old object offset-reg))) + (sc-case value + (immediate + (inst lr result (tn-value value))) + (t + (move result value)))))))))) + (def-small-data-vector-frobs simple-bit-vector 1) + (def-small-data-vector-frobs simple-array-unsigned-byte-2 2) + (def-small-data-vector-frobs simple-array-unsigned-byte-4 4)) + + +;;; And the float variants. +;;; + +(define-vop (data-vector-ref/simple-array-single-float) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types simple-array-single-float positive-fixnum) + (:results (value :scs (single-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:result-types single-float) + (:generator 5 + (inst addi offset index (- (* sb!vm:vector-data-offset sb!vm:n-word-bytes) + sb!vm:other-pointer-lowtag)) + (inst lfsx value object offset))) + + +(define-vop (data-vector-set/simple-array-single-float) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (single-reg) :target result)) + (:arg-types simple-array-single-float positive-fixnum single-float) + (:results (result :scs (single-reg))) + (:result-types single-float) + (:temporary (:scs (non-descriptor-reg)) offset) + (:generator 5 + (inst addi offset index + (- (* sb!vm:vector-data-offset sb!vm:n-word-bytes) + sb!vm:other-pointer-lowtag)) + (inst stfsx value object offset) + (unless (location= result value) + (inst frsp result value)))) + +(define-vop (data-vector-ref/simple-array-double-float) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types simple-array-double-float positive-fixnum) + (:results (value :scs (double-reg))) + (:result-types double-float) + (:temporary (:scs (non-descriptor-reg)) offset) + (:generator 7 + (inst slwi offset index 1) + (inst addi offset offset (- (* sb!vm:vector-data-offset sb!vm:n-word-bytes) + sb!vm:other-pointer-lowtag)) + (inst lfdx value object offset))) + +(define-vop (data-vector-set/simple-array-double-float) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (double-reg) :target result)) + (:arg-types simple-array-double-float positive-fixnum double-float) + (:results (result :scs (double-reg))) + (:result-types double-float) + (:temporary (:scs (non-descriptor-reg)) offset) + (:generator 20 + (inst slwi offset index 1) + (inst addi offset offset (- (* sb!vm:vector-data-offset sb!vm:n-word-bytes) + sb!vm:other-pointer-lowtag)) + (inst stfdx value object offset) + (unless (location= result value) + (inst fmr result value)))) + + +;;; Complex float arrays. + +(define-vop (data-vector-ref/simple-array-complex-single-float) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types simple-array-complex-single-float positive-fixnum) + (:results (value :scs (complex-single-reg))) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset) + (:result-types complex-single-float) + (:generator 5 + (let ((real-tn (complex-single-reg-real-tn value))) + (inst slwi offset index 1) + (inst addi offset offset (- (* sb!vm:vector-data-offset sb!vm:n-word-bytes) + sb!vm:other-pointer-lowtag)) + (inst lfsx real-tn object offset)) + (let ((imag-tn (complex-single-reg-imag-tn value))) + (inst addi offset offset sb!vm:n-word-bytes) + (inst lfsx imag-tn object offset)))) + +(define-vop (data-vector-set/simple-array-complex-single-float) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (complex-single-reg) :target result)) + (:arg-types simple-array-complex-single-float positive-fixnum + complex-single-float) + (:results (result :scs (complex-single-reg))) + (:result-types complex-single-float) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset) + (:generator 5 + (let ((value-real (complex-single-reg-real-tn value)) + (result-real (complex-single-reg-real-tn result))) + (inst slwi offset index 1) + (inst addi offset offset (- (* sb!vm:vector-data-offset sb!vm:n-word-bytes) + sb!vm:other-pointer-lowtag)) + (inst stfsx value-real object offset) + (unless (location= result-real value-real) + (inst frsp result-real value-real))) + (let ((value-imag (complex-single-reg-imag-tn value)) + (result-imag (complex-single-reg-imag-tn result))) + (inst addi offset offset sb!vm:n-word-bytes) + (inst stfsx value-imag object offset) + (unless (location= result-imag value-imag) + (inst frsp result-imag value-imag))))) + + +(define-vop (data-vector-ref/simple-array-complex-double-float) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (index :scs (any-reg))) + (:arg-types simple-array-complex-double-float positive-fixnum) + (:results (value :scs (complex-double-reg))) + (:result-types complex-double-float) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset) + (:generator 7 + (let ((real-tn (complex-double-reg-real-tn value))) + (inst slwi offset index 2) + (inst addi offset offset (- (* sb!vm:vector-data-offset sb!vm:n-word-bytes) + sb!vm:other-pointer-lowtag)) + (inst lfdx real-tn object offset)) + (let ((imag-tn (complex-double-reg-imag-tn value))) + (inst addi offset offset (* 2 sb!vm:n-word-bytes)) + (inst lfdx imag-tn object offset)))) + +(define-vop (data-vector-set/simple-array-complex-double-float) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (index :scs (any-reg)) + (value :scs (complex-double-reg) :target result)) + (:arg-types simple-array-complex-double-float positive-fixnum + complex-double-float) + (:results (result :scs (complex-double-reg))) + (:result-types complex-double-float) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset) + (:generator 20 + (let ((value-real (complex-double-reg-real-tn value)) + (result-real (complex-double-reg-real-tn result))) + (inst slwi offset index 2) + (inst addi offset offset (- (* sb!vm:vector-data-offset sb!vm:n-word-bytes) + sb!vm:other-pointer-lowtag)) + (inst stfdx value-real object offset) + (unless (location= result-real value-real) + (inst fmr result-real value-real))) + (let ((value-imag (complex-double-reg-imag-tn value)) + (result-imag (complex-double-reg-imag-tn result))) + (inst addi offset offset (* 2 sb!vm:n-word-bytes)) + (inst stfdx value-imag object offset) + (unless (location= result-imag value-imag) + (inst fmr result-imag value-imag))))) + + +;;; These VOPs are used for implementing float slots in structures (whose raw +;;; data is an unsigned-32 vector. +;;; +(define-vop (raw-ref-single data-vector-ref/simple-array-single-float) + (:translate %raw-ref-single) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum)) +;;; +(define-vop (raw-set-single data-vector-set/simple-array-single-float) + (:translate %raw-set-single) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum single-float)) +;;; +(define-vop (raw-ref-double data-vector-ref/simple-array-double-float) + (:translate %raw-ref-double) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum)) +;;; +(define-vop (raw-set-double data-vector-set/simple-array-double-float) + (:translate %raw-set-double) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum double-float)) + +(define-vop (raw-ref-complex-single + data-vector-ref/simple-array-complex-single-float) + (:translate %raw-ref-complex-single) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum)) +;;; +(define-vop (raw-set-complex-single + data-vector-set/simple-array-complex-single-float) + (:translate %raw-set-complex-single) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum + complex-single-float)) +;;; +(define-vop (raw-ref-complex-double + data-vector-ref/simple-array-complex-double-float) + (:translate %raw-ref-complex-double) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum)) +;;; +(define-vop (raw-set-complex-double + data-vector-set/simple-array-complex-double-float) + (:translate %raw-set-complex-double) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum + complex-double-float)) + + +;;; These vops are useful for accessing the bits of a vector irrespective of +;;; what type of vector it is. +;;; + +(define-vop (raw-bits word-index-ref) + (:note "raw-bits VOP") + (:translate %raw-bits) + (:results (value :scs (unsigned-reg))) + (:result-types unsigned-num) + (:variant 0 sb!vm:other-pointer-lowtag)) + +(define-vop (set-raw-bits word-index-set) + (:note "setf raw-bits VOP") + (:translate %set-raw-bits) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg zero immediate)) + (value :scs (unsigned-reg))) + (:arg-types * positive-fixnum unsigned-num) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:variant 0 sb!vm:other-pointer-lowtag)) + + + +;;;; Misc. Array VOPs. + + +#+nil +(define-vop (vector-word-length) + (:args (vec :scs (descriptor-reg))) + (:results (res :scs (any-reg descriptor-reg))) + (:generator 6 + (loadw res vec clc::g-vector-header-words) + (inst niuo res res clc::g-vector-words-mask-16))) + +(define-vop (get-vector-subtype get-header-data)) +(define-vop (set-vector-subtype set-header-data)) + + +;;; + +(define-vop (data-vector-ref/simple-array-signed-byte-8 signed-byte-index-ref) + (:note "inline array access") + (:variant sb!vm:vector-data-offset sb!vm:other-pointer-lowtag) + (:translate data-vector-ref) + (:arg-types simple-array-signed-byte-8 positive-fixnum) + (:results (value :scs (signed-reg))) + (:result-types tagged-num)) + +(define-vop (data-vector-set/simple-array-signed-byte-8 byte-index-set) + (:note "inline array store") + (:variant sb!vm:vector-data-offset sb!vm:other-pointer-lowtag) + (:translate data-vector-set) + (:arg-types simple-array-signed-byte-8 positive-fixnum tagged-num) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg zero immediate)) + (value :scs (signed-reg))) + (:results (result :scs (signed-reg))) + (:result-types tagged-num)) + +(define-vop (data-vector-ref/simple-array-signed-byte-16 + signed-halfword-index-ref) + (:note "inline array access") + (:variant sb!vm:vector-data-offset sb!vm:other-pointer-lowtag) + (:translate data-vector-ref) + (:arg-types simple-array-signed-byte-16 positive-fixnum) + (:results (value :scs (signed-reg))) + (:result-types tagged-num)) + +(define-vop (data-vector-set/simple-array-signed-byte-16 halfword-index-set) + (:note "inline array store") + (:variant sb!vm:vector-data-offset sb!vm:other-pointer-lowtag) + (:translate data-vector-set) + (:arg-types simple-array-signed-byte-16 positive-fixnum tagged-num) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg zero immediate)) + (value :scs (signed-reg))) + (:results (result :scs (signed-reg))) + (:result-types tagged-num)) + diff --git a/src/compiler/ppc/backend-parms.lisp b/src/compiler/ppc/backend-parms.lisp new file mode 100644 index 0000000..30f38e4 --- /dev/null +++ b/src/compiler/ppc/backend-parms.lisp @@ -0,0 +1,8 @@ +(in-package "SB!VM") + +(setf *backend-fasl-file-type* "fasl") +(defconstant +backend-fasl-file-implementation+ :ppc) +(setf *backend-register-save-penalty* 3) +(setf *backend-byte-order* :big-endian) +(setf *backend-page-size* 4096) + diff --git a/src/compiler/ppc/c-call.lisp b/src/compiler/ppc/c-call.lisp new file mode 100644 index 0000000..020a9b1 --- /dev/null +++ b/src/compiler/ppc/c-call.lisp @@ -0,0 +1,168 @@ +;;; routines for call-out to C. +;;; +;;; Written by William Lott. +;;; +(in-package "SB!VM") + +(defun my-make-wired-tn (prim-type-name sc-name offset) + (make-wired-tn (primitive-type-or-lose prim-type-name) + (sc-number-or-lose sc-name) + offset)) + +(defstruct arg-state + (gpr-args 0) + (fpr-args 0) + ;SVR4 [a]abi wants two words on stack (callee saved lr, backpointer). + (stack-frame-size 2)) + +(defun int-arg (state prim-type reg-sc stack-sc) + (let ((reg-args (arg-state-gpr-args state))) + (cond ((< reg-args 8) + (setf (arg-state-gpr-args state) (1+ reg-args)) + (my-make-wired-tn prim-type reg-sc (+ reg-args nl0-offset))) + (t + (let ((frame-size (arg-state-stack-frame-size state))) + (setf (arg-state-stack-frame-size state) (1+ frame-size)) + (my-make-wired-tn prim-type stack-sc frame-size)))))) + +(define-alien-type-method (integer :arg-tn) (type state) + (if (alien-integer-type-signed type) + (int-arg state 'signed-byte-32 'signed-reg 'signed-stack) + (int-arg state 'unsigned-byte-32 'unsigned-reg 'unsigned-stack))) + +(define-alien-type-method (system-area-pointer :arg-tn) (type state) + (declare (ignore type)) + (int-arg state 'system-area-pointer 'sap-reg 'sap-stack)) + +; If a single-float arg has to go on the stack, it's promoted to +; double. That way, C programs can get subtle rounding errors +; when unrelated arguments are introduced. + +(define-alien-type-method (single-float :arg-tn) (type state) + (declare (ignore type)) + (let* ((fprs (arg-state-fpr-args state))) + (cond ((< fprs 8) + (incf (arg-state-fpr-args state)) + ; Assign outgoing FPRs starting at FP1 + (my-make-wired-tn 'single-float 'single-reg (1+ fprs))) + (t + (let* ((stack-offset (arg-state-stack-frame-size state))) + (if (oddp stack-offset) + (incf stack-offset)) + (setf (arg-state-stack-frame-size state) (+ stack-offset 2)) + (my-make-wired-tn 'double-float 'double-stack stack-offset)))))) + +(define-alien-type-method (double-float :arg-tn) (type state) + (declare (ignore type)) + (let* ((fprs (arg-state-fpr-args state))) + (cond ((< fprs 8) + (incf (arg-state-fpr-args state)) + ; Assign outgoing FPRs starting at FP1 + (my-make-wired-tn 'double-float 'double-reg (1+ fprs))) + (t + (let* ((stack-offset (arg-state-stack-frame-size state))) + (if (oddp stack-offset) + (incf stack-offset)) + (setf (arg-state-stack-frame-size state) (+ stack-offset 2)) + (my-make-wired-tn 'double-float 'double-stack stack-offset)))))) + +(define-alien-type-method (integer :result-tn) (type) + (if (alien-integer-type-signed type) + (my-make-wired-tn 'signed-byte-32 'signed-reg nl0-offset) + (my-make-wired-tn 'unsigned-byte-32 'unsigned-reg nl0-offset))) + + +(define-alien-type-method (system-area-pointer :result-tn) (type) + (declare (ignore type)) + (my-make-wired-tn 'system-area-pointer 'sap-reg nl0-offset)) + +(define-alien-type-method (single-float :result-tn) (type) + (declare (ignore type)) + (my-make-wired-tn 'single-float 'single-reg 1)) + +(define-alien-type-method (double-float :result-tn) (type) + (declare (ignore type)) + (my-make-wired-tn 'double-float 'double-reg 1)) + +(define-alien-type-method (values :result-tn) (type) + (mapcar #'(lambda (type) + (invoke-alien-type-method :result-tn type)) + (alien-values-type-values type))) + + +(!def-vm-support-routine make-call-out-tns (type) + (declare (type alien-fun-type type)) + (let ((arg-state (make-arg-state))) + (collect ((arg-tns)) + (dolist (arg-type (alien-fun-type-arg-types type)) + (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state))) + (values (my-make-wired-tn 'positive-fixnum 'any-reg nsp-offset) + (* (arg-state-stack-frame-size arg-state) n-word-bytes) + (arg-tns) + (invoke-alien-type-method + :result-tn + (alien-fun-type-result-type type)))))) + + +(define-vop (foreign-symbol-address) + (:translate foreign-symbol-address) + (:policy :fast-safe) + (:args) + (:arg-types (:constant simple-string)) + (:info foreign-symbol) + (:results (res :scs (sap-reg))) + (:result-types system-area-pointer) + (:generator 2 + (inst lr res (make-fixup foreign-symbol :foreign)))) + +(define-vop (call-out) + (:args (function :scs (sap-reg) :target cfunc) + (args :more t)) + (:results (results :more t)) + (:ignore args results) + (:save-p t) + (:temporary (:sc any-reg :offset cfunc-offset + :from (:argument 0) :to (:result 0)) cfunc) + (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) + (:temporary (:scs (non-descriptor-reg)) temp) + (:vop-var vop) + (:generator 0 + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (store-stack-tn nfp-save cur-nfp)) + (inst lr temp (make-fixup "call_into_c" :foreign)) + (inst mtctr temp) + (move cfunc function) + (inst bctrl) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save))))) + + +(define-vop (alloc-number-stack-space) + (:info amount) + (:results (result :scs (sap-reg any-reg))) + (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) + (:generator 0 + (unless (zerop amount) + (let ((delta (- (logandc2 (+ amount 8 7) 7)))) + (cond ((>= delta (ash -1 16)) + (inst stwu nsp-tn nsp-tn delta)) + (t + (inst lr temp delta) + (inst stwux nsp-tn nsp-tn temp))))) + (unless (location= result nsp-tn) + ;; They are only location= when the result tn was allocated by + ;; make-call-out-tns above, which takes the number-stack-displacement + ;; into account itself. + (inst addi result nsp-tn number-stack-displacement)))) + +(define-vop (dealloc-number-stack-space) + (:info amount) + (:policy :fast-safe) + (:generator 0 + (unless (zerop amount) + (let ((delta (logandc2 (+ amount 8 7) 7))) + (cond ((< delta (ash 1 16)) + (inst addi nsp-tn nsp-tn delta)) + (t + (inst lwz nsp-tn nsp-tn 0))))))) diff --git a/src/compiler/ppc/call.lisp b/src/compiler/ppc/call.lisp new file mode 100644 index 0000000..2087a31 --- /dev/null +++ b/src/compiler/ppc/call.lisp @@ -0,0 +1,1260 @@ +;;;; the VM definition of function call for the PPC + +;;;; 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") + +;;;; Interfaces to IR2 conversion: + +;;; Return a wired TN describing the N'th full call argument passing +;;; location. +;;; +(!def-vm-support-routine standard-arg-location (n) + (declare (type unsigned-byte n)) + (if (< n register-arg-count) + (make-wired-tn *backend-t-primitive-type* register-arg-scn + (elt *register-arg-offsets* n)) + (make-wired-tn *backend-t-primitive-type* control-stack-arg-scn n))) + + +;;; Make a passing location TN for a local call return PC. If +;;; standard is true, then use the standard (full call) location, +;;; otherwise use any legal location. Even in the non-standard case, +;;; this may be restricted by a desire to use a subroutine call +;;; instruction. +;;; +(!def-vm-support-routine make-return-pc-passing-location (standard) + (if standard + (make-wired-tn *backend-t-primitive-type* register-arg-scn lra-offset) + (make-restricted-tn *backend-t-primitive-type* register-arg-scn))) + +;;; Make-Old-FP-Passing-Location -- Interface +;;; +;;; Similar to Make-Return-PC-Passing-Location, but makes a location to pass +;;; Old-FP in. This is (obviously) wired in the standard convention, but is +;;; totally unrestricted in non-standard conventions, since we can always fetch +;;; it off of the stack using the arg pointer. +;;; +(!def-vm-support-routine make-old-fp-passing-location (standard) + (if standard + (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ocfp-offset) + (make-normal-tn *fixnum-primitive-type*))) + +;;; Make-Old-FP-Save-Location, Make-Return-PC-Save-Location -- Interface +;;; +;;; Make the TNs used to hold Old-FP and Return-PC within the current +;;; function. We treat these specially so that the debugger can find them at a +;;; known location. +;;; +(!def-vm-support-routine make-old-fp-save-location (env) + (specify-save-tn + (physenv-debug-live-tn (make-normal-tn *fixnum-primitive-type*) env) + (make-wired-tn *fixnum-primitive-type* + control-stack-arg-scn + ocfp-save-offset))) +;;; +(!def-vm-support-routine make-return-pc-save-location (env) + (specify-save-tn + (physenv-debug-live-tn (make-normal-tn *backend-t-primitive-type*) env) + (make-wired-tn *backend-t-primitive-type* + control-stack-arg-scn + lra-save-offset))) + +;;; Make a TN for the standard argument count passing location. We +;;; only need to make the standard location, since a count is never +;;; passed when we are using non-standard conventions. +(!def-vm-support-routine make-arg-count-location () + (make-wired-tn *fixnum-primitive-type* immediate-arg-scn nargs-offset)) + + +;;; Make a TN to hold the number-stack frame pointer. This is +;;; allocated once per component, and is component-live. +(!def-vm-support-routine make-nfp-tn () + (component-live-tn + (make-wired-tn *fixnum-primitive-type* immediate-arg-scn nfp-offset))) + +(!def-vm-support-routine make-stack-pointer-tn () + (make-normal-tn *fixnum-primitive-type*)) + +(!def-vm-support-routine make-number-stack-pointer-tn () + (make-normal-tn *fixnum-primitive-type*)) + +;;; Make-Unknown-Values-Locations -- Interface +;;; +;;; Return a list of TNs that can be used to represent an unknown-values +;;; continuation within a function. +;;; +(!def-vm-support-routine make-unknown-values-locations () + (list (make-stack-pointer-tn) + (make-normal-tn *fixnum-primitive-type*))) + + +;;; Select-Component-Format -- Interface +;;; +;;; This function is called by the Entry-Analyze phase, allowing +;;; VM-dependent initialization of the IR2-Component structure. We push +;;; placeholder entries in the Constants to leave room for additional +;;; noise in the code object header. +;;; +(!def-vm-support-routine select-component-format (component) + (declare (type component component)) + (dotimes (i code-constants-offset) + (vector-push-extend nil + (ir2-component-constants (component-info component)))) + (values)) + + +;;;; Frame hackery: + +;;; Return the number of bytes needed for the current non-descriptor stack +;;; frame. Non-descriptor stack frames must be multiples of 16 bytes under +;;; the PPC SVr4 ABI (though the EABI may be less restrictive.) Two words +;;; are reserved for the stack backlink and saved LR (see SB!VM::NUMBER-STACK- +;;; DISPLACEMENT.) +;;; +;;; Duh. PPC Linux (and VxWorks) adhere to the EABI. + +;;; this is the first function in this file that differs materially from +;;; ../alpha/call.lisp +(defun bytes-needed-for-non-descriptor-stack-frame () + (logandc2 (+ 7 number-stack-displacement + (* (sb-allocated-size 'non-descriptor-stack) sb!vm:n-word-bytes)) + 7)) + + +;;; Used for setting up the Old-FP in local call. +;;; +(define-vop (current-fp) + (:results (val :scs (any-reg))) + (:generator 1 + (move val cfp-tn))) + +;;; Used for computing the caller's NFP for use in known-values return. Only +;;; works assuming there is no variable size stuff on the nstack. +;;; +(define-vop (compute-old-nfp) + (:results (val :scs (any-reg))) + (:vop-var vop) + (:generator 1 + (let ((nfp (current-nfp-tn vop))) + (when nfp + (inst addi val nfp (bytes-needed-for-non-descriptor-stack-frame)))))) + + +(define-vop (xep-allocate-frame) + (:info start-lab copy-more-arg-follows) + (:ignore copy-more-arg-follows) + (:vop-var vop) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 1 + ;; Make sure the function is aligned, and drop a label pointing to this + ;; function header. + (align n-lowtag-bits) + (trace-table-entry trace-table-fun-prologue) + (emit-label start-lab) + ;; Allocate function header. + (inst simple-fun-header-word) + (dotimes (i (1- sb!vm:simple-fun-code-offset)) + (inst word 0)) + (let* ((entry-point (gen-label))) + (emit-label entry-point) + (inst compute-code-from-fn code-tn lip-tn entry-point temp)) + ;; FIXME alpha port has a ### note here saying we should "save it + ;; on the stack" so that GC sees it. No idea what "it" is -dan 20020110 + ;; Build our stack frames. + (inst addi csp-tn cfp-tn + (* n-word-bytes (sb-allocated-size 'control-stack))) + (let ((nfp-tn (current-nfp-tn vop))) + (when nfp-tn + (let* ((nbytes (bytes-needed-for-non-descriptor-stack-frame))) + (when (> nbytes number-stack-displacement) + (inst stwu nsp-tn nsp-tn (- nbytes)) + (inst addi nfp-tn nsp-tn number-stack-displacement))))) + (trace-table-entry trace-table-normal))) + +(define-vop (allocate-frame) + (:results (res :scs (any-reg)) + (nfp :scs (any-reg))) + (:info callee) + (:generator 2 + (trace-table-entry trace-table-fun-prologue) + (move res csp-tn) + (inst addi csp-tn csp-tn + (* n-word-bytes (sb-allocated-size 'control-stack))) + (when (ir2-physenv-number-stack-p callee) + (let* ((nbytes (bytes-needed-for-non-descriptor-stack-frame))) + (when (> nbytes number-stack-displacement) + (inst stwu nsp-tn nsp-tn (- (bytes-needed-for-non-descriptor-stack-frame))) + (inst addi nfp nsp-tn number-stack-displacement)))) + (trace-table-entry trace-table-normal))) + +;;; Allocate a partial frame for passing stack arguments in a full call. Nargs +;;; is the number of arguments passed. If no stack arguments are passed, then +;;; we don't have to do anything. +;;; +(define-vop (allocate-full-call-frame) + (:info nargs) + (:results (res :scs (any-reg))) + (:generator 2 + (when (> nargs register-arg-count) + (move res csp-tn) + (inst addi csp-tn csp-tn (* nargs n-word-bytes))))) + + +;;; Emit code needed at the return-point from an unknown-values call +;;; for a fixed number of values. Values is the head of the TN-Ref +;;; list for the locations that the values are to be received into. +;;; Nvals is the number of values that are to be received (should +;;; equal the length of Values). +;;; +;;; Move-Temp is a Descriptor-Reg TN used as a temporary. +;;; +;;; This code exploits the fact that in the unknown-values convention, +;;; a single value return returns at the return PC + 8, whereas a +;;; return of other than one value returns directly at the return PC. +;;; +;;; If 0 or 1 values are expected, then we just emit an instruction to +;;; reset the SP (which will only be executed when other than 1 value +;;; is returned.) +;;; +;;; In the general case, we have to do three things: +;;; -- Default unsupplied register values. This need only be done when a +;;; single value is returned, since register values are defaulted by the +;;; callee in the non-single case. +;;; -- Default unsupplied stack values. This needs to be done whenever there +;;; are stack values. +;;; -- Reset SP. This must be done whenever other than 1 value is returned, +;;; regardless of the number of values desired. +;;; +;;; The general-case code looks like this: +#| + b regs-defaulted ; Skip if MVs + nop + + move a1 null-tn ; Default register values + ... + loadi nargs 1 ; Force defaulting of stack values + move old-fp csp ; Set up args for SP resetting + +regs-defaulted + subcc temp nargs register-arg-count + + b :lt default-value-7 ; jump to default code + loadw move-temp ocfp-tn 6 ; Move value to correct location. + subcc temp 1 + store-stack-tn val4-tn move-temp + + b :lt default-value-8 + loadw move-temp ocfp-tn 7 + subcc temp 1 + store-stack-tn val5-tn move-temp + + ... + +defaulting-done + move csp ocfp ; Reset SP. + + + +default-value-7 + store-stack-tn val4-tn null-tn ; Nil out 7'th value. (first on stack) + +default-value-8 + store-stack-tn val5-tn null-tn ; Nil out 8'th value. + + ... + + br defaulting-done + nop +|# +;;; differences from alpha: (1) alpha tests for lra-label before +;;; compute-code-from-lra and skips if nil. (2) loop termination is +;;; different when clearing stack defaults + +(defun default-unknown-values (vop values nvals move-temp temp lra-label) + (declare (type (or tn-ref null) values) + (type unsigned-byte nvals) (type tn move-temp temp)) + (if (<= nvals 1) + (progn + (sb!assem:without-scheduling () + (note-this-location vop :single-value-return) + (move csp-tn ocfp-tn) + (inst nop)) + (inst compute-code-from-lra code-tn code-tn lra-label temp)) + (let ((regs-defaulted (gen-label)) + (defaulting-done (gen-label)) + (default-stack-vals (gen-label))) + ;; Branch off to the MV case. + (sb!assem:without-scheduling () + (note-this-location vop :unknown-return) + (if (> nvals register-arg-count) + (inst addic. temp nargs-tn (- (fixnumize register-arg-count))) + (move csp-tn ocfp-tn)) + (inst b regs-defaulted)) + + ;; Do the single value case. + (do ((i 1 (1+ i)) + (val (tn-ref-across values) (tn-ref-across val))) + ((= i (min nvals register-arg-count))) + (move (tn-ref-tn val) null-tn)) + (when (> nvals register-arg-count) + (move ocfp-tn csp-tn) + (inst b default-stack-vals)) + + (emit-label regs-defaulted) + (when (> nvals register-arg-count) + (collect ((defaults)) + (do ((i register-arg-count (1+ i)) + (val (do ((i 0 (1+ i)) + (val values (tn-ref-across val))) + ((= i register-arg-count) val)) + (tn-ref-across val))) + ((null val)) + + (let ((default-lab (gen-label)) + (tn (tn-ref-tn val))) + (defaults (cons default-lab tn)) + + (inst lwz move-temp ocfp-tn (* i n-word-bytes)) + (inst ble default-lab) + (inst addic. temp temp (- (fixnumize 1))) + (store-stack-tn tn move-temp))) + + (emit-label defaulting-done) + (move csp-tn ocfp-tn) + + (let ((defaults (defaults))) + (when defaults + (assemble (*elsewhere*) + (emit-label default-stack-vals) + (trace-table-entry trace-table-fun-prologue) + (do ((remaining defaults (cdr remaining))) + ((null remaining)) + (let ((def (car remaining))) + (emit-label (car def)) + (when (null (cdr remaining)) + (inst b defaulting-done)) + (store-stack-tn (cdr def) null-tn))) + (trace-table-entry trace-table-normal)))))) + + (inst compute-code-from-lra code-tn code-tn lra-label temp))) + (values)) + + +;;;; Unknown values receiving: + +;;; Receive-Unknown-Values -- Internal +;;; +;;; Emit code needed at the return point for an unknown-values call for an +;;; arbitrary number of values. +;;; +;;; We do the single and non-single cases with no shared code: there doesn't +;;; seem to be any potential overlap, and receiving a single value is more +;;; important efficiency-wise. +;;; +;;; When there is a single value, we just push it on the stack, returning +;;; the old SP and 1. +;;; +;;; When there is a variable number of values, we move all of the argument +;;; registers onto the stack, and return Args and Nargs. +;;; +;;; Args and Nargs are TNs wired to the named locations. We must +;;; explicitly allocate these TNs, since their lifetimes overlap with the +;;; results Start and Count (also, it's nice to be able to target them). +;;; +(defun receive-unknown-values (args nargs start count lra-label temp) + (declare (type tn args nargs start count temp)) + (let ((variable-values (gen-label)) + (done (gen-label))) + (sb!assem:without-scheduling () + (inst b variable-values) + (inst nop)) + + (inst compute-code-from-lra code-tn code-tn lra-label temp) + (inst addi csp-tn csp-tn 4) + (storew (first *register-arg-tns*) csp-tn -1) + (inst subi start csp-tn 4) + (inst li count (fixnumize 1)) + + (emit-label done) + + (assemble (*elsewhere*) + (trace-table-entry trace-table-fun-prologue) + (emit-label variable-values) + (inst compute-code-from-lra code-tn code-tn lra-label temp) + (do ((arg *register-arg-tns* (rest arg)) + (i 0 (1+ i))) + ((null arg)) + (storew (first arg) args i)) + (move start args) + (move count nargs) + (inst b done) + (trace-table-entry trace-table-normal))) + (values)) + + +;;; VOP that can be inherited by unknown values receivers. The main thing this +;;; handles is allocation of the result temporaries. +;;; +(define-vop (unknown-values-receiver) + (:results + (start :scs (any-reg)) + (count :scs (any-reg))) + (:temporary (:sc descriptor-reg :offset ocfp-offset + :from :eval :to (:result 0)) + values-start) + (:temporary (:sc any-reg :offset nargs-offset + :from :eval :to (:result 1)) + nvals) + (:temporary (:scs (non-descriptor-reg)) temp)) + + + +;;;; Local call with unknown values convention return: + +;;; Non-TR local call for a fixed number of values passed according to the +;;; unknown values convention. +;;; +;;; Args are the argument passing locations, which are specified only to +;;; terminate their lifetimes in the caller. +;;; +;;; Values are the return value locations (wired to the standard passing +;;; locations). +;;; +;;; Save is the save info, which we can ignore since saving has been done. +;;; Return-PC is the TN that the return PC should be passed in. +;;; Target is a continuation pointing to the start of the called function. +;;; Nvals is the number of values received. +;;; +;;; Note: we can't use normal load-tn allocation for the fixed args, since all +;;; registers may be tied up by the more operand. Instead, we use +;;; MAYBE-LOAD-STACK-TN. +;;; +(define-vop (call-local) + (:args (fp) + (nfp) + (args :more t)) + (:results (values :more t)) + (:save-p t) + (:move-args :local-call) + (:info arg-locs callee target nvals) + (:vop-var vop) + (:temporary (:scs (descriptor-reg) :from (:eval 0)) move-temp) + (:temporary (:scs (non-descriptor-reg)) temp) + (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) + (:temporary (:sc any-reg :offset ocfp-offset :from (:eval 0)) ocfp) + (:ignore arg-locs args ocfp) + (:generator 5 + (trace-table-entry trace-table-call-site) + (let ((label (gen-label)) + (cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (store-stack-tn nfp-save cur-nfp)) + (let ((callee-nfp (callee-nfp-tn callee))) + (when callee-nfp + (maybe-load-stack-tn callee-nfp nfp))) + (maybe-load-stack-tn cfp-tn fp) + (inst compute-lra-from-code + (callee-return-pc-tn callee) code-tn label temp) + (note-this-location vop :call-site) + (inst b target) + (emit-return-pc label) + (default-unknown-values vop values nvals move-temp temp label) + ;; alpha uses (maybe-load-stack-nfp-tn cur-nfp nfp-save temp) + ;; instead of the clause below + (when cur-nfp + (load-stack-tn cur-nfp nfp-save))) + (trace-table-entry trace-table-normal))) + + +;;; Non-TR local call for a variable number of return values passed according +;;; to the unknown values convention. The results are the start of the values +;;; glob and the number of values received. +;;; +;;; Note: we can't use normal load-tn allocation for the fixed args, since all +;;; registers may be tied up by the more operand. Instead, we use +;;; MAYBE-LOAD-STACK-TN. +;;; +(define-vop (multiple-call-local unknown-values-receiver) + (:args (fp) + (nfp) + (args :more t)) + (:save-p t) + (:move-args :local-call) + (:info save callee target) + (:ignore args save) + (:vop-var vop) + (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 20 + (trace-table-entry trace-table-call-site) + (let ((label (gen-label)) + (cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (store-stack-tn nfp-save cur-nfp)) + (let ((callee-nfp (callee-nfp-tn callee))) + ;; alpha doesn't test this before the maybe-load + (when callee-nfp + (maybe-load-stack-tn callee-nfp nfp))) + (maybe-load-stack-tn cfp-tn fp) + (inst compute-lra-from-code + (callee-return-pc-tn callee) code-tn label temp) + (note-this-location vop :call-site) + (inst b target) + (emit-return-pc label) + (note-this-location vop :unknown-return) + (receive-unknown-values values-start nvals start count label temp) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save))) + (trace-table-entry trace-table-normal))) + + +;;;; Local call with known values return: + +;;; Non-TR local call with known return locations. Known-value return works +;;; just like argument passing in local call. +;;; +;;; Note: we can't use normal load-tn allocation for the fixed args, since all +;;; registers may be tied up by the more operand. Instead, we use +;;; MAYBE-LOAD-STACK-TN. +;;; +(define-vop (known-call-local) + (:args (fp) + (nfp) + (args :more t)) + (:results (res :more t)) + (:move-args :local-call) + (:save-p t) + (:info save callee target) + (:ignore args res save) + (:vop-var vop) + (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 5 + (trace-table-entry trace-table-call-site) + (let ((label (gen-label)) + (cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (store-stack-tn nfp-save cur-nfp)) + (let ((callee-nfp (callee-nfp-tn callee))) + (when callee-nfp + (maybe-load-stack-tn callee-nfp nfp))) + (maybe-load-stack-tn cfp-tn fp) + (inst compute-lra-from-code + (callee-return-pc-tn callee) code-tn label temp) + (note-this-location vop :call-site) + (inst b target) + (emit-return-pc label) + (note-this-location vop :known-return) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save))) + (trace-table-entry trace-table-normal))) + +;;; Return from known values call. We receive the return locations as +;;; arguments to terminate their lifetimes in the returning function. We +;;; restore FP and CSP and jump to the Return-PC. +;;; +;;; Note: we can't use normal load-tn allocation for the fixed args, since all +;;; registers may be tied up by the more operand. Instead, we use +;;; MAYBE-LOAD-STACK-TN. +;;; +(define-vop (known-return) + (:args (old-fp :target old-fp-temp) + (return-pc :target return-pc-temp) + (vals :more t)) + (:temporary (:sc any-reg :from (:argument 0)) old-fp-temp) + (:temporary (:sc descriptor-reg :from (:argument 1)) return-pc-temp) + (:move-args :known-return) + (:info val-locs) + (:ignore val-locs vals) + (:vop-var vop) + (:generator 6 + (trace-table-entry trace-table-fun-epilogue) + (maybe-load-stack-tn old-fp-temp old-fp) + (maybe-load-stack-tn return-pc-temp return-pc) + (move csp-tn cfp-tn) + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (inst addi nsp-tn cur-nfp + (- (bytes-needed-for-non-descriptor-stack-frame) + number-stack-displacement)))) + (move cfp-tn old-fp-temp) + (inst j return-pc-temp (- n-word-bytes other-pointer-lowtag)) + (trace-table-entry trace-table-normal))) + + +;;;; Full call: +;;; +;;; There is something of a cross-product effect with full calls. Different +;;; versions are used depending on whether we know the number of arguments or +;;; the name of the called function, and whether we want fixed values, unknown +;;; values, or a tail call. +;;; +;;; In full call, the arguments are passed creating a partial frame on the +;;; stack top and storing stack arguments into that frame. On entry to the +;;; callee, this partial frame is pointed to by FP. If there are no stack +;;; arguments, we don't bother allocating a partial frame, and instead set FP +;;; to SP just before the call. + +;;; Define-Full-Call -- Internal +;;; +;;; This macro helps in the definition of full call VOPs by avoiding code +;;; replication in defining the cross-product VOPs. +;;; +;;; Name is the name of the VOP to define. +;;; +;;; Named is true if the first argument is a symbol whose global function +;;; definition is to be called. +;;; +;;; Return is either :Fixed, :Unknown or :Tail: +;;; -- If :Fixed, then the call is for a fixed number of values, returned in +;;; the standard passing locations (passed as result operands). +;;; -- If :Unknown, then the result values are pushed on the stack, and the +;;; result values are specified by the Start and Count as in the +;;; unknown-values continuation representation. +;;; -- If :Tail, then do a tail-recursive call. No values are returned. +;;; The Old-Fp and Return-PC are passed as the second and third arguments. +;;; +;;; In non-tail calls, the pointer to the stack arguments is passed as the last +;;; fixed argument. If Variable is false, then the passing locations are +;;; passed as a more arg. Variable is true if there are a variable number of +;;; arguments passed on the stack. Variable cannot be specified with :Tail +;;; return. TR variable argument call is implemented separately. +;;; +;;; In tail call with fixed arguments, the passing locations are passed as a +;;; more arg, but there is no new-FP, since the arguments have been set up in +;;; the current frame. +;;; +(defmacro define-full-call (name named return variable) + (assert (not (and variable (eq return :tail)))) + `(define-vop (,name + ,@(when (eq return :unknown) + '(unknown-values-receiver))) + (:args + ,@(unless (eq return :tail) + '((new-fp :scs (any-reg) :to :eval))) + + ,(if named + '(name :target name-pass) + '(arg-fun :target lexenv)) + + ,@(when (eq return :tail) + '((old-fp :target old-fp-pass) + (return-pc :target return-pc-pass))) + + ,@(unless variable '((args :more t :scs (descriptor-reg))))) + + ,@(when (eq return :fixed) + '((:results (values :more t)))) + + (:save-p ,(if (eq return :tail) :compute-only t)) + + ,@(unless (or (eq return :tail) variable) + '((:move-args :full-call))) + + (:vop-var vop) + (:info ,@(unless (or variable (eq return :tail)) '(arg-locs)) + ,@(unless variable '(nargs)) + ,@(when (eq return :fixed) '(nvals))) + + (:ignore + ,@(unless (or variable (eq return :tail)) '(arg-locs)) + ,@(unless variable '(args))) + + (:temporary (:sc descriptor-reg + :offset ocfp-offset + :from (:argument 1) + ,@(unless (eq return :fixed) + '(:to :eval))) + old-fp-pass) + + (:temporary (:sc descriptor-reg + :offset lra-offset + :from (:argument ,(if (eq return :tail) 2 1)) + :to :eval) + return-pc-pass) + + ,(if named + `(:temporary (:sc descriptor-reg :offset fdefn-offset ; -dan + :from (:argument ,(if (eq return :tail) 0 1)) + :to :eval) + name-pass) + `(:temporary (:sc descriptor-reg :offset lexenv-offset + :from (:argument ,(if (eq return :tail) 0 1)) + :to :eval) + lexenv)) + ;; alpha code suggests that function tn is not needed for named call + (:temporary (:scs (descriptor-reg) :from (:argument 0) :to :eval) + function) + (:temporary (:sc any-reg :offset nargs-offset :to :eval) + nargs-pass) + + ,@(when variable + (mapcar #'(lambda (name offset) + `(:temporary (:sc descriptor-reg + :offset ,offset + :to :eval) + ,name)) + register-arg-names *register-arg-offsets*)) + ,@(when (eq return :fixed) + '((:temporary (:scs (descriptor-reg) :from :eval) move-temp))) + + ,@(unless (eq return :tail) + '((:temporary (:scs (non-descriptor-reg)) temp) + (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save))) + + (:temporary (:sc interior-reg :offset lip-offset) entry-point) + + (:generator ,(+ (if named 5 0) + (if variable 19 1) + (if (eq return :tail) 0 10) + 15 + (if (eq return :unknown) 25 0)) + (trace-table-entry trace-table-call-site) + (let* ((cur-nfp (current-nfp-tn vop)) + ,@(unless (eq return :tail) + '((lra-label (gen-label)))) + (filler + (remove nil + (list :load-nargs + ,@(if (eq return :tail) + '((unless (location= old-fp old-fp-pass) + :load-old-fp) + (unless (location= return-pc + return-pc-pass) + :load-return-pc) + (when cur-nfp + :frob-nfp)) + '(:comp-lra + (when cur-nfp + :frob-nfp) + :save-fp + :load-fp)))))) + (flet ((do-next-filler () + (let* ((next (pop filler)) + (what (if (consp next) (car next) next))) + (ecase what + (:load-nargs + ,@(if variable + `((inst sub nargs-pass csp-tn new-fp) + ,@(let ((index -1)) + (mapcar #'(lambda (name) + `(loadw ,name new-fp + ,(incf index))) + register-arg-names))) + '((inst lr nargs-pass (fixnumize nargs))))) + ,@(if (eq return :tail) + '((:load-old-fp + (sc-case old-fp + (any-reg + (inst mr old-fp-pass old-fp)) + (control-stack + (loadw old-fp-pass cfp-tn + (tn-offset old-fp))))) + (:load-return-pc + (sc-case return-pc + (descriptor-reg + (inst mr return-pc-pass return-pc)) + (control-stack + (loadw return-pc-pass cfp-tn + (tn-offset return-pc))))) + (:frob-nfp + (inst addi nsp-tn cur-nfp + (- (bytes-needed-for-non-descriptor-stack-frame) + number-stack-displacement)))) + `((:comp-lra + (inst compute-lra-from-code + return-pc-pass code-tn lra-label temp)) + (:frob-nfp + (store-stack-tn nfp-save cur-nfp)) + (:save-fp + (inst mr old-fp-pass cfp-tn)) + (:load-fp + ,(if variable + '(move cfp-tn new-fp) + '(if (> nargs register-arg-count) + (move cfp-tn new-fp) + (move cfp-tn csp-tn)))))) + ((nil)))))) + ,@(if named + `((sc-case name + (descriptor-reg (move name-pass name)) + (control-stack + (loadw name-pass cfp-tn (tn-offset name)) + (do-next-filler)) + (constant + (loadw name-pass code-tn (tn-offset name) + other-pointer-lowtag) + (do-next-filler))) + (loadw entry-point name-pass fdefn-raw-addr-slot + other-pointer-lowtag) + (do-next-filler)) + `((sc-case arg-fun + (descriptor-reg (move lexenv arg-fun)) + (control-stack + (loadw lexenv cfp-tn (tn-offset arg-fun)) + (do-next-filler)) + (constant + (loadw lexenv code-tn (tn-offset arg-fun) + sb!vm:other-pointer-lowtag) + (do-next-filler))) + (loadw function lexenv sb!vm:closure-fun-slot + sb!vm:fun-pointer-lowtag) + (do-next-filler) + (inst addi entry-point function + (- (ash simple-fun-code-offset word-shift) + fun-pointer-lowtag)) + )) + (loop + (if filler + (do-next-filler) + (return))) + + (note-this-location vop :call-site) + (inst mtctr entry-point) + ;; this following line is questionable. or else the alpha + ;; code (which doesn't do it) is questionable + ;; (inst mr code-tn function) + (inst bctr)) + + ,@(ecase return + (:fixed + '((emit-return-pc lra-label) + (default-unknown-values vop values nvals move-temp + temp lra-label) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save)))) + (:unknown + '((emit-return-pc lra-label) + (note-this-location vop :unknown-return) + (receive-unknown-values values-start nvals start count + lra-label temp) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save)))) + (:tail))) + (trace-table-entry trace-table-normal)))) + + +(define-full-call call nil :fixed nil) +(define-full-call call-named t :fixed nil) +(define-full-call multiple-call nil :unknown nil) +(define-full-call multiple-call-named t :unknown nil) +(define-full-call tail-call nil :tail nil) +(define-full-call tail-call-named t :tail nil) + +(define-full-call call-variable nil :fixed t) +(define-full-call multiple-call-variable nil :unknown t) + + +;;; Defined separately, since needs special code that BLT's the arguments +;;; down. +;;; +(define-vop (tail-call-variable) + (:args + (args-arg :scs (any-reg) :target args) + (function-arg :scs (descriptor-reg) :target lexenv) + (old-fp-arg :scs (any-reg) :target old-fp) + (lra-arg :scs (descriptor-reg) :target lra)) + + (:temporary (:sc any-reg :offset nl0-offset :from (:argument 0)) args) + (:temporary (:sc any-reg :offset lexenv-offset :from (:argument 1)) lexenv) + (:temporary (:sc any-reg :offset ocfp-offset :from (:argument 2)) old-fp) + (:temporary (:sc any-reg :offset lra-offset :from (:argument 3)) lra) + + + (:vop-var vop) + + (:generator 75 + + ;; Move these into the passing locations if they are not already there. + (move args args-arg) + (move lexenv function-arg) + (move old-fp old-fp-arg) + (move lra lra-arg) + + + ;; Clear the number stack if anything is there. + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (inst addi nsp-tn cur-nfp + (- (bytes-needed-for-non-descriptor-stack-frame) + number-stack-displacement)))) + + + (inst ba (make-fixup 'tail-call-variable :assembly-routine)))) + + +;;;; Unknown values return: + + +;;; Return a single value using the unknown-values convention. +;;; +(define-vop (return-single) + (:args (old-fp :scs (any-reg)) + (return-pc :scs (descriptor-reg)) + (value)) + (:ignore value) + (:temporary (:scs (interior-reg)) lip) + (:vop-var vop) + (:generator 6 + (trace-table-entry trace-table-fun-epilogue) + ;; Clear the number stack. + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (inst addi nsp-tn cur-nfp + (- (bytes-needed-for-non-descriptor-stack-frame) + number-stack-displacement)))) + ;; Clear the control stack, and restore the frame pointer. + (move csp-tn cfp-tn) + (move cfp-tn old-fp) + ;; Out of here. + (lisp-return return-pc lip :offset 2) + (trace-table-entry trace-table-normal))) + +;;; Do unknown-values return of a fixed number of values. The Values are +;;; required to be set up in the standard passing locations. Nvals is the +;;; number of values returned. +;;; +;;; If returning a single value, then deallocate the current frame, restore +;;; FP and jump to the single-value entry at Return-PC + 8. +;;; +;;; If returning other than one value, then load the number of values returned, +;;; NIL out unsupplied values registers, restore FP and return at Return-PC. +;;; When there are stack values, we must initialize the argument pointer to +;;; point to the beginning of the values block (which is the beginning of the +;;; current frame.) +;;; +(define-vop (return) + (:args + (old-fp :scs (any-reg)) + (return-pc :scs (descriptor-reg) :to (:eval 1)) + (values :more t)) + (:ignore values) + (:info nvals) + (:temporary (:sc descriptor-reg :offset a0-offset :from (:eval 0)) a0) + (:temporary (:sc descriptor-reg :offset a1-offset :from (:eval 0)) a1) + (:temporary (:sc descriptor-reg :offset a2-offset :from (:eval 0)) a2) + (:temporary (:sc descriptor-reg :offset a3-offset :from (:eval 0)) a3) + (:temporary (:sc any-reg :offset nargs-offset) nargs) + (:temporary (:sc any-reg :offset ocfp-offset) val-ptr) + (:temporary (:scs (interior-reg)) lip) + (:vop-var vop) + (:generator 6 + (trace-table-entry trace-table-fun-epilogue) + ;; Clear the number stack. + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (inst addi nsp-tn cur-nfp + (- (bytes-needed-for-non-descriptor-stack-frame) + number-stack-displacement)))) + (cond ((= nvals 1) + ;; Clear the control stack, and restore the frame pointer. + (move csp-tn cfp-tn) + (move cfp-tn old-fp) + ;; Out of here. + (lisp-return return-pc lip :offset 2)) + (t + ;; Establish the values pointer and values count. + (move val-ptr cfp-tn) + (inst lr nargs (fixnumize nvals)) + ;; restore the frame pointer and clear as much of the control + ;; stack as possible. + (move cfp-tn old-fp) + (inst addi csp-tn val-ptr (* nvals n-word-bytes)) + ;; pre-default any argument register that need it. + (when (< nvals register-arg-count) + (dolist (reg (subseq (list a0 a1 a2 a3) nvals)) + (move reg null-tn))) + ;; And away we go. + (lisp-return return-pc lip))) + (trace-table-entry trace-table-normal))) + +;;; Do unknown-values return of an arbitrary number of values (passed on the +;;; stack.) We check for the common case of a single return value, and do that +;;; inline using the normal single value return convention. Otherwise, we +;;; branch off to code that calls an assembly-routine. +;;; +(define-vop (return-multiple) + (:args + (old-fp-arg :scs (any-reg) :to (:eval 1)) + (lra-arg :scs (descriptor-reg) :to (:eval 1)) + (vals-arg :scs (any-reg) :target vals) + (nvals-arg :scs (any-reg) :target nvals)) + + (:temporary (:sc any-reg :offset nl1-offset :from (:argument 0)) old-fp) + (:temporary (:sc descriptor-reg :offset lra-offset :from (:argument 1)) lra) + (:temporary (:sc any-reg :offset nl0-offset :from (:argument 2)) vals) + (:temporary (:sc any-reg :offset nargs-offset :from (:argument 3)) nvals) + (:temporary (:sc descriptor-reg :offset a0-offset) a0) + (:temporary (:scs (interior-reg)) lip) + + + (:vop-var vop) + + (:generator 13 + (trace-table-entry trace-table-fun-epilogue) + (let ((not-single (gen-label))) + ;; Clear the number stack. + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (inst addi nsp-tn cur-nfp + (- (bytes-needed-for-non-descriptor-stack-frame) + number-stack-displacement)))) + + ;; Check for the single case. + (inst cmpwi nvals-arg (fixnumize 1)) + (inst lwz a0 vals-arg 0) + (inst bne not-single) + + ;; Return with one value. + (move csp-tn cfp-tn) + (move cfp-tn old-fp-arg) + (lisp-return lra-arg lip :offset 2) + + ;; Nope, not the single case. + (emit-label not-single) + (move old-fp old-fp-arg) + (move lra lra-arg) + (move vals vals-arg) + (move nvals nvals-arg) + (inst ba (make-fixup 'return-multiple :assembly-routine))) + (trace-table-entry trace-table-normal))) + + + +;;;; XEP hackery: + + +;;; We don't need to do anything special for regular functions. +;;; +(define-vop (setup-environment) + (:info label) + (:ignore label) + (:generator 0 + ;; Don't bother doing anything. + )) + +;;; Get the lexical environment from its passing location. +;;; +(define-vop (setup-closure-environment) + (:temporary (:sc descriptor-reg :offset lexenv-offset :target closure + :to (:result 0)) + lexenv) + (:results (closure :scs (descriptor-reg))) + (:info label) + (:ignore label) + (:generator 6 + ;; Get result. + (move closure lexenv))) + +;;; Copy a more arg from the argument area to the end of the current frame. +;;; Fixed is the number of non-more arguments. +;;; +(define-vop (copy-more-arg) + (:temporary (:sc any-reg :offset nl0-offset) result) + (:temporary (:sc any-reg :offset nl1-offset) count) + (:temporary (:sc any-reg :offset nl2-offset) src) + (:temporary (:sc any-reg :offset nl3-offset) dst) + (:temporary (:sc descriptor-reg :offset l0-offset) temp) + (:info fixed) + (:generator 20 + (let ((loop (gen-label)) + (do-regs (gen-label)) + (done (gen-label))) + (when (< fixed register-arg-count) + ;; Save a pointer to the results so we can fill in register args. + ;; We don't need this if there are more fixed args than reg args. + (move result csp-tn)) + ;; Allocate the space on the stack. + (cond ((zerop fixed) + (inst cmpwi nargs-tn 0) + (inst add csp-tn csp-tn nargs-tn) + (inst beq done)) + (t + (inst addic. count nargs-tn (- (fixnumize fixed))) + (inst ble done) + (inst add csp-tn csp-tn count))) + (when (< fixed register-arg-count) + ;; We must stop when we run out of stack args, not when we run out of + ;; more args. + (inst addic. count nargs-tn (- (fixnumize register-arg-count))) + ;; Everything of interest is in registers. + (inst ble do-regs)) + ;; Initialize dst to be end of stack. + (move dst csp-tn) + ;; Initialize src to be end of args. + (inst add src cfp-tn nargs-tn) + + (emit-label loop) + ;; *--dst = *--src, --count + (inst addi src src (- sb!vm:n-word-bytes)) + (inst addic. count count (- (fixnumize 1))) + (loadw temp src) + (inst addi dst dst (- sb!vm:n-word-bytes)) + (storew temp dst) + (inst bgt loop) + + (emit-label do-regs) + (when (< fixed register-arg-count) + ;; Now we have to deposit any more args that showed up in registers. + (inst subic. count nargs-tn (fixnumize fixed)) + (do ((i fixed (1+ i))) + ((>= i register-arg-count)) + ;; Don't deposit any more than there are. + (inst beq done) + (inst subic. count count (fixnumize 1)) + ;; Store it relative to the pointer saved at the start. + (storew (nth i *register-arg-tns*) result (- i fixed)))) + (emit-label done)))) + + +;;; More args are stored consecutively on the stack, starting immediately at +;;; the context pointer. The context pointer is not typed, so the lowtag is 0. +;;; +(define-vop (more-arg word-index-ref) + (:variant 0 0) + (:translate %more-arg)) + + +;;; Turn more arg (context, count) into a list. +;;; +(define-vop (listify-rest-args) + (:args (context-arg :target context :scs (descriptor-reg)) + (count-arg :target count :scs (any-reg))) + (:arg-types * tagged-num) + (:temporary (:scs (any-reg) :from (:argument 0)) context) + (:temporary (:scs (any-reg) :from (:argument 1)) count) + (:temporary (:scs (descriptor-reg) :from :eval) temp) + (:temporary (:scs (non-descriptor-reg) :from :eval) dst) + (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag) + (:results (result :scs (descriptor-reg))) + (:translate %listify-rest-args) + (:policy :safe) + (:generator 20 + (move context context-arg) + (move count count-arg) + ;; Check to see if there are any arguments. + (inst cmpwi count 0) + (move result null-tn) + (inst beq done) + + ;; We need to do this atomically. + (pseudo-atomic (pa-flag) + (assemble () + ;; Allocate a cons (2 words) for each item. + (inst clrrwi result alloc-tn n-lowtag-bits) + (inst ori result result list-pointer-lowtag) + (move dst result) + (inst slwi temp count 1) + (inst add alloc-tn alloc-tn temp) + (inst b enter) + + ;; Compute the next cons and store it in the current one. + LOOP + (inst addi dst dst (* 2 n-word-bytes)) + (storew dst dst -1 list-pointer-lowtag) + + ;; Grab one value. + ENTER + (loadw temp context) + (inst addi context context n-word-bytes) + + ;; Dec count, and if != zero, go back for more. + (inst addic. count count (- (fixnumize 1))) + ;; Store the value into the car of the current cons (in the delay + ;; slot). + (storew temp dst 0 list-pointer-lowtag) + (inst bgt loop) + + + ;; NIL out the last cons. + (storew null-tn dst 1 list-pointer-lowtag))) + DONE)) + + +;;; Return the location and size of the more arg glob created by Copy-More-Arg. +;;; Supplied is the total number of arguments supplied (originally passed in +;;; NARGS.) Fixed is the number of non-rest arguments. +;;; +;;; We must duplicate some of the work done by Copy-More-Arg, since at that +;;; time the environment is in a pretty brain-damaged state, preventing this +;;; info from being returned as values. What we do is compute +;;; supplied - fixed, and return a pointer that many words below the current +;;; stack top. +;;; +(define-vop (more-arg-context) + (:policy :fast-safe) + (:translate sb!c::%more-arg-context) + (:args (supplied :scs (any-reg))) + (:arg-types tagged-num (:constant fixnum)) + (:info fixed) + (:results (context :scs (descriptor-reg)) + (count :scs (any-reg))) + (:result-types t tagged-num) + (:note "more-arg-context") + (:generator 5 + (inst subi count supplied (fixnumize fixed)) + (inst sub context csp-tn count))) + + +;;; Signal wrong argument count error if Nargs isn't = to Count. +;;; +#| +(define-vop (verify-argument-count) + (:policy :fast-safe) + (:translate sb!c::%verify-argument-count) + (:args (nargs :scs (any-reg))) + (:arg-types positive-fixnum (:constant t)) + (:info count) + (:vop-var vop) + (:save-p :compute-only) + (:generator 3 + (let ((err-lab + (generate-error-code vop invalid-argument-count-error nargs))) + (inst cmpwi nargs (fixnumize count)) + (inst bne err-lab)))) +|# +(define-vop (verify-arg-count) + (:policy :fast-safe) + (:translate sb!c::%verify-arg-count) + (:args (nargs :scs (any-reg))) + (:arg-types positive-fixnum (:constant t)) + (:info count) + (:vop-var vop) + (:save-p :compute-only) + (:generator 3 + (inst twi :ne nargs (fixnumize count)))) + + +;;; Signal various errors. +;;; +(macrolet ((frob (name error translate &rest args) + `(define-vop (,name) + ,@(when translate + `((:policy :fast-safe) + (:translate ,translate))) + (:args ,@(mapcar #'(lambda (arg) + `(,arg :scs (any-reg descriptor-reg))) + args)) + (:vop-var vop) + (:save-p :compute-only) + (:generator 1000 + (error-call vop ,error ,@args))))) + (frob arg-count-error invalid-arg-count-error + sb!c::%arg-count-error nargs) + (frob type-check-error object-not-type-error sb!c::%type-check-error + object type) + (frob layout-invalid-error layout-invalid-error sb!c::%layout-invalid-error + object layout) + (frob odd-key-args-error odd-key-args-error + sb!c::%odd-key-args-error) + (frob unknown-key-arg-error unknown-key-arg-error + sb!c::%unknown-key-arg-error key) + (frob nil-fun-returned-error nil-fun-returned-error nil fun)) diff --git a/src/compiler/ppc/cell.lisp b/src/compiler/ppc/cell.lisp new file mode 100644 index 0000000..3d5fb37 --- /dev/null +++ b/src/compiler/ppc/cell.lisp @@ -0,0 +1,280 @@ +;;; VOPs for the PPC. +;;; +;;; Written by Rob MacLachlan +;;; +;;; Converted by William Lott. +;;; + +(in-package "SB!VM") + + +;;;; Data object ref/set stuff. + +(define-vop (slot) + (:args (object :scs (descriptor-reg))) + (:info name offset lowtag) + (:ignore name) + (:results (result :scs (descriptor-reg any-reg))) + (:generator 1 + (loadw result object offset lowtag))) + +(define-vop (set-slot) + (:args (object :scs (descriptor-reg)) + (value :scs (descriptor-reg any-reg))) + (:info name offset lowtag) + (:ignore name) + (:results) + (:generator 1 + (storew value object offset lowtag))) + + + +;;;; Symbol hacking VOPs: + +;;; The compiler likes to be able to directly SET symbols. +;;; +(define-vop (set cell-set) + (:variant symbol-value-slot other-pointer-lowtag)) + +;;; Do a cell ref with an error check for being unbound. +;;; +(define-vop (checked-cell-ref) + (:args (object :scs (descriptor-reg) :target obj-temp)) + (:results (value :scs (descriptor-reg any-reg))) + (:policy :fast-safe) + (:vop-var vop) + (:save-p :compute-only) + (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp)) + +;;; With Symbol-Value, we check that the value isn't the trap object. So +;;; Symbol-Value of NIL is NIL. +;;; +(define-vop (symbol-value checked-cell-ref) + (:translate symbol-value) + (:generator 9 + (move obj-temp object) + (loadw value obj-temp sb!vm:symbol-value-slot sb!vm:other-pointer-lowtag) + (let ((err-lab (generate-error-code vop unbound-symbol-error obj-temp))) + (inst cmpwi value sb!vm:unbound-marker-widetag) + (inst beq err-lab)))) + +;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell is bound. +(define-vop (boundp-frob) + (:args (object :scs (descriptor-reg))) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:temporary (:scs (descriptor-reg)) value)) + +(define-vop (boundp boundp-frob) + (:translate boundp) + (:generator 9 + (loadw value object sb!vm:symbol-value-slot sb!vm:other-pointer-lowtag) + (inst cmpwi value sb!vm:unbound-marker-widetag) + (inst b? (if not-p :eq :ne) target))) + +(define-vop (fast-symbol-value cell-ref) + (:variant sb!vm:symbol-value-slot sb!vm:other-pointer-lowtag) + (:policy :fast) + (:translate symbol-value)) + + +;;;; Fdefinition (fdefn) objects. + +(define-vop (fdefn-fun cell-ref) + (:variant fdefn-fun-slot other-pointer-lowtag)) + +(define-vop (safe-fdefn-fun) + (:args (object :scs (descriptor-reg) :target obj-temp)) + (:results (value :scs (descriptor-reg any-reg))) + (:vop-var vop) + (:save-p :compute-only) + (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp) + (:generator 10 + (move obj-temp object) + (loadw value obj-temp fdefn-fun-slot other-pointer-lowtag) + (inst cmpw value null-tn) + (let ((err-lab (generate-error-code vop undefined-fun-error obj-temp))) + (inst beq err-lab)))) + +(define-vop (set-fdefn-fun) + (:policy :fast-safe) + (:translate (setf fdefn-fun)) + (:args (function :scs (descriptor-reg) :target result) + (fdefn :scs (descriptor-reg))) + (:temporary (:scs (interior-reg)) lip) + (:temporary (:scs (non-descriptor-reg)) type) + (:results (result :scs (descriptor-reg))) + (:generator 38 + (let ((normal-fn (gen-label))) + (load-type type function (- fun-pointer-lowtag)) + (inst cmpwi type simple-fun-header-widetag) + ;;(inst mr lip function) + (inst addi lip function + (- (ash simple-fun-code-offset word-shift) fun-pointer-lowtag)) + (inst beq normal-fn) + (inst lr lip (make-fixup "closure_tramp" :foreign)) + (emit-label normal-fn) + (storew lip fdefn fdefn-raw-addr-slot other-pointer-lowtag) + (storew function fdefn fdefn-fun-slot other-pointer-lowtag) + (move result function)))) + +(define-vop (fdefn-makunbound) + (:policy :fast-safe) + (:translate fdefn-makunbound) + (:args (fdefn :scs (descriptor-reg) :target result)) + (:temporary (:scs (non-descriptor-reg)) temp) + (:results (result :scs (descriptor-reg))) + (:generator 38 + (storew null-tn fdefn fdefn-fun-slot other-pointer-lowtag) + (inst lr temp (make-fixup "undefined_tramp" :foreign)) + (storew temp fdefn fdefn-raw-addr-slot other-pointer-lowtag) + (move result fdefn))) + + + +;;;; Binding and Unbinding. + +;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and +;;; the symbol on the binding stack and stuff the new value into the +;;; symbol. + +(define-vop (bind) + (:args (val :scs (any-reg descriptor-reg)) + (symbol :scs (descriptor-reg))) + (:temporary (:scs (descriptor-reg)) temp) + (:generator 5 + (loadw temp symbol sb!vm:symbol-value-slot sb!vm:other-pointer-lowtag) + (inst addi bsp-tn bsp-tn (* 2 sb!vm:n-word-bytes)) + (storew temp bsp-tn (- sb!vm:binding-value-slot sb!vm:binding-size)) + (storew symbol bsp-tn (- sb!vm:binding-symbol-slot sb!vm:binding-size)) + (storew val symbol sb!vm:symbol-value-slot sb!vm:other-pointer-lowtag))) + + +(define-vop (unbind) + (:temporary (:scs (descriptor-reg)) symbol value) + (:generator 0 + (loadw symbol bsp-tn (- sb!vm:binding-symbol-slot sb!vm:binding-size)) + (loadw value bsp-tn (- sb!vm:binding-value-slot sb!vm:binding-size)) + (storew value symbol sb!vm:symbol-value-slot sb!vm:other-pointer-lowtag) + (storew zero-tn bsp-tn (- sb!vm:binding-symbol-slot sb!vm:binding-size)) + (inst subi bsp-tn bsp-tn (* 2 sb!vm:n-word-bytes)))) + + +(define-vop (unbind-to-here) + (:args (arg :scs (descriptor-reg any-reg) :target where)) + (:temporary (:scs (any-reg) :from (:argument 0)) where) + (:temporary (:scs (descriptor-reg)) symbol value) + (:generator 0 + (let ((loop (gen-label)) + (skip (gen-label)) + (done (gen-label))) + (move where arg) + (inst cmpw where bsp-tn) + (inst beq done) + + (emit-label loop) + (loadw symbol bsp-tn (- sb!vm:binding-symbol-slot sb!vm:binding-size)) + (inst cmpwi symbol 0) + (inst beq skip) + (loadw value bsp-tn (- sb!vm:binding-value-slot sb!vm:binding-size)) + (storew value symbol sb!vm:symbol-value-slot sb!vm:other-pointer-lowtag) + (storew zero-tn bsp-tn (- sb!vm:binding-symbol-slot sb!vm:binding-size)) + + (emit-label skip) + (inst subi bsp-tn bsp-tn (* 2 sb!vm:n-word-bytes)) + (inst cmpw where bsp-tn) + (inst bne loop) + + (emit-label done)))) + + + +;;;; Closure indexing. + +(define-vop (closure-index-ref word-index-ref) + (:variant sb!vm:closure-info-offset sb!vm:fun-pointer-lowtag) + (:translate %closure-index-ref)) + +(define-vop (funcallable-instance-info word-index-ref) + (:variant funcallable-instance-info-offset sb!vm:fun-pointer-lowtag) + (:translate %funcallable-instance-info)) + +(define-vop (set-funcallable-instance-info word-index-set) + (:variant funcallable-instance-info-offset fun-pointer-lowtag) + (:translate %set-funcallable-instance-info)) + +(define-vop (funcallable-instance-lexenv cell-ref) + (:variant funcallable-instance-lexenv-slot fun-pointer-lowtag)) + + +(define-vop (closure-ref slot-ref) + (:variant closure-info-offset fun-pointer-lowtag)) + +(define-vop (closure-init slot-set) + (:variant closure-info-offset fun-pointer-lowtag)) + + +;;;; Value Cell hackery. + +(define-vop (value-cell-ref cell-ref) + (:variant value-cell-value-slot other-pointer-lowtag)) + +(define-vop (value-cell-set cell-set) + (:variant value-cell-value-slot other-pointer-lowtag)) + + + +;;;; Instance hackery: + +(define-vop (instance-length) + (:policy :fast-safe) + (:translate %instance-length) + (:args (struct :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) temp) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 4 + (loadw temp struct 0 instance-pointer-lowtag) + (inst srwi res temp sb!vm:n-widetag-bits))) + +(define-vop (instance-ref slot-ref) + (:variant instance-slots-offset instance-pointer-lowtag) + (:policy :fast-safe) + (:translate %instance-ref) + (:arg-types * (:constant index))) + +#+nil +(define-vop (instance-set slot-set) + (:policy :fast-safe) + (:translate %instance-set) + (:variant instance-slots-offset instance-pointer-lowtag) + (:arg-types instance (:constant index) *)) + +(define-vop (instance-index-ref word-index-ref) + (:policy :fast-safe) + (:translate %instance-ref) + (:variant instance-slots-offset instance-pointer-lowtag) + (:arg-types instance positive-fixnum)) + +(define-vop (instance-index-set word-index-set) + (:policy :fast-safe) + (:translate %instance-set) + (:variant instance-slots-offset instance-pointer-lowtag) + (:arg-types instance positive-fixnum *)) + + + + +;;;; Code object frobbing. + +(define-vop (code-header-ref word-index-ref) + (:translate code-header-ref) + (:policy :fast-safe) + (:variant 0 other-pointer-lowtag)) + +(define-vop (code-header-set word-index-set) + (:translate code-header-set) + (:policy :fast-safe) + (:variant 0 other-pointer-lowtag)) + diff --git a/src/compiler/ppc/char.lisp b/src/compiler/ppc/char.lisp new file mode 100644 index 0000000..308ddb0 --- /dev/null +++ b/src/compiler/ppc/char.lisp @@ -0,0 +1,133 @@ +;;; +;;; Written by Rob MacLachlan +;;; Converted for the MIPS R2000 by Christopher Hoover. +;;; And then to the SPARC by William Lott. +;;; +(in-package "SB!VM") + + + +;;;; Moves and coercions: + +;;; Move a tagged char to an untagged representation. +;;; +(define-vop (move-to-base-char) + (:args (x :scs (any-reg descriptor-reg))) + (:results (y :scs (base-char-reg))) + (:note "character untagging") + (:generator 1 + (inst srwi y x sb!vm:n-widetag-bits))) +;;; +(define-move-vop move-to-base-char :move + (any-reg descriptor-reg) (base-char-reg)) + + +;;; Move an untagged char to a tagged representation. +;;; +(define-vop (move-from-base-char) + (:args (x :scs (base-char-reg))) + (:results (y :scs (any-reg descriptor-reg))) + (:note "character tagging") + (:generator 1 + (inst slwi y x sb!vm:n-widetag-bits) + (inst ori y y sb!vm:base-char-widetag))) +;;; +(define-move-vop move-from-base-char :move + (base-char-reg) (any-reg descriptor-reg)) + +;;; Move untagged base-char values. +;;; +(define-vop (base-char-move) + (:args (x :target y + :scs (base-char-reg) + :load-if (not (location= x y)))) + (:results (y :scs (base-char-reg) + :load-if (not (location= x y)))) + (:note "character move") + (:effects) + (:affected) + (:generator 0 + (move y x))) +;;; +(define-move-vop base-char-move :move + (base-char-reg) (base-char-reg)) + + +;;; Move untagged base-char arguments/return-values. +;;; +(define-vop (move-base-char-arg) + (:args (x :target y + :scs (base-char-reg)) + (fp :scs (any-reg) + :load-if (not (sc-is y base-char-reg)))) + (:results (y)) + (:note "character arg move") + (:generator 0 + (sc-case y + (base-char-reg + (move y x)) + (base-char-stack + (storew x fp (tn-offset y)))))) +;;; +(define-move-vop move-base-char-arg :move-arg + (any-reg base-char-reg) (base-char-reg)) + + +;;; Use standard MOVE-ARG + coercion to move an untagged base-char +;;; to a descriptor passing location. +;;; +(define-move-vop move-arg :move-arg + (base-char-reg) (any-reg descriptor-reg)) + + + +;;;; Other operations: + +(define-vop (char-code) + (:translate char-code) + (:policy :fast-safe) + (:args (ch :scs (base-char-reg) :target res)) + (:arg-types base-char) + (:results (res :scs (any-reg))) + (:result-types positive-fixnum) + (:generator 1 + (inst slwi res ch 2))) + +(define-vop (code-char) + (:translate code-char) + (:policy :fast-safe) + (:args (code :scs (any-reg) :target res)) + (:arg-types positive-fixnum) + (:results (res :scs (base-char-reg))) + (:result-types base-char) + (:generator 1 + (inst srwi res code 2))) + + +;;; Comparison of base-chars. +;;; +(define-vop (base-char-compare) + (:args (x :scs (base-char-reg)) + (y :scs (base-char-reg))) + (:arg-types base-char base-char) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:note "inline comparison") + (:variant-vars condition not-condition) + (:generator 3 + (inst cmplw x y) + (inst b? (if not-p not-condition condition) target))) + +(define-vop (fast-char=/base-char base-char-compare) + (:translate char=) + (:variant :eq :ne)) + +(define-vop (fast-char/base-char base-char-compare) + (:translate char>) + (:variant :gt :le)) + diff --git a/src/compiler/ppc/debug.lisp b/src/compiler/ppc/debug.lisp new file mode 100644 index 0000000..cf5db5f --- /dev/null +++ b/src/compiler/ppc/debug.lisp @@ -0,0 +1,104 @@ +;;; +;;; Written by William Lott. +;;; +(in-package "SB!VM") + +(define-vop (debug-cur-sp) + (:translate sb!di::current-sp) + (:policy :fast-safe) + (:results (res :scs (sap-reg))) + (:result-types system-area-pointer) + (:generator 1 + (move res csp-tn))) + +(define-vop (debug-cur-fp) + (:translate sb!di::current-fp) + (:policy :fast-safe) + (:results (res :scs (sap-reg))) + (:result-types system-area-pointer) + (:generator 1 + (move res cfp-tn))) + +(define-vop (read-control-stack) + (:translate sb!kernel:stack-ref) + (:policy :fast-safe) + (:args (sap :scs (sap-reg)) + (offset :scs (any-reg))) + (:arg-types system-area-pointer positive-fixnum) + (:results (result :scs (descriptor-reg))) + (:result-types *) + (:generator 5 + (inst lwzx result sap offset))) + +(define-vop (write-control-stack) + (:translate sb!kernel:%set-stack-ref) + (:policy :fast-safe) + (:args (sap :scs (sap-reg)) + (offset :scs (any-reg)) + (value :scs (descriptor-reg) :target result)) + (:arg-types system-area-pointer positive-fixnum *) + (:results (result :scs (descriptor-reg))) + (:result-types *) + (:generator 5 + (inst stwx value sap offset) + (move result value))) + +(define-vop (code-from-mumble) + (:policy :fast-safe) + (:args (thing :scs (descriptor-reg))) + (:results (code :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) temp) + (:variant-vars lowtag) + (:generator 5 + (let ((bogus (gen-label)) + (done (gen-label))) + (loadw temp thing 0 lowtag) + (inst srwi temp temp sb!vm:n-widetag-bits) + (inst cmpwi temp 0) + (inst slwi temp temp (1- (integer-length sb!vm:n-word-bytes))) + (inst beq bogus) + (unless (= lowtag sb!vm:other-pointer-lowtag) + (inst addi temp temp (- lowtag sb!vm:other-pointer-lowtag))) + (inst sub code thing temp) + (emit-label done) + (assemble (*elsewhere*) + (emit-label bogus) + (move code null-tn) + (inst b done))))) + +(define-vop (code-from-lra code-from-mumble) + (:translate sb!di::lra-code-header) + (:variant sb!vm:other-pointer-lowtag)) + +(define-vop (code-from-fun code-from-mumble) + (:translate sb!di::fun-code-header) + (:variant sb!vm:fun-pointer-lowtag)) + +(define-vop (make-lisp-obj) + (:policy :fast-safe) + (:translate sb!di::make-lisp-obj) + (:args (value :scs (unsigned-reg) :target result)) + (:arg-types unsigned-num) + (:results (result :scs (descriptor-reg))) + (:generator 1 + (move result value))) + +(define-vop (get-lisp-obj-address) + (:policy :fast-safe) + (:translate sb!di::get-lisp-obj-address) + (:args (thing :scs (descriptor-reg) :target result)) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 1 + (move result thing))) + + +(define-vop (fun-word-offset) + (:policy :fast-safe) + (:translate sb!di::fun-word-offset) + (:args (fun :scs (descriptor-reg))) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 5 + (loadw res fun 0 fun-pointer-lowtag) + (inst srwi res res sb!vm:n-widetag-bits))) diff --git a/src/compiler/ppc/float.lisp b/src/compiler/ppc/float.lisp new file mode 100644 index 0000000..0a6c97b --- /dev/null +++ b/src/compiler/ppc/float.lisp @@ -0,0 +1,847 @@ +2;;; +;;; Written by Rob MacLachlan +;;; Sparc conversion by William Lott. +;;; +(in-package "SB!VM") + + +;;;; Move functions: + +(define-move-fun (load-single 1) (vop x y) + ((single-stack) (single-reg)) + (inst lfs y (current-nfp-tn vop) (* (tn-offset x) sb!vm:n-word-bytes))) + +(define-move-fun (store-single 1) (vop x y) + ((single-reg) (single-stack)) + (inst stfs x (current-nfp-tn vop) (* (tn-offset y) sb!vm:n-word-bytes))) + + +(define-move-fun (load-double 2) (vop x y) + ((double-stack) (double-reg)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset x) sb!vm:n-word-bytes))) + (inst lfd y nfp offset))) + +(define-move-fun (store-double 2) (vop x y) + ((double-reg) (double-stack)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset y) sb!vm:n-word-bytes))) + (inst stfd x nfp offset))) + + + +;;;; Move VOPs: + +(macrolet ((frob (vop sc) + `(progn + (define-vop (,vop) + (:args (x :scs (,sc) + :target y + :load-if (not (location= x y)))) + (:results (y :scs (,sc) + :load-if (not (location= x y)))) + (:note "float move") + (:generator 0 + (unless (location= y x) + (inst fmr y x)))) + (define-move-vop ,vop :move (,sc) (,sc))))) + (frob single-move single-reg) + (frob double-move double-reg)) + + +(define-vop (move-from-float) + (:args (x :to :save)) + (:results (y)) + (:note "float to pointer coercion") + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag) + (:variant-vars double-p size type data) + (:generator 13 + (with-fixed-allocation (y pa-flag ndescr type size)) + (if double-p + (inst stfd x y (- (* data sb!vm:n-word-bytes) sb!vm:other-pointer-lowtag)) + (inst stfs x y (- (* data sb!vm:n-word-bytes) sb!vm:other-pointer-lowtag))))) + +(macrolet ((frob (name sc &rest args) + `(progn + (define-vop (,name move-from-float) + (:args (x :scs (,sc) :to :save)) + (:results (y :scs (descriptor-reg))) + (:variant ,@args)) + (define-move-vop ,name :move (,sc) (descriptor-reg))))) + (frob move-from-single single-reg + nil sb!vm:single-float-size sb!vm:single-float-widetag sb!vm:single-float-value-slot) + (frob move-from-double double-reg + t sb!vm:double-float-size sb!vm:double-float-widetag sb!vm:double-float-value-slot)) + +(macrolet ((frob (name sc double-p value) + `(progn + (define-vop (,name) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (,sc))) + (:note "pointer to float coercion") + (:generator 2 + (inst ,(if double-p 'lfd 'lfs) y x + (- (* ,value sb!vm:n-word-bytes) sb!vm:other-pointer-lowtag)))) + (define-move-vop ,name :move (descriptor-reg) (,sc))))) + (frob move-to-single single-reg nil sb!vm:single-float-value-slot) + (frob move-to-double double-reg t sb!vm:double-float-value-slot)) + + +(macrolet ((frob (name sc stack-sc double-p) + `(progn + (define-vop (,name) + (:args (x :scs (,sc) :target y) + (nfp :scs (any-reg) + :load-if (not (sc-is y ,sc)))) + (:results (y)) + (:note "float arg move") + (:generator ,(if double-p 2 1) + (sc-case y + (,sc + (unless (location= x y) + (inst fmr y x))) + (,stack-sc + (let ((offset (* (tn-offset y) sb!vm:n-word-bytes))) + (inst ,(if double-p 'stfd 'stfs) x nfp offset)))))) + (define-move-vop ,name :move-arg + (,sc descriptor-reg) (,sc))))) + (frob move-single-float-arg single-reg single-stack nil) + (frob move-double-float-arg double-reg double-stack t)) + + + +;;;; Complex float move functions + +(defun complex-single-reg-real-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg) + :offset (tn-offset x))) +(defun complex-single-reg-imag-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg) + :offset (1+ (tn-offset x)))) + +(defun complex-double-reg-real-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg) + :offset (tn-offset x))) +(defun complex-double-reg-imag-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg) + :offset (+ (tn-offset x) 2))) + + +(define-move-fun (load-complex-single 2) (vop x y) + ((complex-single-stack) (complex-single-reg)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset x) sb!vm:n-word-bytes))) + (let ((real-tn (complex-single-reg-real-tn y))) + (inst lfs real-tn nfp offset)) + (let ((imag-tn (complex-single-reg-imag-tn y))) + (inst lfs imag-tn nfp (+ offset sb!vm:n-word-bytes))))) + +(define-move-fun (store-complex-single 2) (vop x y) + ((complex-single-reg) (complex-single-stack)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset y) sb!vm:n-word-bytes))) + (let ((real-tn (complex-single-reg-real-tn x))) + (inst stfs real-tn nfp offset)) + (let ((imag-tn (complex-single-reg-imag-tn x))) + (inst stfs imag-tn nfp (+ offset sb!vm:n-word-bytes))))) + + +(define-move-fun (load-complex-double 4) (vop x y) + ((complex-double-stack) (complex-double-reg)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset x) sb!vm:n-word-bytes))) + (let ((real-tn (complex-double-reg-real-tn y))) + (inst lfd real-tn nfp offset)) + (let ((imag-tn (complex-double-reg-imag-tn y))) + (inst lfd imag-tn nfp (+ offset (* 2 sb!vm:n-word-bytes)))))) + +(define-move-fun (store-complex-double 4) (vop x y) + ((complex-double-reg) (complex-double-stack)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset y) sb!vm:n-word-bytes))) + (let ((real-tn (complex-double-reg-real-tn x))) + (inst stfd real-tn nfp offset)) + (let ((imag-tn (complex-double-reg-imag-tn x))) + (inst stfd imag-tn nfp (+ offset (* 2 sb!vm:n-word-bytes)))))) + + +;;; +;;; Complex float register to register moves. +;;; +(define-vop (complex-single-move) + (:args (x :scs (complex-single-reg) :target y + :load-if (not (location= x y)))) + (:results (y :scs (complex-single-reg) :load-if (not (location= x y)))) + (:note "complex single float move") + (:generator 0 + (unless (location= x y) + ;; Note the complex-float-regs are aligned to every second + ;; float register so there is not need to worry about overlap. + (let ((x-real (complex-single-reg-real-tn x)) + (y-real (complex-single-reg-real-tn y))) + (inst fmr y-real x-real)) + (let ((x-imag (complex-single-reg-imag-tn x)) + (y-imag (complex-single-reg-imag-tn y))) + (inst fmr y-imag x-imag))))) +;;; +(define-move-vop complex-single-move :move + (complex-single-reg) (complex-single-reg)) + +(define-vop (complex-double-move) + (:args (x :scs (complex-double-reg) + :target y :load-if (not (location= x y)))) + (:results (y :scs (complex-double-reg) :load-if (not (location= x y)))) + (:note "complex double float move") + (:generator 0 + (unless (location= x y) + ;; Note the complex-float-regs are aligned to every second + ;; float register so there is not need to worry about overlap. + (let ((x-real (complex-double-reg-real-tn x)) + (y-real (complex-double-reg-real-tn y))) + (inst fmr y-real x-real)) + (let ((x-imag (complex-double-reg-imag-tn x)) + (y-imag (complex-double-reg-imag-tn y))) + (inst fmr y-imag x-imag))))) +;;; +(define-move-vop complex-double-move :move + (complex-double-reg) (complex-double-reg)) + + +;;; +;;; Move from a complex float to a descriptor register allocating a +;;; new complex float object in the process. +;;; +(define-vop (move-from-complex-single) + (:args (x :scs (complex-single-reg) :to :save)) + (:results (y :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag) + (:note "complex single float to pointer coercion") + (:generator 13 + (with-fixed-allocation (y pa-flag ndescr sb!vm:complex-single-float-widetag + sb!vm:complex-single-float-size)) + (let ((real-tn (complex-single-reg-real-tn x))) + (inst stfs real-tn y (- (* sb!vm:complex-single-float-real-slot + sb!vm:n-word-bytes) + sb!vm:other-pointer-lowtag))) + (let ((imag-tn (complex-single-reg-imag-tn x))) + (inst stfs imag-tn y (- (* sb!vm:complex-single-float-imag-slot + sb!vm:n-word-bytes) + sb!vm:other-pointer-lowtag))))) +;;; +(define-move-vop move-from-complex-single :move + (complex-single-reg) (descriptor-reg)) + +(define-vop (move-from-complex-double) + (:args (x :scs (complex-double-reg) :to :save)) + (:results (y :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag) + (:note "complex double float to pointer coercion") + (:generator 13 + (with-fixed-allocation (y pa-flag ndescr sb!vm:complex-double-float-widetag + sb!vm:complex-double-float-size)) + (let ((real-tn (complex-double-reg-real-tn x))) + (inst stfd real-tn y (- (* sb!vm:complex-double-float-real-slot + sb!vm:n-word-bytes) + sb!vm:other-pointer-lowtag))) + (let ((imag-tn (complex-double-reg-imag-tn x))) + (inst stfd imag-tn y (- (* sb!vm:complex-double-float-imag-slot + sb!vm:n-word-bytes) + sb!vm:other-pointer-lowtag))))) +;;; +(define-move-vop move-from-complex-double :move + (complex-double-reg) (descriptor-reg)) + + +;;; +;;; Move from a descriptor to a complex float register +;;; +(define-vop (move-to-complex-single) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (complex-single-reg))) + (:note "pointer to complex float coercion") + (:generator 2 + (let ((real-tn (complex-single-reg-real-tn y))) + (inst lfs real-tn x (- (* complex-single-float-real-slot n-word-bytes) + other-pointer-lowtag))) + (let ((imag-tn (complex-single-reg-imag-tn y))) + (inst lfs imag-tn x (- (* complex-single-float-imag-slot n-word-bytes) + other-pointer-lowtag))))) +(define-move-vop move-to-complex-single :move + (descriptor-reg) (complex-single-reg)) + +(define-vop (move-to-complex-double) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (complex-double-reg))) + (:note "pointer to complex float coercion") + (:generator 2 + (let ((real-tn (complex-double-reg-real-tn y))) + (inst lfd real-tn x (- (* complex-double-float-real-slot n-word-bytes) + other-pointer-lowtag))) + (let ((imag-tn (complex-double-reg-imag-tn y))) + (inst lfd imag-tn x (- (* complex-double-float-imag-slot n-word-bytes) + other-pointer-lowtag))))) +(define-move-vop move-to-complex-double :move + (descriptor-reg) (complex-double-reg)) + + +;;; +;;; Complex float move-arg vop +;;; +(define-vop (move-complex-single-float-arg) + (:args (x :scs (complex-single-reg) :target y) + (nfp :scs (any-reg) :load-if (not (sc-is y complex-single-reg)))) + (:results (y)) + (:note "complex single-float arg move") + (:generator 1 + (sc-case y + (complex-single-reg + (unless (location= x y) + (let ((x-real (complex-single-reg-real-tn x)) + (y-real (complex-single-reg-real-tn y))) + (inst fmr y-real x-real)) + (let ((x-imag (complex-single-reg-imag-tn x)) + (y-imag (complex-single-reg-imag-tn y))) + (inst fmr y-imag x-imag)))) + (complex-single-stack + (let ((offset (* (tn-offset y) n-word-bytes))) + (let ((real-tn (complex-single-reg-real-tn x))) + (inst stfs real-tn nfp offset)) + (let ((imag-tn (complex-single-reg-imag-tn x))) + (inst stfs imag-tn nfp (+ offset n-word-bytes)))))))) +(define-move-vop move-complex-single-float-arg :move-arg + (complex-single-reg descriptor-reg) (complex-single-reg)) + +(define-vop (move-complex-double-float-arg) + (:args (x :scs (complex-double-reg) :target y) + (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-reg)))) + (:results (y)) + (:note "complex double-float arg move") + (:generator 2 + (sc-case y + (complex-double-reg + (unless (location= x y) + (let ((x-real (complex-double-reg-real-tn x)) + (y-real (complex-double-reg-real-tn y))) + (inst fmr y-real x-real)) + (let ((x-imag (complex-double-reg-imag-tn x)) + (y-imag (complex-double-reg-imag-tn y))) + (inst fmr y-imag x-imag)))) + (complex-double-stack + (let ((offset (* (tn-offset y) n-word-bytes))) + (let ((real-tn (complex-double-reg-real-tn x))) + (inst stfd real-tn nfp offset)) + (let ((imag-tn (complex-double-reg-imag-tn x))) + (inst stfd imag-tn nfp (+ offset (* 2 n-word-bytes))))))))) +(define-move-vop move-complex-double-float-arg :move-arg + (complex-double-reg descriptor-reg) (complex-double-reg)) + + +(define-move-vop move-arg :move-arg + (single-reg double-reg complex-single-reg complex-double-reg) + (descriptor-reg)) + + +;;;; Arithmetic VOPs: + +(define-vop (float-op) + (:args (x) (y)) + (:results (r)) + (:policy :fast-safe) + (:note "inline float arithmetic") + (:vop-var vop) + (:save-p :compute-only)) + +(macrolet ((frob (name sc ptype) + `(define-vop (,name float-op) + (:args (x :scs (,sc)) + (y :scs (,sc))) + (:results (r :scs (,sc))) + (:arg-types ,ptype ,ptype) + (:result-types ,ptype)))) + (frob single-float-op single-reg single-float) + (frob double-float-op double-reg double-float)) + +(macrolet ((frob (op sinst sname scost dinst dname dcost) + `(progn + (define-vop (,sname single-float-op) + (:translate ,op) + (:generator ,scost + (inst ,sinst r x y))) + (define-vop (,dname double-float-op) + (:translate ,op) + (:generator ,dcost + (inst ,dinst r x y)))))) + (frob + fadds +/single-float 2 fadd +/double-float 2) + (frob - fsubs -/single-float 2 fsub -/double-float 2) + (frob * fmuls */single-float 4 fmul */double-float 5) + (frob / fdivs //single-float 12 fdiv //double-float 19)) + +(macrolet ((frob (name inst translate sc type) + `(define-vop (,name) + (:args (x :scs (,sc))) + (:results (y :scs (,sc))) + (:translate ,translate) + (:policy :fast-safe) + (:arg-types ,type) + (:result-types ,type) + (:note "inline float arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:generator 1 + (note-this-location vop :internal-error) + (inst ,inst y x))))) + (frob abs/single-float fabs abs single-reg single-float) + (frob abs/double-float fabs abs double-reg double-float) + (frob %negate/single-float fneg %negate single-reg single-float) + (frob %negate/double-float fneg %negate double-reg double-float)) + + +;;;; Comparison: + +(define-vop (float-compare) + (:args (x) (y)) + (:conditional) + (:info target not-p) + (:variant-vars format yep nope) + (:policy :fast-safe) + (:note "inline float comparison") + (:vop-var vop) + (:save-p :compute-only) + (:generator 3 + (note-this-location vop :internal-error) + (ecase format + ((:single :double) + (inst fcmpo :cr1 x y))) + (inst b? :cr1 (if not-p nope yep) target))) + +(macrolet ((frob (name sc ptype) + `(define-vop (,name float-compare) + (:args (x :scs (,sc)) + (y :scs (,sc))) + (:arg-types ,ptype ,ptype)))) + (frob single-float-compare single-reg single-float) + (frob double-float-compare double-reg double-float)) + +(macrolet ((frob (translate yep nope sname dname) + `(progn + (define-vop (,sname single-float-compare) + (:translate ,translate) + (:variant :single ,yep ,nope)) + (define-vop (,dname double-float-compare) + (:translate ,translate) + (:variant :double ,yep ,nope))))) + (frob < :lt :ge :gt :le >/single-float >/double-float) + (frob = :eq :ne eql/single-float eql/double-float)) + + +;;;; Conversion: + +(macrolet ((frob (name translate inst to-sc to-type) + `(define-vop (,name) + (:args (x :scs (signed-reg))) + (:temporary (:scs (double-stack)) temp) + (:temporary (:scs (double-reg)) fmagic) + (:temporary (:scs (signed-reg)) rtemp) + (:results (y :scs (,to-sc))) + (:arg-types signed-num) + (:result-types ,to-type) + (:policy :fast-safe) + (:note "inline float coercion") + (:translate ,translate) + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (let* ((stack-offset (* (tn-offset temp) sb!vm:n-word-bytes)) + (nfp-tn (current-nfp-tn vop)) + (temp-offset-high (* stack-offset sb!vm:n-word-bytes)) + (temp-offset-low (* (1+ stack-offset) sb!vm:n-word-bytes))) + (inst lis rtemp #x4330) ; High word of magic constant + (inst stw rtemp nfp-tn temp-offset-high) + (inst lis rtemp #x8000) + (inst stw rtemp nfp-tn temp-offset-low) + (inst lfd fmagic nfp-tn temp-offset-high) + (inst xor rtemp rtemp x) ; invert sign bit of x : rtemp had #x80000000 + (inst stw rtemp nfp-tn temp-offset-low) + (inst lfd y nfp-tn temp-offset-high) + (note-this-location vop :internal-error) + (inst ,inst y y fmagic)))))) + (frob %single-float/signed %single-float fsubs single-reg single-float) + (frob %double-float/signed %double-float fsub double-reg double-float)) + +(macrolet ((frob (name translate inst from-sc from-type to-sc to-type) + `(define-vop (,name) + (:args (x :scs (,from-sc))) + (:results (y :scs (,to-sc))) + (:arg-types ,from-type) + (:result-types ,to-type) + (:policy :fast-safe) + (:note "inline float coercion") + (:translate ,translate) + (:vop-var vop) + (:save-p :compute-only) + (:generator 2 + (note-this-location vop :internal-error) + (inst ,inst y x))))) + (frob %single-float/double-float %single-float frsp + double-reg double-float single-reg single-float) + (frob %double-float/single-float %double-float fmr + single-reg single-float double-reg double-float)) + +(macrolet ((frob (trans from-sc from-type inst) + `(define-vop (,(symbolicate trans "/" from-type)) + (:args (x :scs (,from-sc) :target temp)) + (:temporary (:from (:argument 0) :sc single-reg) temp) + (:temporary (:scs (double-stack)) stack-temp) + (:results (y :scs (signed-reg) + :load-if (not (sc-is y signed-stack)))) + (:arg-types ,from-type) + (:result-types signed-num) + (:translate ,trans) + (:policy :fast-safe) + (:note "inline float truncate") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + (inst ,inst temp x) + (sc-case y + (signed-stack + (inst stfd temp (current-nfp-tn vop) + (* (tn-offset y) sb!vm:n-word-bytes))) + (signed-reg + (inst stfd temp (current-nfp-tn vop) + (* (tn-offset stack-temp) sb!vm:n-word-bytes)) + (inst lwz y (current-nfp-tn vop) + (+ 4 (* (tn-offset stack-temp) sb!vm:n-word-bytes))))))))) + (frob %unary-truncate single-reg single-float fctiwz) + (frob %unary-truncate double-reg double-float fctiwz) + (frob %unary-round single-reg single-float fctiw) + (frob %unary-round double-reg double-float fctiw)) + + + +(define-vop (make-single-float) + (:args (bits :scs (signed-reg) :target res + :load-if (not (sc-is bits signed-stack)))) + (:results (res :scs (single-reg) + :load-if (not (sc-is res single-stack)))) + (:temporary (:scs (signed-reg) :from (:argument 0) :to (:result 0)) temp) + (:temporary (:scs (signed-stack)) stack-temp) + (:arg-types signed-num) + (:result-types single-float) + (:translate make-single-float) + (:policy :fast-safe) + (:vop-var vop) + (:generator 4 + (sc-case bits + (signed-reg + (sc-case res + (single-reg + (inst stw bits (current-nfp-tn vop) + (* (tn-offset stack-temp) sb!vm:n-word-bytes)) + (inst lfs res (current-nfp-tn vop) + (* (tn-offset stack-temp) sb!vm:n-word-bytes))) + (single-stack + (inst stw bits (current-nfp-tn vop) + (* (tn-offset res) sb!vm:n-word-bytes))))) + (signed-stack + (sc-case res + (single-reg + (inst lfs res (current-nfp-tn vop) + (* (tn-offset bits) sb!vm:n-word-bytes))) + (single-stack + (unless (location= bits res) + (inst lwz temp (current-nfp-tn vop) + (* (tn-offset bits) sb!vm:n-word-bytes)) + (inst stw temp (current-nfp-tn vop) + (* (tn-offset res) sb!vm:n-word-bytes))))))))) + +(define-vop (make-double-float) + (:args (hi-bits :scs (signed-reg)) + (lo-bits :scs (unsigned-reg))) + (:results (res :scs (double-reg) + :load-if (not (sc-is res double-stack)))) + (:temporary (:scs (double-stack)) temp) + (:arg-types signed-num unsigned-num) + (:result-types double-float) + (:translate make-double-float) + (:policy :fast-safe) + (:vop-var vop) + (:generator 2 + (let ((stack-tn (sc-case res + (double-stack res) + (double-reg temp)))) + (inst stw hi-bits (current-nfp-tn vop) + (* (tn-offset stack-tn) sb!vm:n-word-bytes)) + (inst stw lo-bits (current-nfp-tn vop) + (* (1+ (tn-offset stack-tn)) sb!vm:n-word-bytes))) + (when (sc-is res double-reg) + (inst lfd res (current-nfp-tn vop) + (* (tn-offset temp) sb!vm:n-word-bytes))))) + +(define-vop (single-float-bits) + (:args (float :scs (single-reg descriptor-reg) + :load-if (not (sc-is float single-stack)))) + (:results (bits :scs (signed-reg) + :load-if (or (sc-is float descriptor-reg single-stack) + (not (sc-is bits signed-stack))))) + (:temporary (:scs (signed-stack)) stack-temp) + (:arg-types single-float) + (:result-types signed-num) + (:translate single-float-bits) + (:policy :fast-safe) + (:vop-var vop) + (:generator 4 + (sc-case bits + (signed-reg + (sc-case float + (single-reg + (inst stfs float (current-nfp-tn vop) + (* (tn-offset stack-temp) sb!vm:n-word-bytes)) + (inst lwz bits (current-nfp-tn vop) + (* (tn-offset stack-temp) sb!vm:n-word-bytes))) + (single-stack + (inst lwz bits (current-nfp-tn vop) + (* (tn-offset float) sb!vm:n-word-bytes))) + (descriptor-reg + (loadw bits float sb!vm:single-float-value-slot sb!vm:other-pointer-lowtag)))) + (signed-stack + (sc-case float + (single-reg + (inst stfs float (current-nfp-tn vop) + (* (tn-offset bits) sb!vm:n-word-bytes)))))))) + +(define-vop (double-float-high-bits) + (:args (float :scs (double-reg descriptor-reg) + :load-if (not (sc-is float double-stack)))) + (:results (hi-bits :scs (signed-reg) + :load-if (or (sc-is float descriptor-reg double-stack) + (not (sc-is hi-bits signed-stack))))) + (:temporary (:scs (signed-stack)) stack-temp) + (:arg-types double-float) + (:result-types signed-num) + (:translate double-float-high-bits) + (:policy :fast-safe) + (:vop-var vop) + (:generator 5 + (sc-case hi-bits + (signed-reg + (sc-case float + (double-reg + (inst stfd float (current-nfp-tn vop) + (* (tn-offset stack-temp) sb!vm:n-word-bytes)) + (inst lwz hi-bits (current-nfp-tn vop) + (* (tn-offset stack-temp) sb!vm:n-word-bytes))) + (double-stack + (inst lwz hi-bits (current-nfp-tn vop) + (* (tn-offset float) sb!vm:n-word-bytes))) + (descriptor-reg + (loadw hi-bits float sb!vm:double-float-value-slot + sb!vm:other-pointer-lowtag)))) + (signed-stack + (sc-case float + (double-reg + (inst stfd float (current-nfp-tn vop) + (* (tn-offset hi-bits) sb!vm:n-word-bytes)))))))) + +(define-vop (double-float-low-bits) + (:args (float :scs (double-reg descriptor-reg) + :load-if (not (sc-is float double-stack)))) + (:results (lo-bits :scs (unsigned-reg) + :load-if (or (sc-is float descriptor-reg double-stack) + (not (sc-is lo-bits unsigned-stack))))) + (:temporary (:scs (unsigned-stack)) stack-temp) + (:arg-types double-float) + (:result-types unsigned-num) + (:translate double-float-low-bits) + (:policy :fast-safe) + (:vop-var vop) + (:generator 5 + (sc-case lo-bits + (unsigned-reg + (sc-case float + (double-reg + (inst stfd float (current-nfp-tn vop) + (* (tn-offset stack-temp) sb!vm:n-word-bytes)) + (inst lwz lo-bits (current-nfp-tn vop) + (* (1+ (tn-offset stack-temp)) sb!vm:n-word-bytes))) + (double-stack + (inst lwz lo-bits (current-nfp-tn vop) + (* (1+ (tn-offset float)) sb!vm:n-word-bytes))) + (descriptor-reg + (loadw lo-bits float (1+ sb!vm:double-float-value-slot) + sb!vm:other-pointer-lowtag)))) + (unsigned-stack + (sc-case float + (double-reg + (inst stfd float (current-nfp-tn vop) + (* (tn-offset lo-bits) sb!vm:n-word-bytes)))))))) + + +;;;; Float mode hackery: + +(sb!xc:deftype float-modes () '(unsigned-byte 32)) +(defknown floating-point-modes () float-modes (flushable)) +(defknown ((setf floating-point-modes)) (float-modes) + float-modes) + +(define-vop (floating-point-modes) + (:results (res :scs (unsigned-reg))) + (:result-types unsigned-num) + (:translate floating-point-modes) + (:policy :fast-safe) + (:vop-var vop) + (:temporary (:sc double-stack) temp) + (:temporary (:sc single-reg) fp-temp) + (:generator 3 + (let ((nfp (current-nfp-tn vop))) + (inst mffs fp-temp) + (inst stfd fp-temp nfp (* n-word-bytes (tn-offset temp))) + (loadw res nfp (1+ (tn-offset temp)))))) + +(define-vop (set-floating-point-modes) + (:args (new :scs (unsigned-reg) :target res)) + (:results (res :scs (unsigned-reg))) + (:arg-types unsigned-num) + (:result-types unsigned-num) + (:translate (setf floating-point-modes)) + (:policy :fast-safe) + (:temporary (:sc double-stack) temp) + (:temporary (:sc single-reg) fp-temp) + (:vop-var vop) + (:generator 3 + (let ((nfp (current-nfp-tn vop))) + (storew new nfp (1+ (tn-offset temp))) + (inst lfd fp-temp nfp (* n-word-bytes (tn-offset temp))) + (inst mtfsf 255 fp-temp) + (move res new)))) + + +;;;; Complex float VOPs + +(define-vop (make-complex-single-float) + (:translate complex) + (:args (real :scs (single-reg) :target r + :load-if (not (location= real r))) + (imag :scs (single-reg) :to :save)) + (:arg-types single-float single-float) + (:results (r :scs (complex-single-reg) :from (:argument 0) + :load-if (not (sc-is r complex-single-stack)))) + (:result-types complex-single-float) + (:note "inline complex single-float creation") + (:policy :fast-safe) + (:vop-var vop) + (:generator 5 + (sc-case r + (complex-single-reg + (let ((r-real (complex-single-reg-real-tn r))) + (unless (location= real r-real) + (inst fmr r-real real))) + (let ((r-imag (complex-single-reg-imag-tn r))) + (unless (location= imag r-imag) + (inst fmr r-imag imag)))) + (complex-single-stack + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset r) sb!vm:n-word-bytes))) + (unless (location= real r) + (inst stfs real nfp offset)) + (inst stfs imag nfp (+ offset sb!vm:n-word-bytes))))))) + +(define-vop (make-complex-double-float) + (:translate complex) + (:args (real :scs (double-reg) :target r + :load-if (not (location= real r))) + (imag :scs (double-reg) :to :save)) + (:arg-types double-float double-float) + (:results (r :scs (complex-double-reg) :from (:argument 0) + :load-if (not (sc-is r complex-double-stack)))) + (:result-types complex-double-float) + (:note "inline complex double-float creation") + (:policy :fast-safe) + (:vop-var vop) + (:generator 5 + (sc-case r + (complex-double-reg + (let ((r-real (complex-double-reg-real-tn r))) + (unless (location= real r-real) + (inst fmr r-real real))) + (let ((r-imag (complex-double-reg-imag-tn r))) + (unless (location= imag r-imag) + (inst fmr r-imag imag)))) + (complex-double-stack + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset r) sb!vm:n-word-bytes))) + (unless (location= real r) + (inst stfd real nfp offset)) + (inst stfd imag nfp (+ offset (* 2 sb!vm:n-word-bytes)))))))) + + +(define-vop (complex-single-float-value) + (:args (x :scs (complex-single-reg) :target r + :load-if (not (sc-is x complex-single-stack)))) + (:arg-types complex-single-float) + (:results (r :scs (single-reg))) + (:result-types single-float) + (:variant-vars slot) + (:policy :fast-safe) + (:vop-var vop) + (:generator 3 + (sc-case x + (complex-single-reg + (let ((value-tn (ecase slot + (:real (complex-single-reg-real-tn x)) + (:imag (complex-single-reg-imag-tn x))))) + (unless (location= value-tn r) + (inst fmr r value-tn)))) + (complex-single-stack + (inst lfs r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 1)) + (tn-offset x)) + sb!vm:n-word-bytes)))))) + +(define-vop (realpart/complex-single-float complex-single-float-value) + (:translate realpart) + (:note "complex single float realpart") + (:variant :real)) + +(define-vop (imagpart/complex-single-float complex-single-float-value) + (:translate imagpart) + (:note "complex single float imagpart") + (:variant :imag)) + +(define-vop (complex-double-float-value) + (:args (x :scs (complex-double-reg) :target r + :load-if (not (sc-is x complex-double-stack)))) + (:arg-types complex-double-float) + (:results (r :scs (double-reg))) + (:result-types double-float) + (:variant-vars slot) + (:policy :fast-safe) + (:vop-var vop) + (:generator 3 + (sc-case x + (complex-double-reg + (let ((value-tn (ecase slot + (:real (complex-double-reg-real-tn x)) + (:imag (complex-double-reg-imag-tn x))))) + (unless (location= value-tn r) + (inst fmr r value-tn)))) + (complex-double-stack + (inst lfd r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 2)) + (tn-offset x)) + sb!vm:n-word-bytes)))))) + +(define-vop (realpart/complex-double-float complex-double-float-value) + (:translate realpart) + (:note "complex double float realpart") + (:variant :real)) + +(define-vop (imagpart/complex-double-float complex-double-float-value) + (:translate imagpart) + (:note "complex double float imagpart") + (:variant :imag)) + + diff --git a/src/compiler/ppc/insts.lisp b/src/compiler/ppc/insts.lisp new file mode 100644 index 0000000..8ccf258 --- /dev/null +++ b/src/compiler/ppc/insts.lisp @@ -0,0 +1,2065 @@ +;;; +;;; Written by William Lott +;;; + +(in-package "SB!VM") + +;(def-assembler-params +; :scheduler-p nil ; t when we trust the scheduler not to "fill delay slots" +; :max-locations 70) + + + +;;;; Constants, types, conversion functions, some disassembler stuff. + +(defun reg-tn-encoding (tn) + (declare (type tn tn)) + (sc-case tn + (zero zero-offset) + (null null-offset) + (t + (if (eq (sb-name (sc-sb (tn-sc tn))) 'registers) + (tn-offset tn) + (error "~S isn't a register." tn))))) + +(defun fp-reg-tn-encoding (tn) + (declare (type tn tn)) + (unless (eq (sb-name (sc-sb (tn-sc tn))) 'float-registers) + (error "~S isn't a floating-point register." tn)) + (tn-offset tn)) + +;(sb!disassem:set-disassem-params :instruction-alignment 32) + +(defvar *disassem-use-lisp-reg-names* t) + +(!def-vm-support-routine location-number (loc) + (etypecase loc + (null) + (number) + (label) + (fixup) + (tn + (ecase (sb-name (sc-sb (tn-sc loc))) + (immediate-constant + ;; Can happen if $ZERO or $NULL are passed in. + nil) + (registers + (unless (zerop (tn-offset loc)) + (tn-offset loc))) + (float-registers + (+ (tn-offset loc) 32)))) + (symbol + (ecase loc + (:memory 0) + (:ccr 64) + (:xer 65) + (:lr 66) + (:ctr 67) + (:fpscr 68))))) + +(defparameter reg-symbols + (map 'vector + #'(lambda (name) + (cond ((null name) nil) + (t (make-symbol (concatenate 'string "$" name))))) + *register-names*)) + +(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)))) + +(defparameter float-reg-symbols + (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)))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter bo-kind-names + #(:bo-dnzf :bo-dnzfp :bo-dzf :bo-dzfp :bo-f :bo-fp nil nil + :bo-dnzt :bo-dnztp :bo-dzt :bo-dztp :bo-t :bo-tp nil nil + :bo-dnz :bo-dnzp :bo-dz :bo-dzp :bo-u nil nil nil + nil nil nil nil nil nil nil nil))) + +(sb!disassem:define-arg-type bo-field + :printer #'(lambda (value stream dstate) + (declare (ignore dstate) + (type stream stream) + (type fixnum value)) + (princ (svref bo-kind-names value) stream))) + +(eval-when (:compile-toplevel :load-toplevel :execute) +(defun valid-bo-encoding (enc) + (or (if (integerp enc) + (and (= enc (logand #x1f enc)) + (not (null (svref bo-kind-names enc))) + enc) + (and enc (position enc bo-kind-names))) + (error "Invalid BO field spec: ~s" enc))) +) + + +(defparameter cr-bit-names #(:lt :gt :eq :so)) +(defparameter cr-bit-inverse-names #(:ge :le :ne :ns)) + +(defparameter cr-field-names #(:cr0 :cr1 :cr2 :cr3 :cr4 :cr5 :cr6 :cr7)) + +(defun valid-cr-bit-encoding (enc &optional error-p) + (or (if (integerp enc) + (and (= enc (logand 3 enc)) + enc)) + (position enc cr-bit-names) + (if error-p (error "Invalid condition bit specifier : ~s" enc)))) + +(defun valid-cr-field-encoding (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) + (and (= enc (logand 31 enc)) enc) + (position enc cr-bit-names)) + (+ (valid-cr-field-encoding (car enc)) + (valid-cr-bit-encoding (cadr enc)))) + (error "Invalid BI field spec : ~s" enc))) + +(sb!disassem:define-arg-type bi-field + :printer #'(lambda (value stream dstate) + (declare (ignore dstate) + (type stream stream) + (type (unsigned-byte 5) value)) + (let* ((bitname (svref cr-bit-names (logand 3 value))) + (crfield (ash value -2))) + (declare (type (unsigned-byte 3) crfield)) + (if (= crfield 0) + (princ bitname stream) + (princ (list (svref cr-field-names crfield) bitname) stream))))) + +(sb!disassem:define-arg-type crf + :printer #'(lambda (value stream dstate) + (declare (ignore dstate) + (type stream stream) + (type (unsigned-byte 3) value)) + (princ (svref cr-field-names value) stream))) + +(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)))) + +(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) + (declare (ignore dstate) + (type stream stream) + (type fixnum value)) + (princ (or (car (rassoc value trap-values-alist)) + value) + stream))) + +(defun snarf-error-junk (sap offset &optional length-only) + (let* ((length (sb!sys:sap-ref-8 sap offset)) + (vector (make-array length :element-type '(unsigned-byte 8)))) + (declare (type sb!sys:system-area-pointer sap) + (type (unsigned-byte 8) length) + (type (simple-array (unsigned-byte 8) (*)) vector)) + (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)) + (collect ((sc-offsets) + (lengths)) + (lengths 1) ; the length byte + (let* ((index 0) + (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)) + (lengths (- index old-index)))) + (values error-number + (1+ length) + (sc-offsets) + (lengths)))))))) + +(defun emit-conditional-branch (segment bo bi target &optional aa-p lk-p) + (declare (type boolean aa-p lk-p)) + (let* ((bo (valid-bo-encoding bo)) + (bi (valid-bi-encoding bi)) + (aa-bit (if aa-p 1 0)) + (lk-bit (if lk-p 1 0))) + (if aa-p ; Not bloody likely, bwth. + (emit-b-form-inst segment 16 bo bi target aa-bit lk-bit) + ;; the target may be >32k away, in which case we have to invert the + ;; test and do an absolute branch + (emit-chooser + ;; We emit either 4 or 8 bytes, so I think we declare this as + ;; preserving 4 byte alignment. If this gives us no joy, we can + ;; stick a nop in the long branch and then we will be + ;; 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))) + #'(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))))) + )))) + + + +; non-absolute I-form: B, BL. +(defun emit-i-form-branch (segment target &optional lk-p) + (let* ((lk-bit (if lk-p 1 0))) + (etypecase target + (fixup + (note-fixup segment :b target) + (emit-i-form-inst segment 18 0 0 lk-bit)) + (label + (emit-back-patch segment 4 + #'(lambda (segment posn) + (emit-i-form-inst + segment + 18 + (ash (- (label-position target) posn) -2) + 0 + lk-bit))))))) + +(eval-when (:compile-toplevel :execute :load-toplevel) +(defparameter *spr-numbers-alist* '((:xer 1) (:lr 8) (:ctr 9)))) + +(sb!disassem:define-arg-type spr + :printer #'(lambda (value stream dstate) + (declare (ignore dstate) + (type (unsigned-byte 10) value)) + (let* ((name (car (rassoc value *spr-numbers-alist*)))) + (if name + (princ name stream) + (princ value stream))))) + +(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))))) + + + +;;;; dissassem:define-instruction-formats + +(eval-when (:compile-toplevel :execute) + (defmacro ppc-byte (startbit &optional (endbit startbit)) + (unless (and (typep startbit '(unsigned-byte 32)) + (typep endbit '(unsigned-byte 32)) + (>= endbit startbit)) + (error "Bad bits.")) + ``(byte ,(1+ ,(- endbit startbit)) ,(- 31 ,endbit))) + + (defparameter *ppc-field-specs-alist* + `((aa :field ,(ppc-byte 30)) + (ba :field ,(ppc-byte 11 15) :type 'bi-field) + (bb :field ,(ppc-byte 16 20) :type 'bi-field) + (bd :field ,(ppc-byte 16 29) :type 'relative-label) + (bf :field ,(ppc-byte 6 8) :type 'crf) + (bfa :field ,(ppc-byte 11 13) :type 'crf) + (bi :field ,(ppc-byte 11 15) :type 'bi-field) + (bo :field ,(ppc-byte 6 10) :type 'bo-field) + (bt :field ,(ppc-byte 6 10) :type 'bi-field) + (d :field ,(ppc-byte 16 31) :sign-extend t) + (flm :field ,(ppc-byte 7 14) :sign-extend nil) + (fra :field ,(ppc-byte 11 15) :type 'fp-reg) + (frb :field ,(ppc-byte 16 20) :type 'fp-reg) + (frc :field ,(ppc-byte 21 25) :type 'fp-reg) + (frs :field ,(ppc-byte 6 10) :type 'fp-reg) + (frt :field ,(ppc-byte 6 10) :type 'fp-reg) + (fxm :field ,(ppc-byte 12 19) :sign-extend nil) + (l :field ,(ppc-byte 10) :sign-extend nil) + (li :field ,(ppc-byte 6 29) :sign-extend t :type 'relative-label) + (li-abs :field ,(ppc-byte 6 29) :sign-extend t :printer jump-printer) + (lk :field ,(ppc-byte 31)) + (mb :field ,(ppc-byte 21 25) :sign-extend nil) + (me :field ,(ppc-byte 26 30) :sign-extend nil) + (nb :field ,(ppc-byte 16 20) :sign-extend nil) + (oe :field ,(ppc-byte 21)) + (ra :field ,(ppc-byte 11 15) :type 'reg) + (rb :field ,(ppc-byte 16 20) :type 'reg) + (rc :field ,(ppc-byte 31)) + (rs :field ,(ppc-byte 6 10) :type 'reg) + (rt :field ,(ppc-byte 6 10) :type 'reg) + (sh :field ,(ppc-byte 16 20) :sign-extend nil) + (si :field ,(ppc-byte 16 31) :sign-extend t) + (spr :field ,(ppc-byte 11 20) :type 'spr) + (to :field ,(ppc-byte 6 10) :type 'to-field) + (u :field ,(ppc-byte 16 19) :sign-extend nil) + (ui :field ,(ppc-byte 16 31) :sign-extend nil) + (xo21-30 :field ,(ppc-byte 21 30) :sign-extend nil) + (xo22-30 :field ,(ppc-byte 22 30) :sign-extend nil) + (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))) + +(sb!disassem:define-instruction-format (xinstr 32 :default-printer '(:name :tab data)) + (op-to-a :field (byte 16 16)) + (data :field (byte 16 0))) + +(sb!disassem:define-instruction-format (sc 32 :default-printer '(:name :tab rest)) + (op :field (byte 6 26)) + (rest :field (byte 26 0) :value 2)) + + + +(macrolet ((def-ppc-iformat ((name &optional default-printer) &rest specs) + (flet ((specname-field (specname) + (or (assoc specname *ppc-field-specs-alist*) + (error "Unknown ppc instruction field spec ~s" specname)))) + (labels ((spec-field (spec) + (if (atom spec) + (specname-field spec) + (cons (car spec) + (cdr (specname-field (cadr spec))))))) + (collect ((field (list '(op :field (byte 6 26))))) + (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)) + li aa lk) + +(def-ppc-iformat (i-abs '(:name :tab li-abs)) + li-abs aa lk) + +(def-ppc-iformat (b '(:name :tab bo "," bi "," bd)) + bo bi bd aa lk) + +(def-ppc-iformat (d '(:name :tab rt "," d "(" ra ")")) + rt ra d) + +(def-ppc-iformat (d-si '(:name :tab rt "," ra "," si )) + rt ra si) + +(def-ppc-iformat (d-rs '(:name :tab rs "," d "(" ra ")")) + rs ra d) + +(def-ppc-iformat (d-rs-ui '(:name :tab ra "," rs "," ui)) + rs ra ui) + +(def-ppc-iformat (d-crf-si) + bf l ra si) + +(def-ppc-iformat (d-crf-ui) + bf l ra ui) + +(def-ppc-iformat (d-to '(:name :tab to "," ra "," si)) + to ra rb si) + +(def-ppc-iformat (d-frt '(:name :tab frt "," d "(" ra ")")) + frt ra d) + +(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. +;;; Some of them are only used by one instruction; some are used by dozens. +;;; Some aren't used by instructions that we generate ... + +(def-ppc-iformat (x '(:name :tab rt "," ra "," rb)) + rt ra rb (xo xo21-30)) + +(def-ppc-iformat (x-1 '(:name :tab rt "," ra "," nb)) + rt ra nb (xo xo21-30)) + +(def-ppc-iformat (x-4 '(:name :tab rt)) + rt (xo xo21-30)) + +(def-ppc-iformat (x-5 '(:name :tab ra "," rs "," rb)) + rs ra rb (xo xo21-30) rc) + +(def-ppc-iformat (x-7 '(:name :tab ra "," rs "," rb)) + rs ra rb (xo xo21-30)) + +(def-ppc-iformat (x-8 '(:name :tab ra "," rs "," nb)) + rs ra nb (xo xo21-30)) + +(def-ppc-iformat (x-9 '(:name :tab ra "," rs "," sh)) + rs ra sh (xo xo21-30) rc) + +(def-ppc-iformat (x-10 '(:name :tab ra "," rs)) + rs ra (xo xo21-30) rc) + +(def-ppc-iformat (x-14 '(:name :tab bf "," l "," ra "," rb)) + bf l ra rb (xo xo21-30)) + +(def-ppc-iformat (x-15 '(:name :tab bf "," l "," fra "," frb)) + bf l fra frb (xo xo21-30)) + +(def-ppc-iformat (x-18 '(:name :tab bf)) + bf (xo xo21-30)) + +(def-ppc-iformat (x-19 '(:name :tab to "," ra "," rb)) + to ra rb (xo xo21-30)) + +(def-ppc-iformat (x-20 '(:name :tab frt "," ra "," rb)) + frt ra rb (xo xo21-30)) + +(def-ppc-iformat (x-21 '(:name :tab frt "," rb)) + frt rb (xo xo21-30) rc) + +(def-ppc-iformat (x-22 '(:name :tab frt)) + frt (xo xo21-30) rc) + +(def-ppc-iformat (x-23 '(:name :tab ra "," frs "," rb)) + frs ra rb (xo xo21-30)) + +(def-ppc-iformat (x-24 '(:name :tab bt)) + bt (xo xo21-30) rc) + +(def-ppc-iformat (x-25 '(:name :tab ra "," rb)) + ra rb (xo xo21-30)) + +(def-ppc-iformat (x-26 '(:name :tab rb)) + rb (xo xo21-30)) + +(def-ppc-iformat (x-27 '(:name)) + (xo xo21-30)) + + +;;;; + +(def-ppc-iformat (xl '(:name :tab bt "," ba "," bb)) + bt ba bb (xo xo21-30)) + +(def-ppc-iformat (xl-bo-bi '(:name :tab bo "," bi)) + bo bi (xo xo21-30) lk) + +(def-ppc-iformat (xl-cr '(:name :tab bf "," bfa)) + bf bfa (xo xo21-30)) + +(def-ppc-iformat (xl-xo '(:name)) + (xo xo21-30)) + + +;;;; + +(def-ppc-iformat (xfx) + rt spr (xo xo21-30)) + +(def-ppc-iformat (xfx-fxm '(:name :tab fxm "," rs)) + rs fxm (xo xo21-30)) + +(def-ppc-iformat (xfl '(:name :tab flm "," frb)) + flm frb (xo xo21-30) rc) + + +;;; + +(def-ppc-iformat (xo '(:name :tab rt "," ra "," rb)) + rt ra rb oe (xo xo22-30) rc) + +(def-ppc-iformat (xo-oe '(:name :tab rt "," ra "," rb)) + rt ra rb (xo xo22-30) rc) + +(def-ppc-iformat (xo-a '(:name :tab rt "," ra)) + rt ra oe (xo xo22-30) rc) + + +;;; + +(def-ppc-iformat (a '(:name :tab frt "," fra "," frb "," frc)) + frt fra frb frc (xo xo26-30) rc) + +(def-ppc-iformat (a-tab '(:name :tab frt "," fra "," frb)) + frt fra frb (xo xo26-30) rc) + +(def-ppc-iformat (a-tac '(:name :tab frt "," fra "," frc)) + frt fra frc (xo xo26-30) rc) + +(def-ppc-iformat (a-tbc '(:name :tab frt "," frb "," frc)) + frt frb frc (xo xo26-30) rc) + + +(def-ppc-iformat (m '(:name :tab ra "," rs "," rb "," mb "," me)) + rs ra rb mb me rc) + +(def-ppc-iformat (m-sh '(:name :tab ra "," rs "," sh "," mb "," me)) + rs ra sh mb me rc))) + + + + +;;;; Primitive emitters. + + +(define-bitfield-emitter emit-word 32 + (byte 32 0)) + +(define-bitfield-emitter emit-short 16 + (byte 16 0)) + +(define-bitfield-emitter emit-i-form-inst 32 + (byte 6 26) (byte 24 2) (byte 1 1) (byte 1 0)) + +(define-bitfield-emitter emit-b-form-inst 32 + (byte 6 26) (byte 5 21) (byte 5 16) (byte 14 2) (byte 1 1) (byte 1 0)) + +(define-bitfield-emitter emit-sc-form-inst 32 + (byte 6 26) (byte 26 0)) + +(define-bitfield-emitter emit-d-form-inst 32 + (byte 6 26) (byte 5 21) (byte 5 16) (byte 16 0)) + +; Also used for XL-form. What's the difference ? +(define-bitfield-emitter emit-x-form-inst 32 + (byte 6 26) (byte 5 21) (byte 5 16) (byte 5 11) (byte 10 1) (byte 1 0)) + +(define-bitfield-emitter emit-xfx-form-inst 32 + (byte 6 26) (byte 5 21) (byte 10 11) (byte 10 1) (byte 1 0)) + +(define-bitfield-emitter emit-xfl-form-inst 32 + (byte 6 26) (byte 10 16) (byte 5 11) (byte 10 1) (byte 1 0)) + +; XS is 64-bit only +(define-bitfield-emitter emit-xo-form-inst 32 + (byte 6 26) (byte 5 21) (byte 5 16) (byte 5 11) (byte 1 10) (byte 9 1) (byte 1 0)) + +(define-bitfield-emitter emit-a-form-inst 32 + (byte 6 26) (byte 5 21) (byte 5 16) (byte 5 11) (byte 5 6) (byte 5 1) (byte 1 0)) + + + + +(defun unimp-control (chunk inst stream dstate) + (declare (ignore inst)) + (flet ((nt (x) (if stream (sb!disassem:note x dstate)))) + (case (xinstr-data chunk dstate) + (#.sb!vm:error-trap + (nt "Error trap") + (sb!disassem:handle-break-args #'snarf-error-junk stream dstate)) + (#.sb!vm:cerror-trap + (nt "Cerror trap") + (sb!disassem:handle-break-args #'snarf-error-junk stream dstate)) + (#.sb!vm:object-not-list-trap + (nt "Object not list trap")) + (#.sb!vm:breakpoint-trap + (nt "Breakpoint trap")) + (#.sb!vm:pending-interrupt-trap + (nt "Pending interrupt trap")) + (#.sb!vm:halt-trap + (nt "Halt trap")) + (#.sb!vm:fun-end-breakpoint-trap + (nt "Function end breakpoint trap")) + (#.sb!vm:object-not-instance-trap + (nt "Object not instance trap")) + ))) + +(eval-when (:compile-toplevel :execute) + +(defun classify-dependencies (deplist) + (collect ((reads) (writes)) + (dolist (dep deplist) + (ecase (car dep) + (reads (reads dep)) + (writes (writes dep)))) + (values (reads) (writes))))) + +(macrolet ((define-xo-instruction + (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))) + (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 rb) + ,(if oe-p 1 0) + ,xo + ,(if rc-p 1 0))))) + (define-xo-oe-instruction + (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))) + (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 rb) + 0 + ,xo + (if ,rc-p 1 0))))) + (define-4-xo-instructions + (base op xo &key always-reads-xer always-writes-xer (cost 1)) + `(progn + (define-xo-instruction ,base ,op ,xo nil nil ,always-reads-xer ,always-writes-xer ,cost) + (define-xo-instruction ,(symbolicate base ".") ,op ,xo nil t ,always-reads-xer ,always-writes-xer ,cost) + (define-xo-instruction ,(symbolicate base "O") ,op ,xo t nil ,always-reads-xer ,always-writes-xer ,cost) + (define-xo-instruction ,(symbolicate base "O.") ,op ,xo t t ,always-reads-xer ,always-writes-xer ,cost))) + + (define-2-xo-oe-instructions (base op xo &key always-reads-xer always-writes-xer (cost 1)) + `(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)))) + (:dependencies (reads ra) ,@(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) + 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 + (writes rt) ,@other-writes) + (:emitter + (emit-x-form-inst segment ,op + (reg-tn-encoding rt) + (reg-tn-encoding ra) + (reg-tn-encoding rb) + ,xo + 0))))) + + (define-x-20-instruction (name op xo &key (cost 2) other-dependencies) + (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies) + `(define-instruction ,name (segment frt ra rb) + (:printer x-20 ((op ,op) (xo ,xo))) + (:delay ,cost) + (:cost ,cost) + (:dependencies (reads ra) (reads rb) ,@other-reads + (writes frt) ,@other-writes) + (:emitter + (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 + (writes ra) ,@other-writes) + (:emitter + (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-5-st-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 rs ra rb) + (: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) + (:emitter + (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) + (:emitter + (emit-x-form-inst segment ,op + (fp-reg-tn-encoding frs) + (reg-tn-encoding ra) + (reg-tn-encoding rb) + ,xo + 0))))) + + (define-x-10-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) + (:printer x-10 ((op ,op) (xo ,xo) (rc ,(if rc-p 1 0)))) + (:delay ,cost) + (:cost ,cost) + (:dependencies (reads rs) ,@other-reads + (writes ra) ,@other-writes) + (:emitter + (emit-x-form-inst segment ,op + (reg-tn-encoding rs) + (reg-tn-encoding ra) + 0 + ,xo + ,(if rc-p 1 0)))))) + + (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 + :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 + :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 + (writes frt) ,@other-writes) + (:emitter + (emit-x-form-inst segment ,op + (fp-reg-tn-encoding frt) + 0 + (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 + :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))) + (:printer d-si ((op ,op))) + (:delay ,cost) + (:cost ,cost) + (: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)) + (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) + (:declare (type (unsigned-byte 16) ui)) + (:printer d-rs-ui ((op ,op))) + (:cost ,cost) + (:delay ,cost) + (: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) + (:declare (type (signed-byte 16) si)) + (:printer d ((op ,op))) + (:delay ,cost) + (:cost ,cost) + ,@(when pinned '(:pinned)) + (:dependencies (reads ra) ,@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) + (:declare (type (signed-byte 16) si)) + (:printer d-frt ((op ,op))) + (:delay ,cost) + (:cost ,cost) + (:dependencies (reads ra) ,@other-reads + (writes frt) ,@other-writes) + (:emitter + (emit-d-form-inst segment ,op (fp-reg-tn-encoding frt) (reg-tn-encoding ra) si))))) + + (define-d-rs-instruction (name op &key (cost 1) other-dependencies pinned) + (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies) + `(define-instruction ,name (segment rs ra si) + (:declare (type (signed-byte 16) si)) + (:printer d-rs ((op ,op))) + (:delay ,cost) + (:cost ,cost) + ,@(when pinned '(:pinned)) + (: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))))) + + (define-d-frs-instruction (name op &key (cost 1) other-dependencies) + (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies) + `(define-instruction ,name (segment frs ra si) + (:declare (type (signed-byte 16) si)) + (:printer d-frs ((op ,op))) + (:delay ,cost) + (:cost ,cost) + (: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))))) + + (define-a-instruction (name op xo rc &key (cost 1) other-dependencies) + `(define-instruction ,name (segment frt fra frb frc) + (:printer a ((op ,op) (xo ,xo) (rc ,rc))) + (:cost ,cost) + (: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) + (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) + (:printer a-tab ((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) + (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) + (: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) + 0 + (fp-reg-tn-encoding frc) + ,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))) + (:delay 1) + (:cost 1) + (:dependencies (reads :ccr) (writes :ccr)) + (:emitter (emit-x-form-inst segment 19 + (valid-bi-encoding dbit) + (valid-bi-encoding abit) + (valid-bi-encoding bbit) + ,xo + 0))))) + + ;;; The instructions, in numerical order + + (define-instruction unimp (segment data) + (:declare (type (signed-byte 16) data)) + (:printer xinstr ((op-to-a #.(logior (ash 3 10) (ash 6 5) 0))) + :default :control #'unimp-control) + :pinned + (:delay 0) + (:emitter (emit-d-form-inst segment 3 6 0 data))) + + (define-instruction twi (segment tcond ra si) + (:printer d-to ((op 3))) + (:delay 1) + :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 + (unless ui-p + (setq ui ra ra crf crf :cr0)) + (emit-d-form-inst segment + 10 + (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 + (unless si-p + (setq si ra ra crf crf :cr0)) + (emit-d-form-inst segment + 11 + (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 + ;; to the CTR + ;; (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) + (: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) + (: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) + (: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) + (: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 ... + + (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) + (: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) + (: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) + (: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 + (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 + :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) + :pinned + (:emitter (emit-sc-form-inst segment 17 2))) + + (define-instruction b (segment target) + (:printer i ((op 18) (aa 0) (lk 0))) + (:delay 1) + (:emitter + (emit-i-form-branch segment target nil))) + + (define-instruction ba (segment target) + (:printer i-abs ((op 18) (aa 1) (lk 0))) + (:delay 1) + (: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) + (:emitter + (emit-i-form-branch segment target t))) + + (define-instruction bla (segment target) + (:printer i-abs ((op 18) (aa 1) (lk 1))) + (:delay 1) + (: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) + (: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) + (: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) + (: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) + (:printer xl-xo ((op 19) (xo 150))) + (: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) + (: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) + (: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) + (: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) + (: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) + (:dependencies (reads rs) (writes ra) (writes :ccr)) + (:emitter + (emit-a-form-inst segment 21 (reg-tn-encoding rs) (reg-tn-encoding ra) sh mb me 1))) + + (define-instruction rlwnm (segment ra rs rb mb me) + (:printer m ((op 23) (rc 0) (rb nil :type 'reg))) + (:delay 1) + (: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 + (unless rb-p + (setq rb ra ra crf crf :cr0)) + (emit-x-form-inst segment + 31 + (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) + :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 + (unless rb-p + (setq rb ra ra crf crf :cr0)) + (emit-x-form-inst segment + 31 + (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))) + (define-4-xo-a-instructions subfze 31 200 :always-reads-xer t :always-writes-xer t) + (define-4-xo-a-instructions addze 31 202 :always-reads-xer t :always-writes-xer t) + (define-x-5-st-instruction stbx 31 215 nil) + (define-4-xo-a-instructions subfme 31 232 :always-reads-xer t :always-writes-xer t) + (define-4-xo-a-instructions addme 31 234 :always-reads-xer t :always-writes-xer t) + (define-4-xo-instructions mullw 31 235 :cost 5) + (define-x-5-st-instruction stbux 31 247 nil :other-dependencies ((writes ra))) + (define-4-xo-instructions add 31 266) + (define-x-instruction lhzx 31 279) + (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) + (t :name)) + :tab + ra "," rs + (:unless (:same-as rs) "," rb))) + (:delay 1) + (:cost 1) + (:dependencies (reads rb) (reads rs) (writes ra)) + (:emitter + (emit-x-form-inst segment + 31 + (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.) + (t :name)) + :tab + ra "," rs + (:unless (:same-as rs) "," rb))) + (:delay 1) + (:cost 1) + (:dependencies (reads rb) (reads rs) (writes ra)) + (:emitter + (emit-x-form-inst segment + 31 + (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) + (:printer x-18 ((op 31) (xo 512))) + (: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) + (:printer x ((op 31) (xo 533) (rc 0))) + (:delay 1) + :pinned + (: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) + (:printer x-1 ((op 31) (xo 597) (rc 0))) + :pinned + (:delay 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) + :pinned + (: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) + (:printer x-5 ((op 31) (xo 661))) + :pinned + (: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 + 0))) + (define-x-5-st-instruction stwbrx 31 662 nil) + (define-x-23-st-instruction stfsx 31 663) + (define-x-23-st-instruction stfsux 31 695 :other-dependencies ((writes ra))) + (define-instruction stswi (segment rs ra nb) + (:printer x-8 ((op 31) (xo 725))) + :pinned + (:delay 1) + (:emitter + (emit-x-form-inst segment 31 + (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) + (:delay 1) + (:dependencies (reads rs) (writes ra)) + (:emitter + (emit-x-form-inst segment 31 + (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)) + (:emitter + (emit-x-form-inst segment 31 + (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)) + (: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))) + (define-d-rs-instruction stw 36) + (define-d-rs-instruction stwu 37 :other-dependencies ((writes ra))) + (define-d-rs-instruction stb 38) + (define-d-rs-instruction stbu 39 :other-dependencies ((writes ra))) + (define-d-instruction lhz 40) + (define-d-instruction lhzu 41 :other-dependencies ((writes ra))) + (define-d-instruction lha 42) + (define-d-instruction lhau 43 :other-dependencies ((writes ra))) + (define-d-rs-instruction sth 44) + (define-d-rs-instruction sthu 45 :other-dependencies ((writes ra))) + (define-d-instruction lmw 46 :pinned t) + (define-d-rs-instruction stmw 47 :pinned t) + (define-d-frt-instruction lfs 48) + (define-d-frt-instruction lfsu 49 :other-dependencies ((writes ra))) + (define-d-frt-instruction lfd 50) + (define-d-frt-instruction lfdu 51 :other-dependencies ((writes ra))) + (define-d-frs-instruction stfs 52) + (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) + (define-2-a-tac-instructions fmuls 59 25) + (define-2-a-instructions fmsubs 59 28 :cost 4) + (define-2-a-instructions fmadds 59 29 :cost 4) + (define-2-a-instructions fnmsubs 59 30 :cost 4) + (define-2-a-instructions fnmadds 59 31 :cost 4) + + (define-instruction fcmpu (segment crfd fra frb) + (:printer x-15 ((op 63) (xo 0))) + (:dependencies (reads fra) (reads frb) (reads :fpscr) + (writes :fpscr) (writes :ccr)) + (:cost 4) + (:delay 4) + (:emitter (emit-x-form-inst segment + 63 + (valid-cr-field-encoding crfd) + (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) + (define-2-a-tac-instructions fmul 63 25 :cost 5) + (define-2-a-instructions fmsub 63 28 :cost 5) + (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) + (writes :fpscr) (writes :ccr)) + (:cost 4) + (:delay 1) + (:emitter (emit-x-form-inst segment + 63 + (valid-cr-field-encoding crfd) + (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 + (fp-reg-tn-encoding frd) + 0 + 0 + 583 + 0))) + + (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 + (fp-reg-tn-encoding frd) + 0 + 0 + 583 + 1))) + + (define-instruction mtfsf (segment mask rb) + (:printer xfl ((op 63) (xo 711) (rc 0))) + (:dependencies (reads rb) (writes :fpscr)) + (:delay 1) + (:emitter (emit-xfl-form-inst segment 63 (ash mask 1) (fp-reg-tn-encoding rb) 711 0))) + + (define-instruction mtfsf. (segment mask rb) + (:printer xfl ((op 63) (xo 711) (rc 1))) + (:delay 1) + (:dependencies (reads rb) (writes :ccr) (writes :fpscr)) + (:emitter (emit-xfl-form-inst segment 63 (ash mask 1) (fp-reg-tn-encoding rb) 711 1))) + + + + +;;; Here in the future, macros are our friends. + + (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) + `(inst subf. ,rt ,ra ,rb)) + (define-instruction-macro subo (rt rb ra) + `(inst subfo ,rt ,ra ,rb)) + (define-instruction-macro subo. (rt rb ra) + `(inst subfo. ,rt ,ra ,rb)) + + + (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) + `(inst subfc. ,rt ,ra ,rb)) + (define-instruction-macro subco (rt rb ra) + `(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) + (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 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 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 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 + ((define-conditional-branches (name bo-name) + (let* ((bo-enc (valid-bo-encoding bo-name))) + `(progn + (define-instruction-macro ,(symbolicate name "A") (bi target) + ``(inst bca ,,,bo-enc ,,bi ,,target)) + (define-instruction-macro ,(symbolicate name "L") (bi target) + ``(inst bcl ,,,bo-enc ,,bi ,,target)) + (define-instruction-macro ,(symbolicate name "LA") (bi target) + ``(inst bcla ,,,bo-enc ,,bi ,,target)) + (define-instruction-macro ,(symbolicate name "CTR") (bi target) + ``(inst bcctr ,,,bo-enc ,,bi ,,target)) + (define-instruction-macro ,(symbolicate name "CTRL") (bi target) + ``(inst bcctrl ,,,bo-enc ,,bi ,,target)) + (define-instruction-macro ,(symbolicate name "LR") (bi target) + ``(inst bclr ,,,bo-enc ,,bi ,,target)) + (define-instruction-macro ,(symbolicate name "LRL") (bi target) + ``(inst bclrl ,,,bo-enc ,,bi ,,target)))))) + (define-conditional-branches bt :bo-t) + (define-conditional-branches bf :bo-f)) +|# + +(macrolet + ((define-positive-conditional-branches (name cr-bit-name) + `(progn + (define-instruction-macro ,name (crf &optional (target nil target-p)) + (unless target-p + (setq target crf crf :cr0)) + `(inst bt `(,,crf ,,,cr-bit-name) ,target)) +#| + (define-instruction-macro ,(symbolicate name "A") (target &optional (cr-field :cr0)) + ``(inst bta (,,cr-field ,,,cr-bit-name) ,,target)) + (define-instruction-macro ,(symbolicate name "L") (target &optional (cr-field :cr0)) + ``(inst btl (,,cr-field ,,,cr-bit-name) ,,target)) + (define-instruction-macro ,(symbolicate name "LA") (target &optional (cr-field :cr0)) + ``(inst btla (,,cr-field ,,,cr-bit-name) ,,target)) + (define-instruction-macro ,(symbolicate name "CTR") (target &optional (cr-field :cr0)) + ``(inst btctr (,,cr-field ,,,cr-bit-name) ,,target)) + (define-instruction-macro ,(symbolicate name "CTRL") (target &optional (cr-field :cr0)) + ``(inst btctrl (,,cr-field ,,,cr-bit-name) ,,target)) + (define-instruction-macro ,(symbolicate name "LR") (target &optional (cr-field :cr0)) + ``(inst btlr (,,cr-field ,,,cr-bit-name) ,,target)) + (define-instruction-macro ,(symbolicate name "LRL") (target &optional (cr-field :cr0)) + ``(inst btlrl (,,cr-field ,,,cr-bit-name) ,,target)) +|# + ))) + (define-positive-conditional-branches beq :eq) + (define-positive-conditional-branches blt :lt) + (define-positive-conditional-branches bgt :gt) + (define-positive-conditional-branches bso :so) + (define-positive-conditional-branches bun :so)) + + +(macrolet + ((define-negative-conditional-branches (name cr-bit-name) + `(progn + (define-instruction-macro ,name (crf &optional (target nil target-p)) + (unless target-p + (setq target crf crf :cr0)) + `(inst bf `(,,crf ,,,cr-bit-name) ,target)) +#| + (define-instruction-macro ,(symbolicate name "A") (target &optional (cr-field :cr0)) + ``(inst bfa (,,cr-field ,,,cr-bit-name) ,,target)) + (define-instruction-macro ,(symbolicate name "L") (target &optional (cr-field :cr0)) + ``(inst bfl (,,cr-field ,,,cr-bit-name) ,,target)) + (define-instruction-macro ,(symbolicate name "LA") (target &optional (cr-field :cr0)) + ``(inst bfla (,,cr-field ,,,cr-bit-name) ,,target)) + (define-instruction-macro ,(symbolicate name "CTR") (target &optional (cr-field :cr0)) + ``(inst bfctr (,,cr-field ,,,cr-bit-name) ,,target)) + (define-instruction-macro ,(symbolicate name "CTRL") (target &optional (cr-field :cr0)) + ``(inst bfctrl (,,cr-field ,,,cr-bit-name) ,,target)) + (define-instruction-macro ,(symbolicate name "LR") (target &optional (cr-field :cr0)) + ``(inst bflr (,,cr-field ,,,cr-bit-name) ,,target)) + (define-instruction-macro ,(symbolicate name "LRL") (target &optional (cr-field :cr0)) + ``(inst bflrl (,,cr-field ,,,cr-bit-name) ,,target)) +|# +))) + (define-negative-conditional-branches bne :eq) + (define-negative-conditional-branches bnl :lt) + (define-negative-conditional-branches bge :lt) + (define-negative-conditional-branches bng :gt) + (define-negative-conditional-branches ble :gt) + (define-negative-conditional-branches bns :so) + (define-negative-conditional-branches bnu :so)) + + + +(define-instruction-macro j (func-tn offset) + `(progn + (inst addi lip-tn ,func-tn ,offset) + (inst mtctr lip-tn) + (inst bctr))) + + +#| +(define-instruction-macro bua (target) + `(inst bca :bo-u 0 ,target)) + +(define-instruction-macro bul (target) + `(inst bcl :bo-u 0 ,target)) + +(define-instruction-macro bula (target) + `(inst bcla :bo-u 0 ,target)) + + +(define-instruction-macro blrl () + `(inst bclrl :bo-u 0)) + + + +|# + + + + + +;;; Some more macros + +(defun %lr (reg value) + (etypecase value + ((signed-byte 16) + (inst li reg value)) + ((unsigned-byte 16) + (inst ori reg zero-tn value)) + ((or (signed-byte 32) (unsigned-byte 32)) + (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)) + (t + (inst lis reg high-half) + (unless (zerop low-half) + (inst ori reg reg low-half)))))) + (fixup + (inst lis reg value) + (inst addi reg reg value)))) + +(define-instruction-macro lr (reg value) + `(%lr ,reg ,value)) + + + +;;;; Instructions for dumping data and header objects. + +(define-instruction word (segment word) + (:declare (type (or (unsigned-byte 32) (signed-byte 32)) word)) + :pinned + (:delay 0) + (:emitter + (emit-word segment word))) + +(define-instruction short (segment short) + (:declare (type (or (unsigned-byte 16) (signed-byte 16)) short)) + :pinned + (:delay 0) + (:emitter + (emit-short segment short))) + +(define-instruction byte (segment byte) + (:declare (type (or (unsigned-byte 8) (signed-byte 8)) byte)) + :pinned + (:delay 0) + (:emitter + (emit-byte segment byte))) + +(define-bitfield-emitter emit-header-object 32 + (byte 24 8) (byte 8 0)) + +(defun emit-header-data (segment type) + (emit-back-patch + segment 4 + #'(lambda (segment posn) + (emit-word segment + (logior type + (ash (+ posn (component-header-length)) + (- n-widetag-bits word-shift))))))) + +(define-instruction simple-fun-header-word (segment) + :pinned + (:delay 0) + (:emitter + (emit-header-data segment simple-fun-header-widetag))) + +(define-instruction lra-header-word (segment) + :pinned + (:delay 0) + (:emitter + (emit-header-data segment return-pc-header-widetag))) + + +;;;; Instructions for converting between code objects, functions, and lras. +(defun emit-compute-inst (segment vop dst src label temp calc) + (emit-chooser + ;; We emit either 12 or 4 bytes, so we maintain 8 byte alignments. + 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))) + #'(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) + (:declare (type tn dst src temp) (type label label)) + (:attributes variable-length) + (:dependencies (reads src) (writes dst) (writes temp)) + (:delay 0) + (: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)))))) + +;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag +(define-instruction compute-code-from-lra (segment dst src label temp) + (:declare (type tn dst src temp) (type label label)) + (:attributes variable-length) + (:dependencies (reads src) (writes dst) (writes temp)) + (:delay 0) + (: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))))))) + +;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag +(define-instruction compute-lra-from-code (segment dst src label temp) + (:declare (type tn dst src temp) (type label label)) + (:attributes variable-length) + (:dependencies (reads src) (writes dst) (writes temp)) + (:delay 0) + (: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)))))) diff --git a/src/compiler/ppc/macros.lisp b/src/compiler/ppc/macros.lisp new file mode 100644 index 0000000..fa66c78 --- /dev/null +++ b/src/compiler/ppc/macros.lisp @@ -0,0 +1,446 @@ +;;; + +(in-package "SB!VM") + + +;;; Instruction-like macros. + +(defmacro move (dst src) + "Move SRC into DST unless they are location=." + (once-only ((n-dst dst) + (n-src src)) + `(unless (location= ,n-dst ,n-src) + (inst mr ,n-dst ,n-src)))) + +(macrolet + ((frob (op inst shift) + `(defmacro ,op (object base &optional (offset 0) (lowtag 0)) + `(inst ,',inst ,object ,base (- (ash ,offset ,,shift) ,lowtag))))) + (frob loadw lwz word-shift) + (frob storew stw word-shift)) + +(defmacro load-symbol (reg symbol) + `(inst addi ,reg null-tn (static-symbol-offset ,symbol))) + +(macrolet + ((frob (slot) + (let ((loader (intern (concatenate 'simple-string + "LOAD-SYMBOL-" + (string slot)))) + (storer (intern (concatenate 'simple-string + "STORE-SYMBOL-" + (string slot)))) + (offset (intern (concatenate 'simple-string + "SYMBOL-" + (string slot) + "-SLOT") + (find-package "SB!VM")))) + `(progn + (defmacro ,loader (reg symbol) + `(inst lwz ,reg null-tn + (+ (static-symbol-offset ',symbol) + (ash ,',offset word-shift) + (- other-pointer-lowtag)))) + (defmacro ,storer (reg symbol) + `(inst stw ,reg null-tn + (+ (static-symbol-offset ',symbol) + (ash ,',offset word-shift) + (- other-pointer-lowtag)))))))) + (frob value) + (frob function)) + +(defmacro load-type (target source &optional (offset 0)) + "Loads the type bits of a pointer into target independent of + byte-ordering issues." + (once-only ((n-target target) + (n-source source) + (n-offset offset)) + (ecase *backend-byte-order* + (:little-endian + `(inst lbz ,n-target ,n-source ,n-offset)) + (:big-endian + `(inst lbz ,n-target ,n-source (+ ,n-offset 3)))))) + +;;; Macros to handle the fact that we cannot use the machine native call and +;;; return instructions. + +(defmacro lisp-jump (function lip) + "Jump to the lisp function FUNCTION. LIP is an interior-reg temporary." + `(progn + ;; something is deeply bogus. look at this + ;; (loadw ,lip ,function sb!vm:function-code-offset sb!vm:function-pointer-type) + (inst addi ,lip ,function (- (* n-word-bytes sb!vm:simple-fun-code-offset) sb!vm:fun-pointer-lowtag)) + (inst mtctr ,lip) + (move code-tn ,function) + (inst bctr))) + +(defmacro lisp-return (return-pc lip &key (offset 0) (frob-code t)) + "Return to RETURN-PC." + `(progn + (inst addi ,lip ,return-pc (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag)) + (inst mtlr ,lip) + ,@(if frob-code + `((move code-tn ,return-pc))) + (inst blr))) + +(defmacro emit-return-pc (label) + "Emit a return-pc header word. LABEL is the label to use for this return-pc." + `(progn + (align n-lowtag-bits) + (emit-label ,label) + (inst lra-header-word))) + + + +;;;; Stack TN's + +;;; Load-Stack-TN, Store-Stack-TN -- Interface +;;; +;;; Move a stack TN to a register and vice-versa. +;;; +(defmacro load-stack-tn (reg stack) + `(let ((reg ,reg) + (stack ,stack)) + (let ((offset (tn-offset stack))) + (sc-case stack + ((control-stack) + (loadw reg cfp-tn offset)))))) + +(defmacro store-stack-tn (stack reg) + `(let ((stack ,stack) + (reg ,reg)) + (let ((offset (tn-offset stack))) + (sc-case stack + ((control-stack) + (storew reg cfp-tn offset)))))) + + +;;; MAYBE-LOAD-STACK-TN -- Interface +;;; +(defmacro maybe-load-stack-tn (reg reg-or-stack) + "Move the TN Reg-Or-Stack into Reg if it isn't already there." + (once-only ((n-reg reg) + (n-stack reg-or-stack)) + `(sc-case ,n-reg + ((any-reg descriptor-reg) + (sc-case ,n-stack + ((any-reg descriptor-reg) + (move ,n-reg ,n-stack)) + ((control-stack) + (loadw ,n-reg cfp-tn (tn-offset ,n-stack)))))))) + + +;;;; Storage allocation: + +(defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code size) + &body body) + "Do stuff to allocate an other-pointer object of fixed Size with a single + word header having the specified Type-Code. The result is placed in + Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used + by the body.) The body is placed inside the PSEUDO-ATOMIC, and presumably + initializes the object." + (once-only ((result-tn result-tn) (temp-tn temp-tn) (flag-tn flag-tn) + (type-code type-code) (size size)) + `(pseudo-atomic (,flag-tn :extra (pad-data-block ,size)) + (inst ori ,result-tn alloc-tn other-pointer-lowtag) + (inst lr ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code)) + (storew ,temp-tn ,result-tn 0 other-pointer-lowtag) + ,@body))) + + +;;;; Type testing noise. + +;;; GEN-RANGE-TEST -- internal +;;; +;;; Generate code that branches to TARGET iff REG contains one of VALUES. +;;; If NOT-P is true, invert the test. Jumping to NOT-TARGET is the same +;;; as falling out the bottom. +;;; +(defun gen-range-test (reg target not-target not-p min seperation max values) + (let ((tests nil) + (start nil) + (end nil) + (insts nil)) + (multiple-value-bind (equal less-or-equal greater-or-equal label) + (if not-p + (values :ne :gt :lt not-target) + (values :eq :le :ge target)) + (flet ((emit-test () + (if (= start end) + (push start tests) + (push (cons start end) tests)))) + (dolist (value values) + (cond ((< value min) + (error "~S is less than the specified minimum of ~S" + value min)) + ((> value max) + (error "~S is greater than the specified maximum of ~S" + value max)) + ((not (zerop (rem (- value min) seperation))) + (error "~S isn't an even multiple of ~S from ~S" + value seperation min)) + ((null start) + (setf start value)) + ((> value (+ end seperation)) + (emit-test) + (setf start value))) + (setf end value)) + (emit-test)) + (macrolet ((inst (name &rest args) + `(push (list 'inst ',name ,@args) insts))) + (do ((remaining (nreverse tests) (cdr remaining))) + ((null remaining)) + (let ((test (car remaining)) + (last (null (cdr remaining)))) + (if (atom test) + (progn + (inst cmpwi reg test) + (if last + (inst b? equal target) + (inst beq label))) + (let ((start (car test)) + (end (cdr test))) + (cond ((and (= start min) (= end max)) + (warn "The values ~S cover the entire range from ~ + ~S to ~S [step ~S]." + values min max seperation) + (push `(unless ,not-p (inst b ,target)) insts)) + ((= start min) + (inst cmpwi reg end) + (if last + (inst b? less-or-equal target) + (inst ble label))) + ((= end max) + (inst cmpwi reg start) + (if last + (inst b? greater-or-equal target) + (inst bge label))) + (t + (inst cmpwi reg start) + (inst blt (if not-p target not-target)) + (inst cmpwi reg end) + (if last + (inst b? less-or-equal target) + (inst ble label)))))))))) + (nreverse insts))) + +(defun gen-other-immediate-test (reg target not-target not-p values) + (gen-range-test reg target not-target not-p + (+ other-immediate-0-lowtag lowtag-limit) + (- other-immediate-1-lowtag other-immediate-0-lowtag) + (ash 1 n-widetag-bits) + values)) + + +(defun test-type-aux (reg temp target not-target not-p lowtags immed hdrs + function-p) + (let* ((fixnump (and (member even-fixnum-lowtag lowtags :test #'eql) + (member odd-fixnum-lowtag lowtags :test #'eql))) + (lowtags (sort (if fixnump + (delete even-fixnum-lowtag + (remove odd-fixnum-lowtag lowtags + :test #'eql) + :test #'eql) + (copy-list lowtags)) + #'<)) + (lowtag (if function-p + sb!vm:fun-pointer-lowtag + sb!vm:other-pointer-lowtag)) + (hdrs (sort (copy-list hdrs) #'<)) + (immed (sort (copy-list immed) #'<))) + (append + (when immed + `((inst andi. ,temp ,reg widetag-mask) + ,@(if (or fixnump lowtags hdrs) + (let ((fall-through (gensym))) + `((let (,fall-through (gen-label)) + ,@(gen-other-immediate-test + temp (if not-p not-target target) + fall-through nil immed) + (emit-label ,fall-through)))) + (gen-other-immediate-test temp target not-target not-p immed)))) + (when fixnump + `((inst andi. ,temp ,reg 3) + ,(if (or lowtags hdrs) + `(inst beq ,(if not-p not-target target)) + `(inst b? ,(if not-p :ne :eq) ,target)))) + (when (or lowtags hdrs) + `((inst andi. ,temp ,reg lowtag-mask))) + (when lowtags + (if hdrs + (let ((fall-through (gensym))) + `((let ((,fall-through (gen-label))) + ,@(gen-range-test temp (if not-p not-target target) + fall-through nil + 0 1 (1- lowtag-limit) lowtags) + (emit-label ,fall-through)))) + (gen-range-test temp target not-target not-p 0 1 + (1- lowtag-limit) lowtags))) + (when hdrs + `((inst cmpwi ,temp ,lowtag) + (inst bne ,(if not-p target not-target)) + (load-type ,temp ,reg (- ,lowtag)) + ,@(gen-other-immediate-test temp target not-target not-p hdrs)))))) + +(defparameter immediate-types + (list base-char-widetag unbound-marker-widetag)) + +(defparameter function-subtypes + (list funcallable-instance-header-widetag + simple-fun-header-widetag closure-fun-header-widetag + closure-header-widetag)) + +(defmacro test-type (register temp target not-p &rest type-codes) + (let* ((type-codes (mapcar #'eval type-codes)) + (lowtags (remove lowtag-limit type-codes :test #'<)) + (extended (remove lowtag-limit type-codes :test #'>)) + (immediates (intersection extended immediate-types :test #'eql)) + (headers (set-difference extended immediate-types :test #'eql)) + (function-p nil)) + (unless type-codes + (error "Must supply at least on type for test-type.")) + (when (and headers (member other-pointer-lowtag lowtags)) + (warn "OTHER-POINTER-LOWTAG supersedes the use of ~S" headers) + (setf headers nil)) + (when (and immediates + (or (member other-immediate-0-lowtag lowtags) + (member other-immediate-1-lowtag lowtags))) + (warn "OTHER-IMMEDIATE-n-LOWTAG supersedes the use of ~S" immediates) + (setf immediates nil)) + (when (intersection headers function-subtypes) + (unless (subsetp headers function-subtypes) + (error "Can't test for mix of function subtypes and normal ~ + header types.")) + (setq function-p t)) + + (let ((n-reg (gensym)) + (n-temp (gensym)) + (n-target (gensym)) + (not-target (gensym))) + `(let ((,n-reg ,register) + (,n-temp ,temp) + (,n-target ,target) + (,not-target (gen-label))) + (declare (ignorable ,n-temp)) + ,@(if (constantp not-p) + (test-type-aux n-reg n-temp n-target not-target + (eval not-p) lowtags immediates headers + function-p) + `((cond (,not-p + ,@(test-type-aux n-reg n-temp n-target not-target t + lowtags immediates headers + function-p)) + (t + ,@(test-type-aux n-reg n-temp n-target not-target nil + lowtags immediates headers + function-p))))) + (emit-label ,not-target))))) + + +;;;; Error Code + +(defvar *adjustable-vectors* nil) + +(defmacro with-adjustable-vector ((var) &rest body) + `(let ((,var (or (pop *adjustable-vectors*) + (make-array 16 + :element-type '(unsigned-byte 8) + :fill-pointer 0 + :adjustable t)))) + (setf (fill-pointer ,var) 0) + (unwind-protect + (progn + ,@body) + (push ,var *adjustable-vectors*)))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun emit-error-break (vop kind code values) + (let ((vector (gensym))) + `((let ((vop ,vop)) + (when vop + (note-this-location vop :internal-error))) + (inst unimp ,kind) + (with-adjustable-vector (,vector) + (write-var-integer (error-number-or-lose ',code) ,vector) + ,@(mapcar #'(lambda (tn) + `(let ((tn ,tn)) + (write-var-integer (make-sc-offset (sc-number + (tn-sc tn)) + (tn-offset tn)) + ,vector))) + values) + (inst byte (length ,vector)) + (dotimes (i (length ,vector)) + (inst byte (aref ,vector i)))) + (align word-shift))))) + +(defmacro error-call (vop error-code &rest values) + "Cause an error. ERROR-CODE is the error to cause." + (cons 'progn + (emit-error-break vop error-trap error-code values))) + + +(defmacro cerror-call (vop label error-code &rest values) + "Cause a continuable error. If the error is continued, execution resumes at + LABEL." + `(progn + ,@(emit-error-break vop cerror-trap error-code values) + (inst b ,label))) + +(defmacro generate-error-code (vop error-code &rest values) + "Generate-Error-Code Error-code Value* + Emit code for an error with the specified Error-Code and context Values." + `(assemble (*elsewhere*) + (let ((start-lab (gen-label))) + (emit-label start-lab) + (error-call ,vop ,error-code ,@values) + start-lab))) + +(defmacro generate-cerror-code (vop error-code &rest values) + "Generate-CError-Code Error-code Value* + Emit code for a continuable error with the specified Error-Code and + context Values. If the error is continued, execution resumes after + the GENERATE-CERROR-CODE form." + (let ((continue (gensym "CONTINUE-LABEL-")) + (error (gensym "ERROR-LABEL-"))) + `(let ((,continue (gen-label))) + (emit-label ,continue) + (assemble (*elsewhere*) + (let ((,error (gen-label))) + (emit-label ,error) + (cerror-call ,vop ,continue ,error-code ,@values) + ,error))))) + + + +;;; PSEUDO-ATOMIC -- Handy macro for making sequences look atomic. +;;; +;;; flag-tn must be wired to NL3. If a deferred interrupt happens +;;; while we have the low bits of alloc-tn set, we add a "large" +;;; constant to flag-tn. On exit, we add flag-tn to alloc-tn +;;; which (a) aligns alloc-tn again and (b) makes alloc-tn go +;;; negative. We then trap if alloc-tn's negative (handling the +;;; deferred interrupt) and using flag-tn - minus the large constant - +;;; to correct alloc-tn. +(defmacro pseudo-atomic ((flag-tn &key (extra 0)) &rest forms) + (let ((n-extra (gensym))) + `(let ((,n-extra ,extra)) + (without-scheduling () + ;; Extra debugging stuff: + #+debug + (progn + (inst andi. ,flag-tn alloc-tn 7) + (inst twi :ne ,flag-tn 0)) + (inst lr ,flag-tn (- ,n-extra 4)) + (inst addi alloc-tn alloc-tn 4)) + ,@forms + (without-scheduling () + (inst add alloc-tn alloc-tn ,flag-tn) + (inst twi :lt alloc-tn 0)) + #+debug + (progn + (inst andi. ,flag-tn alloc-tn 7) + (inst twi :ne ,flag-tn 0))))) + + + diff --git a/src/compiler/ppc/memory.lisp b/src/compiler/ppc/memory.lisp new file mode 100644 index 0000000..0e9a19b --- /dev/null +++ b/src/compiler/ppc/memory.lisp @@ -0,0 +1,104 @@ +;;; reference VOPs inherited by basic memory reference operations. +;;; +;;; Written by Rob MacLachlan +;;; +;;; Converted by William Lott. +;;; + +(in-package "SB!VM") + +;;; Cell-Ref and Cell-Set are used to define VOPs like CAR, where the offset to +;;; be read or written is a property of the VOP used. +;;; +(define-vop (cell-ref) + (:args (object :scs (descriptor-reg))) + (:results (value :scs (descriptor-reg any-reg))) + (:variant-vars offset lowtag) + (:policy :fast-safe) + (:generator 4 + (loadw value object offset lowtag))) +;;; +(define-vop (cell-set) + (:args (object :scs (descriptor-reg)) + (value :scs (descriptor-reg any-reg))) + (:variant-vars offset lowtag) + (:policy :fast-safe) + (:generator 4 + (storew value object offset lowtag))) + +;;; Slot-Ref and Slot-Set are used to define VOPs like Closure-Ref, where the +;;; offset is constant at compile time, but varies for different uses. We add +;;; in the standard g-vector overhead. +;;; +(define-vop (slot-ref) + (:args (object :scs (descriptor-reg))) + (:results (value :scs (descriptor-reg any-reg))) + (:variant-vars base lowtag) + (:info offset) + (:generator 4 + (loadw value object (+ base offset) lowtag))) +;;; +(define-vop (slot-set) + (:args (object :scs (descriptor-reg)) + (value :scs (descriptor-reg any-reg))) + (:variant-vars base lowtag) + (:info offset) + (:generator 4 + (storew value object (+ base offset) lowtag))) + + + +;;;; Indexed references: + +;;; Define-Indexer -- Internal +;;; +;;; Define some VOPs for indexed memory reference. +;;; +(defmacro define-indexer (name write-p ri-op rr-op shift &optional sign-extend-byte) + `(define-vop (,name) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg zero immediate)) + ,@(when write-p + '((value :scs (any-reg descriptor-reg) :target result)))) + (:arg-types * tagged-num ,@(when write-p '(*))) + (:temporary (:scs (non-descriptor-reg)) temp) + (:results (,(if write-p 'result 'value) + :scs (any-reg descriptor-reg))) + (:result-types *) + (:variant-vars offset lowtag) + (:policy :fast-safe) + (:generator 5 + (sc-case index + ((immediate zero) + (let ((offset (- (+ (if (sc-is index zero) + 0 + (ash (tn-value index) + (- sb!vm:word-shift ,shift))) + (ash offset sb!vm:word-shift)) + lowtag))) + (etypecase offset + ((signed-byte 16) + (inst ,ri-op value object offset)) + ((or (unsigned-byte 32) (signed-byte 32)) + (inst lr temp offset) + (inst ,rr-op value object temp))))) + (t + ,@(unless (zerop shift) + `((inst srwi temp index ,shift))) + (inst addi temp ,(if (zerop shift) 'index 'temp) + (- (ash offset sb!vm:word-shift) lowtag)) + (inst ,rr-op value object temp))) + ,@(when sign-extend-byte + `((inst extsb value value))) + ,@(when write-p + '((move result value)))))) + +(define-indexer word-index-ref nil lwz lwzx 0) +(define-indexer word-index-set t stw stwx 0) +(define-indexer halfword-index-ref nil lhz lhzx 1) +(define-indexer signed-halfword-index-ref nil lha lhax 1) +(define-indexer halfword-index-set t sth sthx 1) +(define-indexer byte-index-ref nil lbz lbzx 2) +(define-indexer signed-byte-index-ref nil lbz lbzx 2 t) +(define-indexer byte-index-set t stb stbx 2) + diff --git a/src/compiler/ppc/move.lisp b/src/compiler/ppc/move.lisp new file mode 100644 index 0000000..8d00afc --- /dev/null +++ b/src/compiler/ppc/move.lisp @@ -0,0 +1,303 @@ +;;; Written by Rob MacLachlan. +;;; SPARC conversion by William Lott. +;;; +(in-package "SB!VM") + + +(define-move-fun (load-immediate 1) (vop x y) + ((null immediate zero) + (any-reg descriptor-reg)) + (let ((val (tn-value x))) + (etypecase val + (integer + (inst lr y (fixnumize val))) + (null + (move y null-tn)) + (symbol + (load-symbol y val)) + (character + (inst lr y (logior (ash (char-code val) n-widetag-bits) + base-char-widetag)))))) + +(define-move-fun (load-number 1) (vop x y) + ((immediate zero) + (signed-reg unsigned-reg)) + (inst lr y (tn-value x))) + +(define-move-fun (load-base-char 1) (vop x y) + ((immediate) (base-char-reg)) + (inst li y (char-code (tn-value x)))) + +(define-move-fun (load-system-area-pointer 1) (vop x y) + ((immediate) (sap-reg)) + (inst lr y (sap-int (tn-value x)))) + +(define-move-fun (load-constant 5) (vop x y) + ((constant) (descriptor-reg)) + (loadw y code-tn (tn-offset x) other-pointer-lowtag)) + +(define-move-fun (load-stack 5) (vop x y) + ((control-stack) (any-reg descriptor-reg)) + (load-stack-tn y x)) + +(define-move-fun (load-number-stack 5) (vop x y) + ((base-char-stack) (base-char-reg) + (sap-stack) (sap-reg) + (signed-stack) (signed-reg) + (unsigned-stack) (unsigned-reg)) + (let ((nfp (current-nfp-tn vop))) + (loadw y nfp (tn-offset x)))) + +(define-move-fun (store-stack 5) (vop x y) + ((any-reg descriptor-reg) (control-stack)) + (store-stack-tn y x)) + +(define-move-fun (store-number-stack 5) (vop x y) + ((base-char-reg) (base-char-stack) + (sap-reg) (sap-stack) + (signed-reg) (signed-stack) + (unsigned-reg) (unsigned-stack)) + (let ((nfp (current-nfp-tn vop))) + (storew x nfp (tn-offset y)))) + + +;;;; The Move VOP: +;;; +(define-vop (move) + (:args (x :target y + :scs (any-reg descriptor-reg zero null) + :load-if (not (location= x y)))) + (:results (y :scs (any-reg descriptor-reg) + :load-if (not (location= x y)))) + (:effects) + (:affected) + (:generator 0 + (move y x))) + +(define-move-vop move :move + (any-reg descriptor-reg) + (any-reg descriptor-reg)) + +;;; Make Move the check VOP for T so that type check generation doesn't think +;;; it is a hairy type. This also allows checking of a few of the values in a +;;; continuation to fall out. +;;; +(primitive-type-vop move (:check) t) + +;;; The Move-Argument VOP is used for moving descriptor values into another +;;; frame for argument or known value passing. +;;; +(define-vop (move-arg) + (:args (x :target y + :scs (any-reg descriptor-reg zero null)) + (fp :scs (any-reg) + :load-if (not (sc-is y any-reg descriptor-reg)))) + (:results (y)) + (:generator 0 + (sc-case y + ((any-reg descriptor-reg) + (move y x)) + (control-stack + (storew x fp (tn-offset y)))))) +;;; +(define-move-vop move-arg :move-arg + (any-reg descriptor-reg) + (any-reg descriptor-reg)) + + + +;;;; ILLEGAL-MOVE + +;;; This VOP exists just to begin the lifetime of a TN that couldn't be written +;;; legally due to a type error. An error is signalled before this VOP is +;;; so we don't need to do anything (not that there would be anything sensible +;;; to do anyway.) +;;; +(define-vop (illegal-move) + (:args (x) (type)) + (:results (y)) + (:ignore y) + (:vop-var vop) + (:save-p :compute-only) + (:generator 666 + (error-call vop object-not-type-error x type))) + + + +;;;; Moves and coercions: + +;;; These MOVE-TO-WORD VOPs move a tagged integer to a raw full-word +;;; representation. Similarly, the MOVE-FROM-WORD VOPs converts a raw integer +;;; to a tagged bignum or fixnum. + +;;; Arg is a fixnum, so just shift it. We need a type restriction because some +;;; possible arg SCs (control-stack) overlap with possible bignum arg SCs. +;;; +(define-vop (move-to-word/fixnum) + (:args (x :scs (any-reg descriptor-reg))) + (:results (y :scs (signed-reg unsigned-reg))) + (:arg-types tagged-num) + (:note "fixnum untagging") + (:generator 1 + (inst srawi y x 2))) +;;; +(define-move-vop move-to-word/fixnum :move + (any-reg descriptor-reg) (signed-reg unsigned-reg)) + +;;; Arg is a non-immediate constant, load it. +(define-vop (move-to-word-c) + (:args (x :scs (constant))) + (:results (y :scs (signed-reg unsigned-reg))) + (:note "constant load") + (:generator 1 + (inst lr y (tn-value x)))) +;;; +(define-move-vop move-to-word-c :move + (constant) (signed-reg unsigned-reg)) + + +;;; Arg is a fixnum or bignum, figure out which and load if necessary. +(define-vop (move-to-word/integer) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (signed-reg unsigned-reg))) + (:note "integer to untagged word coercion") + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 4 + (let ((done (gen-label))) + (inst andi. temp x 3) + (sc-case y + (signed-reg + (inst srawi y x 2)) + (unsigned-reg + (inst srwi y x 2))) + + (inst beq done) + (loadw y x bignum-digits-offset other-pointer-lowtag) + + (emit-label done)))) +;;; +(define-move-vop move-to-word/integer :move + (descriptor-reg) (signed-reg unsigned-reg)) + + + +;;; Result is a fixnum, so we can just shift. We need the result type +;;; restriction because of the control-stack ambiguity noted above. +;;; +(define-vop (move-from-word/fixnum) + (:args (x :scs (signed-reg unsigned-reg))) + (:results (y :scs (any-reg descriptor-reg))) + (:result-types tagged-num) + (:note "fixnum tagging") + (:generator 1 + (inst slwi y x 2))) +;;; +(define-move-vop move-from-word/fixnum :move + (signed-reg unsigned-reg) (any-reg descriptor-reg)) + + +;;; Result may be a bignum, so we have to check. Use a worst-case cost to make +;;; sure people know they may be number consing. +;;; +(define-vop (move-from-signed) + (:args (arg :scs (signed-reg unsigned-reg) :target x)) + (:results (y :scs (any-reg descriptor-reg))) + (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x temp) + (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag) + (:note "signed word to integer coercion") + (:generator 20 + (move x arg) + (let ((done (gen-label))) + (inst mcrxr :cr0) ; clear sticky overflow bits in XER, CR0 + (inst addo temp x x) ; set XER OV if top two bits differ + (inst addo. temp temp temp) ; set CR0 SO if any top three bits differ + (inst slwi y x 2) ; assume fixnum (tagged ok, maybe lost some high bits) + (inst bns done) + + (with-fixed-allocation (y pa-flag temp bignum-widetag (1+ bignum-digits-offset)) + (storew x y bignum-digits-offset other-pointer-lowtag)) + (emit-label done)))) +;;; +(define-move-vop move-from-signed :move + (signed-reg) (descriptor-reg)) + + +;;; Check for fixnum, and possibly allocate one or two word bignum result. Use +;;; a worst-case cost to make sure people know they may be number consing. +;;; +(define-vop (move-from-unsigned) + (:args (arg :scs (signed-reg unsigned-reg) :target x)) + (:results (y :scs (any-reg descriptor-reg))) + (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x temp) + (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag) + (:note "unsigned word to integer coercion") + (:generator 20 + (move x arg) + (let ((done (gen-label)) + (one-word (gen-label)) + (initial-alloc (pad-data-block (1+ bignum-digits-offset)))) + (inst srawi. temp x 29) + (inst slwi y x 2) + (inst beq done) + + (pseudo-atomic (pa-flag :extra initial-alloc) + (inst cmpwi x 0) + (inst ori y alloc-tn other-pointer-lowtag) + (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag)) + (inst bge one-word) + (inst addi alloc-tn alloc-tn + (- (pad-data-block (+ bignum-digits-offset 2)) + (pad-data-block (+ bignum-digits-offset 1)))) + (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag)) + (emit-label one-word) + (storew temp y 0 other-pointer-lowtag) + (storew x y bignum-digits-offset other-pointer-lowtag)) + (emit-label done)))) +;;; +(define-move-vop move-from-unsigned :move + (unsigned-reg) (descriptor-reg)) + + +;;; Move untagged numbers. +;;; +(define-vop (word-move) + (:args (x :target y + :scs (signed-reg unsigned-reg) + :load-if (not (location= x y)))) + (:results (y :scs (signed-reg unsigned-reg) + :load-if (not (location= x y)))) + (:effects) + (:affected) + (:note "word integer move") + (:generator 0 + (move y x))) +;;; +(define-move-vop word-move :move + (signed-reg unsigned-reg) (signed-reg unsigned-reg)) + + +;;; Move untagged number arguments/return-values. +;;; +(define-vop (move-word-arg) + (:args (x :target y + :scs (signed-reg unsigned-reg)) + (fp :scs (any-reg) + :load-if (not (sc-is y sap-reg)))) + (:results (y)) + (:note "word integer argument move") + (:generator 0 + (sc-case y + ((signed-reg unsigned-reg) + (move y x)) + ((signed-stack unsigned-stack) + (storew x fp (tn-offset y)))))) +;;; +(define-move-vop move-word-arg :move-arg + (descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg)) + + +;;; Use standard MOVE-ARGUMENT + coercion to move an untagged number to a +;;; descriptor passing location. +;;; +(define-move-vop move-arg :move-arg + (signed-reg unsigned-reg) (any-reg descriptor-reg)) diff --git a/src/compiler/ppc/nlx.lisp b/src/compiler/ppc/nlx.lisp new file mode 100644 index 0000000..93c3231 --- /dev/null +++ b/src/compiler/ppc/nlx.lisp @@ -0,0 +1,272 @@ +;;; Written by Rob MacLachlan +;;; +(in-package "SB!VM") + +;;; MAKE-NLX-SP-TN -- Interface +;;; +;;; Make an environment-live stack TN for saving the SP for NLX entry. +;;; +(!def-vm-support-routine make-nlx-sp-tn (env) + (physenv-live-tn + (make-representation-tn *fixnum-primitive-type* immediate-arg-scn) + env)) + +;;; Make-NLX-Entry-Arg-Start-Location -- Interface +;;; +;;; Make a TN for the argument count passing location for a +;;; non-local entry. +;;; +(!def-vm-support-routine make-nlx-entry-arg-start-location () + (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ocfp-offset)) + + +;;; Save and restore dynamic environment. +;;; +;;; These VOPs are used in the reentered function to restore the appropriate +;;; dynamic environment. Currently we only save the Current-Catch and binding +;;; stack pointer. We don't need to save/restore the current unwind-protect, +;;; since unwind-protects are implicitly processed during unwinding. If there +;;; were any additional stacks, then this would be the place to restore the top +;;; pointers. + + +;;; Make-Dynamic-State-TNs -- Interface +;;; +;;; Return a list of TNs that can be used to snapshot the dynamic state for +;;; use with the Save/Restore-Dynamic-Environment VOPs. +;;; +(!def-vm-support-routine make-dynamic-state-tns () + (make-n-tns 4 *backend-t-primitive-type*)) + +(define-vop (save-dynamic-state) + (:results (catch :scs (descriptor-reg)) + (nfp :scs (descriptor-reg)) + (nsp :scs (descriptor-reg)) + (eval :scs (descriptor-reg))) + (:vop-var vop) + (:generator 13 + (load-symbol-value catch *current-catch-block*) + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (move nfp cur-nfp))) + (move nsp nsp-tn) + (load-symbol-value eval *eval-stack-top*))) + +(define-vop (restore-dynamic-state) + (:args (catch :scs (descriptor-reg)) + (nfp :scs (descriptor-reg)) + (nsp :scs (descriptor-reg)) + (eval :scs (descriptor-reg))) + (:vop-var vop) + (:generator 10 + (store-symbol-value catch *current-catch-block*) + (store-symbol-value eval *eval-stack-top*) + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (move cur-nfp nfp))) + (move nsp-tn nsp))) + +(define-vop (current-stack-pointer) + (:results (res :scs (any-reg descriptor-reg))) + (:generator 1 + (move res csp-tn))) + +(define-vop (current-binding-pointer) + (:results (res :scs (any-reg descriptor-reg))) + (:generator 1 + (move res bsp-tn))) + + + +;;;; Unwind block hackery: + +;;; Compute the address of the catch block from its TN, then store into the +;;; block the current Fp, Env, Unwind-Protect, and the entry PC. +;;; +(define-vop (make-unwind-block) + (:args (tn)) + (:info entry-label) + (:results (block :scs (any-reg))) + (:temporary (:scs (descriptor-reg)) temp) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:generator 22 + (inst addi block cfp-tn (* (tn-offset tn) sb!vm:n-word-bytes)) + (load-symbol-value temp *current-unwind-protect-block*) + (storew temp block sb!vm:unwind-block-current-uwp-slot) + (storew cfp-tn block sb!vm:unwind-block-current-cont-slot) + (storew code-tn block sb!vm:unwind-block-current-code-slot) + (inst compute-lra-from-code temp code-tn entry-label ndescr) + (storew temp block sb!vm:catch-block-entry-pc-slot))) + + +;;; Like Make-Unwind-Block, except that we also store in the specified tag, and +;;; link the block into the Current-Catch list. +;;; +(define-vop (make-catch-block) + (:args (tn) + (tag :scs (any-reg descriptor-reg))) + (:info entry-label) + (:results (block :scs (any-reg))) + (:temporary (:scs (descriptor-reg)) temp) + (:temporary (:scs (descriptor-reg) :target block :to (:result 0)) result) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:generator 44 + (inst addi result cfp-tn (* (tn-offset tn) sb!vm:n-word-bytes)) + (load-symbol-value temp *current-unwind-protect-block*) + (storew temp result sb!vm:catch-block-current-uwp-slot) + (storew cfp-tn result sb!vm:catch-block-current-cont-slot) + (storew code-tn result sb!vm:catch-block-current-code-slot) + (inst compute-lra-from-code temp code-tn entry-label ndescr) + (storew temp result sb!vm:catch-block-entry-pc-slot) + + (storew tag result sb!vm:catch-block-tag-slot) + (load-symbol-value temp *current-catch-block*) + (storew temp result sb!vm:catch-block-previous-catch-slot) + (store-symbol-value result *current-catch-block*) + + (move block result))) + + +;;; Just set the current unwind-protect to TN's address. This instantiates an +;;; unwind block as an unwind-protect. +;;; +(define-vop (set-unwind-protect) + (:args (tn)) + (:temporary (:scs (descriptor-reg)) new-uwp) + (:generator 7 + (inst addi new-uwp cfp-tn (* (tn-offset tn) sb!vm:n-word-bytes)) + (store-symbol-value new-uwp *current-unwind-protect-block*))) + + +(define-vop (unlink-catch-block) + (:temporary (:scs (any-reg)) block) + (:policy :fast-safe) + (:translate %catch-breakup) + (:generator 17 + (load-symbol-value block *current-catch-block*) + (loadw block block sb!vm:catch-block-previous-catch-slot) + (store-symbol-value block *current-catch-block*))) + +(define-vop (unlink-unwind-protect) + (:temporary (:scs (any-reg)) block) + (:policy :fast-safe) + (:translate %unwind-protect-breakup) + (:generator 17 + (load-symbol-value block *current-unwind-protect-block*) + (loadw block block sb!vm:unwind-block-current-uwp-slot) + (store-symbol-value block *current-unwind-protect-block*))) + + +;;;; NLX entry VOPs: + + +(define-vop (nlx-entry) + (:args (sp) ; Note: we can't list an sc-restriction, 'cause any load vops + ; would be inserted before the LRA. + (start) + (count)) + (:results (values :more t)) + (:temporary (:scs (descriptor-reg)) move-temp) + (:info label nvals) + (:save-p :force-to-stack) + (:vop-var vop) + (:generator 30 + (emit-return-pc label) + (note-this-location vop :non-local-entry) + (cond ((zerop nvals)) + ((= nvals 1) + (let ((no-values (gen-label))) + (inst cmpwi count 0) + (move (tn-ref-tn values) null-tn) + (inst beq no-values) + (loadw (tn-ref-tn values) start) + (emit-label no-values))) + (t + (collect ((defaults)) + (inst addic. count count (- (fixnumize 1))) + (do ((i 0 (1+ i)) + (tn-ref values (tn-ref-across tn-ref))) + ((null tn-ref)) + (let ((default-lab (gen-label)) + (tn (tn-ref-tn tn-ref))) + (defaults (cons default-lab tn)) + + (inst subi count count (fixnumize 1)) + (inst blt default-lab) + (sc-case tn + ((descriptor-reg any-reg) + (loadw tn start i)) + (control-stack + (loadw move-temp start i) + (store-stack-tn tn move-temp))) + (inst cmpwi count 0))) + + (let ((defaulting-done (gen-label))) + + (emit-label defaulting-done) + + (assemble (*elsewhere*) + (dolist (def (defaults)) + (emit-label (car def)) + (let ((tn (cdr def))) + (sc-case tn + ((descriptor-reg any-reg) + (move tn null-tn)) + (control-stack + (store-stack-tn tn null-tn))))) + (inst b defaulting-done)))))) + (load-stack-tn csp-tn sp))) + + +(define-vop (nlx-entry-multiple) + (:args (top :target result) (src) (count)) + ;; Again, no SC restrictions for the args, 'cause the loading would + ;; happen before the entry label. + (:info label) + (:temporary (:scs (any-reg)) dst) + (:temporary (:scs (descriptor-reg)) temp) + (:results (result :scs (any-reg) :from (:argument 0)) + (num :scs (any-reg) :from (:argument 0))) + (:save-p :force-to-stack) + (:vop-var vop) + (:generator 30 + (emit-return-pc label) + (note-this-location vop :non-local-entry) + (let ((loop (gen-label)) + (done (gen-label))) + + ;; Setup results, and test for the zero value case. + (load-stack-tn result top) + (inst cmpwi count 0) + (inst li num 0) + (inst beq done) + + ;; Compute dst as one slot down from result, because we inc the index + ;; before we use it. + (inst subi dst result 4) + + ;; Copy stuff down the stack. + (emit-label loop) + (inst lwzx temp src num) + (inst addi num num (fixnumize 1)) + (inst cmpw num count) + (inst stwx temp dst num) + (inst bne loop) + + ;; Reset the CSP. + (emit-label done) + (inst add csp-tn result num)))) + + +;;; This VOP is just to force the TNs used in the cleanup onto the stack. +;;; +(define-vop (uwp-entry) + (:info label) + (:save-p :force-to-stack) + (:results (block) (start) (count)) + (:ignore block start count) + (:vop-var vop) + (:generator 0 + (emit-return-pc label) + (note-this-location vop :non-local-entry))) + diff --git a/src/compiler/ppc/parms.lisp b/src/compiler/ppc/parms.lisp new file mode 100644 index 0000000..a8246fc --- /dev/null +++ b/src/compiler/ppc/parms.lisp @@ -0,0 +1,198 @@ +;;;; This file contains some parameterizations of various VM +;;;; attributes for the PPC. This file is separate from other stuff so +;;;; that it can be compiled and loaded earlier. + + +(in-package "SB!VM") + +(defconstant n-word-bits 32 + "Number of bits per word where a word holds one lisp descriptor.") + +(defconstant n-byte-bits 8 + "Number of bits per byte where a byte is the smallest addressable object.") + +(defconstant word-shift (1- (integer-length (/ n-word-bits n-byte-bits))) + "Number of bits to shift between word addresses and byte addresses.") + +(defconstant n-word-bytes (/ n-word-bits n-byte-bits) + "Number of bytes in a word.") + + +(defconstant float-sign-shift 31) + +(defconstant single-float-bias 126) +(defconstant-eqx single-float-exponent-byte (byte 8 23) #'equalp) +(defconstant-eqx single-float-significand-byte (byte 23 0) #'equalp) +(defconstant single-float-normal-exponent-min 1) +(defconstant single-float-normal-exponent-max 254) +(defconstant single-float-hidden-bit (ash 1 23)) +(defconstant single-float-trapping-nan-bit (ash 1 22)) + +(defconstant double-float-bias 1022) +(defconstant-eqx double-float-exponent-byte (byte 11 20) #'equalp) +(defconstant-eqx double-float-significand-byte (byte 20 0) #'equalp) +(defconstant double-float-normal-exponent-min 1) +(defconstant double-float-normal-exponent-max #x7FE) +(defconstant double-float-hidden-bit (ash 1 20)) +(defconstant double-float-trapping-nan-bit (ash 1 19)) + +(defconstant single-float-digits + (+ (byte-size single-float-significand-byte) 1)) + +(defconstant double-float-digits + (+ (byte-size double-float-significand-byte) n-word-bits 1)) + + +(defconstant float-inexact-trap-bit (ash 1 0)) +(defconstant float-divide-by-zero-trap-bit (ash 1 1)) +(defconstant float-underflow-trap-bit (ash 1 2)) +(defconstant float-overflow-trap-bit (ash 1 3)) +(defconstant float-invalid-trap-bit (ash 1 4)) + +(defconstant float-round-to-nearest 0) +(defconstant float-round-to-zero 1) +(defconstant float-round-to-positive 2) +(defconstant float-round-to-negative 3) + +(defconstant-eqx float-rounding-mode (byte 2 0) #'equalp) ; RD +(defconstant-eqx float-sticky-bits (byte 10 19) #'equalp) +(defconstant-eqx float-traps-byte (byte 6 3) #'equalp) +(defconstant-eqx float-exceptions-byte (byte 5 0) #'equalp) ; cexc + +(defconstant float-fast-bit 2) ; Non-IEEE mode + + +;;; NUMBER-STACK-DISPLACEMENT +;;; +;;; The number of bytes reserved above the number stack pointer. These +;;; slots are required by architecture, mostly (?) to make C backtrace +;;; work. +;;; +(defconstant number-stack-displacement + (* 2 sb!vm:n-word-bytes)) + + + + +;;; Where to put the different spaces. +;;; + +(defconstant read-only-space-start #x01000000) +(defconstant read-only-space-end #x04ff8000) + +(defconstant binding-stack-start #x06000000) +(defconstant binding-stack-end #x06ff0000) + +(defconstant control-stack-start #x07000000) +(defconstant control-stack-end #x07ff0000) + +(defconstant static-space-start #x08000000) +(defconstant static-space-end #x097fff00) + +;;; FIXME: this is a gross violation of OAOO, done purely to support +;;; the #define of DYNAMIC_SPACE_SIZE in validate.c -- CSR, 2002-02-25 +;;; (these numbers should match dynamic-0-*) +(defconstant dynamic-space-start #x40000000) +(defconstant dynamic-space-end #x47fff000) + +;;; nothing _seems_ to be using these addresses +(defconstant dynamic-0-space-start #x40000000) +(defconstant dynamic-0-space-end #x47fff000) +(defconstant dynamic-1-space-start #x48000000) +(defconstant dynamic-1-space-end #x4ffff000) + + + + +;;;; Other random constants. + +(defenum (:suffix -trap :start 8) + halt + pending-interrupt + error + cerror + breakpoint + fun-end-breakpoint + after-breakpoint + fixnum-additive-overflow) + +(defenum (:prefix object-not- :suffix -trap :start 16) + list + instance) + +(defenum (:prefix trace-table-) + normal + call-site + fun-prologue + fun-epilogue) + + +;;;; Static symbols. + + +;;; These symbols are loaded into static space directly after NIL so +;;; that the system can compute their address by adding a constant +;;; amount to NIL. +;;; +;;; The fdefn objects for the static functions are loaded into static +;;; space directly after the static symbols. That way, the raw-addr +;;; can be loaded directly out of them by indirecting relative to NIL. +;;; +(defparameter *static-symbols* + '(t + + ;; The C startup code must fill these in. + *posix-argv* + sb!impl::*initial-fdefn-objects* + + ;; Functions that the C code needs to call + ;; sb!impl::%initial-fun + sb!impl::maybe-gc + sb!kernel::internal-error + sb!di::handle-breakpoint + sb!impl::fdefinition-object + + ;; Free Pointers. + *read-only-space-free-pointer* + *static-space-free-pointer* + *initial-dynamic-space-free-pointer* + + ;; Things needed for non-local-exit. + *current-catch-block* + *current-unwind-protect-block* + *eval-stack-top* + + ;; Interrupt Handling + *free-interrupt-context-index* + sb!unix::*interrupts-enabled* + sb!unix::*interrupt-pending* + + #|sb!kernel::*current-thread*|# + )) + +(defparameter *static-funs* + '(length + sb!kernel:two-arg-+ + sb!kernel:two-arg-- + sb!kernel:two-arg-* + sb!kernel:two-arg-/ + sb!kernel:two-arg-< + sb!kernel:two-arg-> + sb!kernel:two-arg-= + sb!kernel:two-arg-<= + sb!kernel:two-arg->= + sb!kernel:two-arg-/= + eql + sb!kernel:%negate + sb!kernel:two-arg-and + sb!kernel:two-arg-ior + sb!kernel:two-arg-xor + sb!kernel:two-arg-gcd + sb!kernel:two-arg-lcm)) + + +;;;; Assembler parameters: + +;;; The number of bits per element in the assemblers code vector. +;;; +(defparameter *assembly-unit-length* 8) diff --git a/src/compiler/ppc/pred.lisp b/src/compiler/ppc/pred.lisp new file mode 100644 index 0000000..f6bd806 --- /dev/null +++ b/src/compiler/ppc/pred.lisp @@ -0,0 +1,30 @@ +;;; +;;; Converted by William Lott. +;;; + +(in-package "SB!VM") + + +;;;; The Branch VOP. + +;;; The unconditional branch, emitted when we can't drop through to the desired +;;; destination. Dest is the continuation we transfer control to. +;;; +(define-vop (branch) + (:info dest) + (:generator 5 + (inst b dest))) + + +;;;; Conditional VOPs: + +(define-vop (if-eq) + (:args (x :scs (any-reg descriptor-reg zero null)) + (y :scs (any-reg descriptor-reg zero null))) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:translate eq) + (:generator 3 + (inst cmpw x y) + (inst b? (if not-p :ne :eq) target))) diff --git a/src/compiler/ppc/print.lisp b/src/compiler/ppc/print.lisp new file mode 100644 index 0000000..526b1c2 --- /dev/null +++ b/src/compiler/ppc/print.lisp @@ -0,0 +1,28 @@ +;;; Written by William Lott. + +(in-package "SB!VM") + + +(define-vop (print) + (:args (object :scs (descriptor-reg any-reg) :target nl0)) + (:results (result :scs (descriptor-reg))) + (:save-p t) + (:temporary (:sc any-reg :offset nl0-offset :from (:argument 0)) nl0) + (:temporary (:sc any-reg :offset cfunc-offset) cfunc) + (:temporary (:sc interior-reg :offset lip-offset) lip) + (:temporary (:scs (non-descriptor-reg)) temp) + (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) + (:vop-var vop) + (:generator 100 + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (store-stack-tn nfp-save cur-nfp)) + (move nl0 object) + (inst lr temp (make-fixup "call_into_c" :foreign)) + (inst mr lip temp) + (inst mtctr lip) + (inst lr cfunc (make-fixup "debug_print" :foreign)) + (inst bctrl) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save)) + (move result nl0)))) diff --git a/src/compiler/ppc/sap.lisp b/src/compiler/ppc/sap.lisp new file mode 100644 index 0000000..a143546 --- /dev/null +++ b/src/compiler/ppc/sap.lisp @@ -0,0 +1,292 @@ +;;; +;;; Written by William Lott. +;;; +(in-package "SB!VM") + + +;;;; Moves and coercions: + +;;; Move a tagged SAP to an untagged representation. +;;; +(define-vop (move-to-sap) + (:args (x :scs (any-reg descriptor-reg))) + (:results (y :scs (sap-reg))) + (:note "pointer to SAP coercion") + (:generator 1 + (loadw y x sap-pointer-slot other-pointer-lowtag))) + +;;; +(define-move-vop move-to-sap :move + (descriptor-reg) (sap-reg)) + + +;;; Move an untagged SAP to a tagged representation. +;;; +(define-vop (move-from-sap) + (:args (sap :scs (sap-reg) :to :save)) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag) + (:results (res :scs (descriptor-reg))) + (:note "SAP to pointer coercion") + (:generator 20 + (with-fixed-allocation (res pa-flag ndescr sap-widetag sap-size) + (storew sap res sap-pointer-slot other-pointer-lowtag)))) +;;; +(define-move-vop move-from-sap :move + (sap-reg) (descriptor-reg)) + + +;;; Move untagged sap values. +;;; +(define-vop (sap-move) + (:args (x :target y + :scs (sap-reg) + :load-if (not (location= x y)))) + (:results (y :scs (sap-reg) + :load-if (not (location= x y)))) + (:note "SAP move") + (:effects) + (:affected) + (:generator 0 + (move y x))) +;;; +(define-move-vop sap-move :move + (sap-reg) (sap-reg)) + + +;;; Move untagged sap arguments/return-values. +;;; +(define-vop (move-sap-arg) + (:args (x :target y + :scs (sap-reg)) + (fp :scs (any-reg) + :load-if (not (sc-is y sap-reg)))) + (:results (y)) + (:note "SAP argument move") + (:generator 0 + (sc-case y + (sap-reg + (move y x)) + (sap-stack + (storew x fp (tn-offset y)))))) +;;; +(define-move-vop move-sap-arg :move-arg + (descriptor-reg sap-reg) (sap-reg)) + + +;;; Use standard MOVE-ARG + coercion to move an untagged sap to a +;;; descriptor passing location. +;;; +(define-move-vop move-arg :move-arg + (sap-reg) (descriptor-reg)) + + + +;;;; SAP-INT and INT-SAP + +(define-vop (sap-int) + (:args (sap :scs (sap-reg) :target int)) + (:arg-types system-area-pointer) + (:results (int :scs (unsigned-reg))) + (:result-types unsigned-num) + (:translate sap-int) + (:policy :fast-safe) + (:generator 1 + (move int sap))) + +(define-vop (int-sap) + (:args (int :scs (unsigned-reg) :target sap)) + (:arg-types unsigned-num) + (:results (sap :scs (sap-reg))) + (:result-types system-area-pointer) + (:translate int-sap) + (:policy :fast-safe) + (:generator 1 + (move sap int))) + + + +;;;; POINTER+ and POINTER- + +(define-vop (pointer+) + (:translate sap+) + (:args (ptr :scs (sap-reg)) + (offset :scs (signed-reg))) + (:arg-types system-area-pointer signed-num) + (:results (res :scs (sap-reg))) + (:result-types system-area-pointer) + (:policy :fast-safe) + (:generator 2 + (inst add res ptr offset))) + +(define-vop (pointer+-c) + (:translate sap+) + (:args (ptr :scs (sap-reg))) + (:info offset) + (:arg-types system-area-pointer (:constant (signed-byte 16))) + (:results (res :scs (sap-reg))) + (:result-types system-area-pointer) + (:policy :fast-safe) + (:generator 1 + (inst addi res ptr offset))) + +(define-vop (pointer-) + (:translate sap-) + (:args (ptr1 :scs (sap-reg)) + (ptr2 :scs (sap-reg))) + (:arg-types system-area-pointer system-area-pointer) + (:policy :fast-safe) + (:results (res :scs (signed-reg))) + (:result-types signed-num) + (:generator 1 + (inst sub res ptr1 ptr2))) + + + +;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET + +(macrolet ((def-system-ref-and-set + (ref-name set-name sc type size &optional signed) + (let ((ref-name-c (symbolicate ref-name "-C")) + (set-name-c (symbolicate set-name "-C"))) + `(progn + (define-vop (,ref-name) + (:translate ,ref-name) + (:policy :fast-safe) + (:args (sap :scs (sap-reg)) + (offset :scs (signed-reg))) + (:arg-types system-area-pointer signed-num) + (:results (result :scs (,sc))) + (:result-types ,type) + (:generator 5 + (inst ,(ecase size + (:byte 'lbzx) + (:short (if signed 'lhax 'lhzx)) + (:long 'lwzx) + (:single 'lfsx) + (:double 'lfdx)) + result sap offset) + ,@(when (and (eq size :byte) signed) + '((inst extsb result result))))) + (define-vop (,ref-name-c) + (:translate ,ref-name) + (:policy :fast-safe) + (:args (sap :scs (sap-reg))) + (:arg-types system-area-pointer (:constant (signed-byte 16))) + (:info offset) + (:results (result :scs (,sc))) + (:result-types ,type) + (:generator 4 + (inst ,(ecase size + (:byte 'lbz) + (:short (if signed 'lha 'lhz)) + (:long 'lwz) + (:single 'lfs) + (:double 'lfd)) + result sap offset) + ,@(when (and (eq size :byte) signed) + '((inst extsb result result))))) + (define-vop (,set-name) + (:translate ,set-name) + (:policy :fast-safe) + (:args (sap :scs (sap-reg)) + (offset :scs (signed-reg)) + (value :scs (,sc) :target result)) + (:arg-types system-area-pointer signed-num ,type) + (:results (result :scs (,sc))) + (:result-types ,type) + (:generator 5 + (inst ,(ecase size + (:byte 'stbx) + (:short 'sthx) + (:long 'stwx) + (:single 'stfsx) + (:double 'stfdx)) + value sap offset) + (unless (location= result value) + ,@(case size + (:single + '((inst frsp result value))) + (:double + '((inst fmr result value))) + (t + '((inst mr result value))))))) + (define-vop (,set-name-c) + (:translate ,set-name) + (:policy :fast-safe) + (:args (sap :scs (sap-reg)) + (value :scs (,sc) :target result)) + (:arg-types system-area-pointer (:constant (signed-byte 16)) ,type) + (:info offset) + (:results (result :scs (,sc))) + (:result-types ,type) + (:generator 4 + (inst ,(ecase size + (:byte 'stb) + (:short 'sth) + (:long 'stw) + (:single 'stfs) + (:double 'stfd)) + value sap offset) + (unless (location= result value) + ,@(case size + (:single + '((inst frsp result value))) + (:double + '((inst fmr result value))) + (t + '((inst mr result value))))))))))) + (def-system-ref-and-set sap-ref-8 %set-sap-ref-8 + unsigned-reg positive-fixnum :byte nil) + (def-system-ref-and-set signed-sap-ref-8 %set-signed-sap-ref-8 + signed-reg tagged-num :byte t) + (def-system-ref-and-set sap-ref-16 %set-sap-ref-16 + unsigned-reg positive-fixnum :short nil) + (def-system-ref-and-set signed-sap-ref-16 %set-signed-sap-ref-16 + signed-reg tagged-num :short t) + (def-system-ref-and-set sap-ref-32 %set-sap-ref-32 + unsigned-reg unsigned-num :long nil) + (def-system-ref-and-set signed-sap-ref-32 %set-signed-sap-ref-32 + signed-reg signed-num :long t) + (def-system-ref-and-set sap-ref-sap %set-sap-ref-sap + sap-reg system-area-pointer :long) + (def-system-ref-and-set sap-ref-single %set-sap-ref-single + single-reg single-float :single) + (def-system-ref-and-set sap-ref-double %set-sap-ref-double + double-reg double-float :double)) + + + +;;; Noise to convert normal lisp data objects into SAPs. + +(define-vop (vector-sap) + (:translate vector-sap) + (:policy :fast-safe) + (:args (vector :scs (descriptor-reg))) + (:results (sap :scs (sap-reg))) + (:result-types system-area-pointer) + (:generator 2 + (inst addi sap vector + (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)))) + + +;;; Transforms for 64-bit SAP accessors. +#| +(deftransform sap-ref-64 ((sap offset) (* *)) + '(logior (ash (sap-ref-32 sap offset) 32) + (sap-ref-32 sap (+ offset 4)))) + +(deftransform signed-sap-ref-64 ((sap offset) (* *)) + '(logior (ash (signed-sap-ref-32 sap offset) 32) + (sap-ref-32 sap (+ 4 offset)))) + +(deftransform %set-sap-ref-64 ((sap offset value) (* * *)) + '(progn + (%set-sap-ref-32 sap offset (ash value -32)) + (%set-sap-ref-32 sap (+ offset 4) (logand value #xffffffff)))) + +(deftransform %set-signed-sap-ref-64 ((sap offset value) (* * *)) + '(progn + (%set-signed-sap-ref-32 sap offset (ash value -32)) + (%set-sap-ref-32 sap (+ 4 offset) (logand value #xffffffff)))) +|# \ No newline at end of file diff --git a/src/compiler/ppc/show.lisp b/src/compiler/ppc/show.lisp new file mode 100644 index 0000000..526b1c2 --- /dev/null +++ b/src/compiler/ppc/show.lisp @@ -0,0 +1,28 @@ +;;; Written by William Lott. + +(in-package "SB!VM") + + +(define-vop (print) + (:args (object :scs (descriptor-reg any-reg) :target nl0)) + (:results (result :scs (descriptor-reg))) + (:save-p t) + (:temporary (:sc any-reg :offset nl0-offset :from (:argument 0)) nl0) + (:temporary (:sc any-reg :offset cfunc-offset) cfunc) + (:temporary (:sc interior-reg :offset lip-offset) lip) + (:temporary (:scs (non-descriptor-reg)) temp) + (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) + (:vop-var vop) + (:generator 100 + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (store-stack-tn nfp-save cur-nfp)) + (move nl0 object) + (inst lr temp (make-fixup "call_into_c" :foreign)) + (inst mr lip temp) + (inst mtctr lip) + (inst lr cfunc (make-fixup "debug_print" :foreign)) + (inst bctrl) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save)) + (move result nl0)))) diff --git a/src/compiler/ppc/static-fn.lisp b/src/compiler/ppc/static-fn.lisp new file mode 100644 index 0000000..faf19e6 --- /dev/null +++ b/src/compiler/ppc/static-fn.lisp @@ -0,0 +1,137 @@ +;;; Written by William Lott. +;;; +(in-package "SB!VM") + + + +(define-vop (static-fun-template) + (:save-p t) + (:policy :safe) + (:variant-vars symbol) + (:vop-var vop) + (:temporary (:scs (non-descriptor-reg)) temp) + (:temporary (:scs (descriptor-reg)) move-temp) + (:temporary (:sc descriptor-reg :offset lra-offset) lra) + (:temporary (:sc interior-reg :offset lip-offset) entry-point) + (:temporary (:scs (descriptor-reg)) func) + (:temporary (:sc any-reg :offset nargs-offset) nargs) + (:temporary (:sc any-reg :offset ocfp-offset) old-fp) + (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)) + + +(eval-when (:compile-toplevel :load-toplevel :execute) + + +(defun static-fun-template-name (num-args num-results) + (intern (format nil "~:@(~R-arg-~R-result-static-fun~)" + num-args num-results))) + + +(defun moves (dst src) + (collect ((moves)) + (do ((dst dst (cdr dst)) + (src src (cdr src))) + ((or (null dst) (null src))) + (moves `(move ,(car dst) ,(car src)))) + (moves))) + +(defun static-fun-template-vop (num-args num-results) + (assert (and (<= num-args register-arg-count) + (<= num-results register-arg-count)) + (num-args num-results) + "Either too many args (~W) or too many results (~W). Max = ~W" + num-args num-results register-arg-count) + (let ((num-temps (max num-args num-results))) + (collect ((temp-names) (temps) (arg-names) (args) (result-names) (results)) + (dotimes (i num-results) + (let ((result-name (intern (format nil "RESULT-~D" i)))) + (result-names result-name) + (results `(,result-name :scs (any-reg descriptor-reg))))) + (dotimes (i num-temps) + (let ((temp-name (intern (format nil "TEMP-~D" i)))) + (temp-names temp-name) + (temps `(:temporary (:sc descriptor-reg + :offset ,(nth i *register-arg-offsets*) + ,@(when (< i num-args) + `(:from (:argument ,i))) + ,@(when (< i num-results) + `(:to (:result ,i) + :target ,(nth i (result-names))))) + ,temp-name)))) + (dotimes (i num-args) + (let ((arg-name (intern (format nil "ARG-~D" i)))) + (arg-names arg-name) + (args `(,arg-name + :scs (any-reg descriptor-reg) + :target ,(nth i (temp-names)))))) + `(define-vop (,(static-fun-template-name num-args num-results) + static-fun-template) + (:args ,@(args)) + ,@(temps) + (:results ,@(results)) + (:generator ,(+ 50 num-args num-results) + (let ((lra-label (gen-label)) + (cur-nfp (current-nfp-tn vop))) + ,@(moves (temp-names) (arg-names)) + (inst lwz entry-point null-tn (static-fun-offset symbol)) + (inst lr nargs (fixnumize ,num-args)) + (when cur-nfp + (store-stack-tn nfp-save cur-nfp)) + (inst mr old-fp cfp-tn) + (inst mr cfp-tn csp-tn) + (inst compute-lra-from-code lra code-tn lra-label temp) + (note-this-location vop :call-site) + ;(inst mr code-tn func) + (inst mtctr entry-point) + (inst bctr) + (emit-return-pc lra-label) + ,(collect ((bindings) (links)) + (do ((temp (temp-names) (cdr temp)) + (name 'values (gensym)) + (prev nil name) + (i 0 (1+ i))) + ((= i num-results)) + (bindings `(,name + (make-tn-ref ,(car temp) nil))) + (when prev + (links `(setf (tn-ref-across ,prev) ,name)))) + `(let ,(bindings) + ,@(links) + (default-unknown-values vop + ,(if (zerop num-results) nil 'values) + ,num-results move-temp temp lra-label))) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save)) + ,@(moves (result-names) (temp-names)))))))) + + +) ; eval-when (:compile-toplevel :load-toplevel :execute) + + +(macrolet ((frob (num-args num-res) + (static-fun-template-vop (eval num-args) (eval num-res)))) + (frob 0 1) + (frob 1 1) + (frob 2 1) + (frob 3 1) + (frob 4 1) + #|(frob 5 1)|#) + + +(defmacro define-static-fun (name args &key (results '(x)) translate + policy cost arg-types result-types) + `(define-vop (,name + ,(static-fun-template-name (length args) + (length results))) + (:variant ',name) + (:note ,(format nil "static-fun ~@(~S~)" name)) + ,@(when translate + `((:translate ,translate))) + ,@(when policy + `((:policy ,policy))) + ,@(when cost + `((:generator-cost ,cost))) + ,@(when arg-types + `((:arg-types ,@arg-types))) + ,@(when result-types + `((:result-types ,@result-types))))) diff --git a/src/compiler/ppc/subprim.lisp b/src/compiler/ppc/subprim.lisp new file mode 100644 index 0000000..9e1826d --- /dev/null +++ b/src/compiler/ppc/subprim.lisp @@ -0,0 +1,47 @@ +;;; +;;; Written by William Lott. +;;; +(in-package "SB!VM") + + + +;;;; Length + +(define-vop (length/list) + (:translate length) + (:args (object :scs (descriptor-reg) :target ptr)) + (:arg-types list) + (:temporary (:scs (descriptor-reg) :from (:argument 0)) ptr) + (:temporary (:scs (non-descriptor-reg)) temp) + (:temporary (:scs (any-reg) :type fixnum :to (:result 0) :target result) + count) + (:results (result :scs (any-reg descriptor-reg))) + (:policy :fast-safe) + (:vop-var vop) + (:save-p :compute-only) + (:generator 50 + (let ((done (gen-label)) + (loop (gen-label)) + (not-list (generate-cerror-code vop object-not-list-error object))) + (move ptr object) + (move count zero-tn) + + (emit-label loop) + + (inst cmpw ptr null-tn) + (inst beq done) + + (test-type ptr temp not-list t sb!vm:list-pointer-lowtag) + + (loadw ptr ptr sb!vm:cons-cdr-slot sb!vm:list-pointer-lowtag) + (inst addi count count (fixnumize 1)) + (test-type ptr temp loop nil sb!vm:list-pointer-lowtag) + + (cerror-call vop done object-not-list-error ptr) + + (emit-label done) + (move result count)))) + + +(define-static-fun length (object) :translate length) + diff --git a/src/compiler/ppc/system.lisp b/src/compiler/ppc/system.lisp new file mode 100644 index 0000000..aa245b0 --- /dev/null +++ b/src/compiler/ppc/system.lisp @@ -0,0 +1,235 @@ +;;; +;;; Written by Rob MacLachlan +;;; +;;; Mips conversion by William Lott and Christopher Hoover. +;;; +(in-package "SB!VM") + + + +;;;; Type frobbing VOPs + +(define-vop (lowtag-of) + (:translate lowtag-of) + (:policy :fast-safe) + (:args (object :scs (any-reg descriptor-reg))) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 1 + (inst andi. result object sb!vm:lowtag-mask))) + +(define-vop (widetag-of) + (:translate widetag-of) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to (:eval 1))) + (:results (result :scs (unsigned-reg) :from (:eval 0))) + (:result-types positive-fixnum) + (:generator 6 + ;; Grab the lowtag. + (inst andi. result object lowtag-mask) + ;; Check for various pointer types. + (inst cmpwi result list-pointer-lowtag) + (inst beq done) + (inst cmpwi result other-pointer-lowtag) + (inst beq other-pointer) + (inst cmpwi result fun-pointer-lowtag) + (inst beq function-pointer) + (inst cmpwi result instance-pointer-lowtag) + (inst beq done) + ;; Okay, it is an immediate. If fixnum, we want zero. Otherwise, + ;; we want the low 8 bits. + (inst andi. result object #b11) + (inst beq done) + ;; It wasn't a fixnum, so get the low 8 bits. + (inst andi. result object widetag-mask) + (inst b done) + + FUNCTION-POINTER + (load-type result object (- fun-pointer-lowtag)) + (inst b done) + + OTHER-POINTER + (load-type result object (- other-pointer-lowtag)) + + DONE)) + + +(define-vop (fun-subtype) + (:translate fun-subtype) + (:policy :fast-safe) + (:args (function :scs (descriptor-reg))) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 6 + (load-type result function (- sb!vm:fun-pointer-lowtag)))) + +(define-vop (set-fun-subtype) + (:translate (setf fun-subtype)) + (:policy :fast-safe) + (:args (type :scs (unsigned-reg) :target result) + (function :scs (descriptor-reg))) + (:arg-types positive-fixnum *) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 6 + (inst stb type function (- 3 fun-pointer-lowtag)) + (move result type))) + +(define-vop (get-header-data) + (:translate get-header-data) + (:policy :fast-safe) + (:args (x :scs (descriptor-reg))) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 6 + (loadw res x 0 sb!vm:other-pointer-lowtag) + (inst srwi res res sb!vm:n-widetag-bits))) + +(define-vop (get-closure-length) + (:translate get-closure-length) + (:policy :fast-safe) + (:args (x :scs (descriptor-reg))) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 6 + (loadw res x 0 sb!vm:fun-pointer-lowtag) + (inst srwi res res sb!vm:n-widetag-bits))) + +(define-vop (set-header-data) + (:translate set-header-data) + (:policy :fast-safe) + (:args (x :scs (descriptor-reg) :target res) + (data :scs (any-reg immediate zero))) + (:arg-types * positive-fixnum) + (:results (res :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) t1 t2) + (:generator 6 + (loadw t1 x 0 sb!vm:other-pointer-lowtag) + (inst andi. t1 t1 sb!vm:widetag-mask) + (sc-case data + (any-reg + (inst slwi t2 data (- sb!vm:n-widetag-bits 2)) + (inst or t1 t1 t2)) + (immediate + (inst ori t1 t1 (ash (tn-value data) sb!vm:n-widetag-bits))) + (zero)) + (storew t1 x 0 sb!vm:other-pointer-lowtag) + (move res x))) + + +(define-vop (make-fixnum) + (:args (ptr :scs (any-reg descriptor-reg))) + (:results (res :scs (any-reg descriptor-reg))) + (:generator 1 + ;; + ;; Some code (the hash table code) depends on this returning a + ;; positive number so make sure it does. + (inst slwi res ptr 3) + (inst srwi res res 1))) + +(define-vop (make-other-immediate-type) + (:args (val :scs (any-reg descriptor-reg)) + (type :scs (any-reg descriptor-reg immediate) + :target temp)) + (:results (res :scs (any-reg descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 2 + (sc-case type + (immediate + (inst slwi temp val sb!vm:n-widetag-bits) + (inst ori res temp (tn-value type))) + (t + (inst srawi temp type 2) + (inst slwi res val (- sb!vm:n-widetag-bits 2)) + (inst or res res temp))))) + + +;;;; Allocation + +(define-vop (dynamic-space-free-pointer) + (:results (int :scs (sap-reg))) + (:result-types system-area-pointer) + (:translate dynamic-space-free-pointer) + (:policy :fast-safe) + (:generator 1 + (move int alloc-tn))) + +(define-vop (binding-stack-pointer-sap) + (:results (int :scs (sap-reg))) + (:result-types system-area-pointer) + (:translate binding-stack-pointer-sap) + (:policy :fast-safe) + (:generator 1 + (move int bsp-tn))) + +(define-vop (control-stack-pointer-sap) + (:results (int :scs (sap-reg))) + (:result-types system-area-pointer) + (:translate control-stack-pointer-sap) + (:policy :fast-safe) + (:generator 1 + (move int csp-tn))) + + +;;;; Code object frobbing. + +(define-vop (code-instructions) + (:translate code-instructions) + (:policy :fast-safe) + (:args (code :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:results (sap :scs (sap-reg))) + (:result-types system-area-pointer) + (:generator 10 + (loadw ndescr code 0 sb!vm:other-pointer-lowtag) + (inst srwi ndescr ndescr sb!vm:n-widetag-bits) + (inst slwi ndescr ndescr sb!vm:word-shift) + (inst subi ndescr ndescr sb!vm:other-pointer-lowtag) + (inst add sap code ndescr))) + +(define-vop (compute-fun) + (:args (code :scs (descriptor-reg)) + (offset :scs (signed-reg unsigned-reg))) + (:arg-types * positive-fixnum) + (:results (func :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:generator 10 + (loadw ndescr code 0 sb!vm:other-pointer-lowtag) + (inst srwi ndescr ndescr sb!vm:n-widetag-bits) + (inst slwi ndescr ndescr sb!vm:word-shift) + (inst add ndescr ndescr offset) + (inst addi ndescr ndescr (- sb!vm:fun-pointer-lowtag sb!vm:other-pointer-lowtag)) + (inst add func code ndescr))) + + + +;;;; Other random VOPs. + + +(defknown sb!unix::do-pending-interrupt () (values)) +(define-vop (sb!unix::do-pending-interrupt) + (:policy :fast-safe) + (:translate sb!unix::do-pending-interrupt) + (:generator 1 + (inst unimp pending-interrupt-trap))) + + +(define-vop (halt) + (:generator 1 + (inst unimp halt-trap))) + + + +;;;; Dynamic vop count collection support + +(define-vop (count-me) + (:args (count-vector :scs (descriptor-reg))) + (:info index) + (:temporary (:scs (non-descriptor-reg)) count) + (:generator 1 + (let ((offset + (- (* (+ index vector-data-offset) n-word-bytes) other-pointer-lowtag))) + (assert (typep offset '(signed-byte 16))) + (inst lwz count count-vector offset) + (inst addi count count 1) + (inst stw count count-vector offset)))) diff --git a/src/compiler/ppc/target-insts.lisp b/src/compiler/ppc/target-insts.lisp new file mode 100644 index 0000000..bb56ba6 --- /dev/null +++ b/src/compiler/ppc/target-insts.lisp @@ -0,0 +1,3 @@ +(in-package "SB!VM") + +;;; Let's see if an empty file works here. It does on the Alpha. diff --git a/src/compiler/ppc/type-vops.lisp b/src/compiler/ppc/type-vops.lisp new file mode 100644 index 0000000..0260508 --- /dev/null +++ b/src/compiler/ppc/type-vops.lisp @@ -0,0 +1,467 @@ +(in-package "SB!VM") + + +;;;; Simple type checking and testing: +;;; +;;; These types are represented by a single type code, so are easily +;;; open-coded as a mask and compare. + +(define-vop (check-type) + (:args (value :target result :scs (any-reg descriptor-reg))) + (:results (result :scs (any-reg descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) temp) + (:vop-var vop) + (:save-p :compute-only)) + +(define-vop (type-predicate) + (:args (value :scs (any-reg descriptor-reg))) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:temporary (:scs (non-descriptor-reg)) temp)) + +(eval-when (:compile-toplevel :load-toplevel) + (defun cost-to-test-types (type-codes) + (+ (* 2 (length type-codes)) + (if (> (apply #'max type-codes) lowtag-limit) 7 2)))) + +(macrolet ((def-type-vops (pred-name check-name ptype error-code + &rest type-codes) + (let ((cost (cost-to-test-types (mapcar #'eval type-codes)))) + `(progn + ,@(when pred-name + `((define-vop (,pred-name type-predicate) + (:translate ,pred-name) + (:generator ,cost + (test-type value temp target not-p ,@type-codes))))) + ,@(when check-name + `((define-vop (,check-name check-type) + (:generator ,cost + (let ((err-lab + (generate-error-code vop ,error-code value))) + (test-type value temp err-lab t ,@type-codes) + (move result value)))))) + ,@(when ptype + `((primitive-type-vop ,check-name (:check) ,ptype))))))) + + (def-type-vops fixnump nil nil object-not-fixnum-error + sb!vm:even-fixnum-lowtag sb!vm:odd-fixnum-lowtag) + (define-vop (check-fixnum check-type) + (:generator 3 + (inst andi. temp value 3) + (inst twi 0 value (error-number-or-lose 'object-not-fixnum-error)) + (inst twi :ne temp 0) + (move result value))) + (primitive-type-vop check-fixnum (:check) fixnum) + (def-type-vops functionp nil nil + object-not-fun-error sb!vm:fun-pointer-lowtag) + + (define-vop (check-fun check-type) + (:generator 3 + (inst andi. temp value 7) + (inst twi 0 value (error-number-or-lose 'object-not-fun-error)) + (inst twi :ne temp sb!vm:fun-pointer-lowtag) + (move result value))) + (primitive-type-vop check-fun (:check) function) + + (def-type-vops listp nil nil + object-not-list-error sb!vm:list-pointer-lowtag) + (define-vop (check-list check-type) + (:generator 3 + (inst andi. temp value 7) + (inst twi 0 value (error-number-or-lose 'object-not-list-error)) + (inst twi :ne temp sb!vm:list-pointer-lowtag) + (move result value))) + (primitive-type-vop check-list (:check) list) + + (def-type-vops %instancep nil nil + object-not-instance-error sb!vm:instance-pointer-lowtag) + (define-vop (check-instance check-type) + (:generator 3 + (inst andi. temp value 7) + (inst twi 0 value (error-number-or-lose 'object-not-instance-error)) + (inst twi :ne temp sb!vm:instance-pointer-lowtag) + (move result value))) + (primitive-type-vop check-instance (:check) instance) + + + (def-type-vops bignump check-bignum bignum + object-not-bignum-error sb!vm:bignum-widetag) + + (def-type-vops ratiop check-ratio ratio + object-not-ratio-error sb!vm:ratio-widetag) + + (def-type-vops complexp check-complex complex + object-not-complex-error sb!vm:complex-widetag + complex-single-float-widetag complex-double-float-widetag) + + (def-type-vops complex-rational-p check-complex-rational nil + object-not-complex-rational-error complex-widetag) + + (def-type-vops complex-float-p check-complex-float nil + object-not-complex-float-error + complex-single-float-widetag complex-double-float-widetag) + + (def-type-vops complex-single-float-p check-complex-single-float + complex-single-float object-not-complex-single-float-error + complex-single-float-widetag) + + (def-type-vops complex-double-float-p check-complex-double-float + complex-double-float object-not-complex-double-float-error + complex-double-float-widetag) + +(def-type-vops single-float-p check-single-float single-float + object-not-single-float-error sb!vm:single-float-widetag) + +(def-type-vops double-float-p check-double-float double-float + object-not-double-float-error sb!vm:double-float-widetag) + +(def-type-vops simple-string-p check-simple-string simple-string + object-not-simple-string-error sb!vm:simple-string-widetag) + +(def-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector + object-not-simple-bit-vector-error simple-bit-vector-widetag) + +(def-type-vops simple-vector-p check-simple-vector simple-vector + object-not-simple-vector-error sb!vm:simple-vector-widetag) + +(def-type-vops simple-array-unsigned-byte-2-p + check-simple-array-unsigned-byte-2 + simple-array-unsigned-byte-2 + object-not-simple-array-unsigned-byte-2-error + sb!vm:simple-array-unsigned-byte-2-widetag) + +(def-type-vops simple-array-unsigned-byte-4-p + check-simple-array-unsigned-byte-4 + simple-array-unsigned-byte-4 + object-not-simple-array-unsigned-byte-4-error + sb!vm:simple-array-unsigned-byte-4-widetag) + +(def-type-vops simple-array-unsigned-byte-8-p + check-simple-array-unsigned-byte-8 + simple-array-unsigned-byte-8 + object-not-simple-array-unsigned-byte-8-error + sb!vm:simple-array-unsigned-byte-8-widetag) + +(def-type-vops simple-array-unsigned-byte-16-p + check-simple-array-unsigned-byte-16 + simple-array-unsigned-byte-16 + object-not-simple-array-unsigned-byte-16-error + sb!vm:simple-array-unsigned-byte-16-widetag) + +(def-type-vops simple-array-unsigned-byte-32-p + check-simple-array-unsigned-byte-32 + simple-array-unsigned-byte-32 + object-not-simple-array-unsigned-byte-32-error + sb!vm:simple-array-unsigned-byte-32-widetag) + +(def-type-vops simple-array-signed-byte-8-p + check-simple-array-signed-byte-8 + simple-array-signed-byte-8 + object-not-simple-array-signed-byte-8-error + simple-array-signed-byte-8-widetag) + +(def-type-vops simple-array-signed-byte-16-p + check-simple-array-signed-byte-16 + simple-array-signed-byte-16 + object-not-simple-array-signed-byte-16-error + simple-array-signed-byte-16-widetag) + +(def-type-vops simple-array-signed-byte-30-p + check-simple-array-signed-byte-30 + simple-array-signed-byte-30 + object-not-simple-array-signed-byte-30-error + simple-array-signed-byte-30-widetag) + +(def-type-vops simple-array-signed-byte-32-p + check-simple-array-signed-byte-32 + simple-array-signed-byte-32 + object-not-simple-array-signed-byte-32-error + simple-array-signed-byte-32-widetag) + +(def-type-vops simple-array-single-float-p check-simple-array-single-float + simple-array-single-float object-not-simple-array-single-float-error + sb!vm:simple-array-single-float-widetag) + +(def-type-vops simple-array-double-float-p check-simple-array-double-float + simple-array-double-float object-not-simple-array-double-float-error + sb!vm:simple-array-double-float-widetag) + +(def-type-vops simple-array-complex-single-float-p + check-simple-array-complex-single-float + simple-array-complex-single-float + object-not-simple-array-complex-single-float-error + simple-array-complex-single-float-widetag) + +(def-type-vops simple-array-complex-double-float-p + check-simple-array-complex-double-float + simple-array-complex-double-float + object-not-simple-array-complex-double-float-error + simple-array-complex-double-float-widetag) + +(def-type-vops base-char-p check-base-char base-char + object-not-base-char-error sb!vm:base-char-widetag) + +(def-type-vops system-area-pointer-p check-system-area-pointer + system-area-pointer object-not-sap-error sb!vm:sap-widetag) + +(def-type-vops weak-pointer-p check-weak-pointer weak-pointer + object-not-weak-pointer-error sb!vm:weak-pointer-widetag) + +(def-type-vops code-component-p nil nil nil + sb!vm:code-header-widetag) + +(def-type-vops lra-p nil nil nil + sb!vm:return-pc-header-widetag) + +(def-type-vops fdefn-p nil nil nil + sb!vm:fdefn-widetag) + +(def-type-vops funcallable-instance-p nil nil nil + sb!vm:funcallable-instance-header-widetag) + +(def-type-vops array-header-p nil nil nil + sb!vm:simple-array-widetag sb!vm:complex-string-widetag sb!vm:complex-bit-vector-widetag + sb!vm:complex-vector-widetag sb!vm:complex-array-widetag) + +(def-type-vops nil check-function-or-symbol nil object-not-function-or-symbol-error + sb!vm:fun-pointer-lowtag sb!vm:symbol-header-widetag) + +(def-type-vops stringp check-string nil object-not-string-error + sb!vm:simple-string-widetag sb!vm:complex-string-widetag) + +(def-type-vops complex-vector-p check-complex-vector nil + object-not-complex-vector-error complex-vector-widetag) + +(def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error + sb!vm:simple-bit-vector-widetag sb!vm:complex-bit-vector-widetag) + +(def-type-vops vectorp check-vector nil object-not-vector-error + simple-string-widetag simple-bit-vector-widetag simple-vector-widetag + simple-array-unsigned-byte-2-widetag simple-array-unsigned-byte-4-widetag + simple-array-unsigned-byte-8-widetag simple-array-unsigned-byte-16-widetag + simple-array-unsigned-byte-32-widetag + simple-array-signed-byte-8-widetag simple-array-signed-byte-16-widetag + simple-array-signed-byte-30-widetag simple-array-signed-byte-32-widetag + simple-array-single-float-widetag simple-array-double-float-widetag + simple-array-complex-single-float-widetag + simple-array-complex-double-float-widetag + complex-string-widetag complex-bit-vector-widetag complex-vector-widetag) + +(def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error + simple-array-widetag simple-string-widetag simple-bit-vector-widetag + simple-vector-widetag simple-array-unsigned-byte-2-widetag + simple-array-unsigned-byte-4-widetag simple-array-unsigned-byte-8-widetag + simple-array-unsigned-byte-16-widetag simple-array-unsigned-byte-32-widetag + simple-array-signed-byte-8-widetag simple-array-signed-byte-16-widetag + simple-array-signed-byte-30-widetag simple-array-signed-byte-32-widetag + simple-array-single-float-widetag simple-array-double-float-widetag + simple-array-complex-single-float-widetag + simple-array-complex-double-float-widetag) + +(def-type-vops arrayp check-array nil object-not-array-error + simple-array-widetag simple-string-widetag simple-bit-vector-widetag + simple-vector-widetag simple-array-unsigned-byte-2-widetag + simple-array-unsigned-byte-4-widetag simple-array-unsigned-byte-8-widetag + simple-array-unsigned-byte-16-widetag simple-array-unsigned-byte-32-widetag + simple-array-signed-byte-8-widetag simple-array-signed-byte-16-widetag + simple-array-signed-byte-30-widetag simple-array-signed-byte-32-widetag + simple-array-single-float-widetag simple-array-double-float-widetag + simple-array-complex-single-float-widetag + simple-array-complex-double-float-widetag + complex-string-widetag complex-bit-vector-widetag complex-vector-widetag + complex-array-widetag) + +(def-type-vops numberp check-number nil object-not-number-error + even-fixnum-lowtag odd-fixnum-lowtag bignum-widetag ratio-widetag + single-float-widetag double-float-widetag complex-widetag + complex-single-float-widetag complex-double-float-widetag) + +(def-type-vops rationalp check-rational nil object-not-rational-error + sb!vm:even-fixnum-lowtag sb!vm:odd-fixnum-lowtag sb!vm:ratio-widetag sb!vm:bignum-widetag) + +(def-type-vops integerp check-integer nil object-not-integer-error + sb!vm:even-fixnum-lowtag sb!vm:odd-fixnum-lowtag sb!vm:bignum-widetag) + +(def-type-vops floatp check-float nil object-not-float-error + sb!vm:single-float-widetag sb!vm:double-float-widetag) + +(def-type-vops realp check-real nil object-not-real-error + sb!vm:even-fixnum-lowtag sb!vm:odd-fixnum-lowtag sb!vm:ratio-widetag sb!vm:bignum-widetag + sb!vm:single-float-widetag sb!vm:double-float-widetag)) + + +;;;; Other integer ranges. + +;;; A (signed-byte 32) can be represented with either fixnum or a bignum with +;;; exactly one digit. + +(define-vop (signed-byte-32-p type-predicate) + (:translate signed-byte-32-p) + (:generator 45 + (let ((not-target (gen-label))) + (multiple-value-bind + (yep nope) + (if not-p + (values not-target target) + (values target not-target)) + (inst andi. temp value #x3) + (inst beq yep) + (test-type value temp nope t sb!vm:other-pointer-lowtag) + (loadw temp value 0 sb!vm:other-pointer-lowtag) + (inst cmpwi temp (+ (ash 1 sb!vm:n-widetag-bits) + sb!vm:bignum-widetag)) + (inst b? (if not-p :ne :eq) target) + (emit-label not-target))))) + +(define-vop (check-signed-byte-32 check-type) + (:generator 45 + (let ((nope (generate-error-code vop object-not-signed-byte-32-error value)) + (yep (gen-label))) + (inst andi. temp value #x3) + (inst beq yep) + (test-type value temp nope t sb!vm:other-pointer-lowtag) + (loadw temp value 0 sb!vm:other-pointer-lowtag) + (inst cmpwi temp (+ (ash 1 sb!vm:n-widetag-bits) sb!vm:bignum-widetag)) + (inst bne nope) + (emit-label yep) + (move result value)))) + + +;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a +;;; bignum with exactly one positive digit, or a bignum with exactly two digits +;;; and the second digit all zeros. + +(define-vop (unsigned-byte-32-p type-predicate) + (:translate unsigned-byte-32-p) + (:generator 45 + (let ((not-target (gen-label)) + (single-word (gen-label)) + (fixnum (gen-label))) + (multiple-value-bind + (yep nope) + (if not-p + (values not-target target) + (values target not-target)) + ;; Is it a fixnum? + (inst andi. temp value #x3) + (inst cmpwi :cr1 value 0) + (inst beq fixnum) + + ;; If not, is it an other pointer? + (test-type value temp nope t sb!vm:other-pointer-lowtag) + ;; Get the header. + (loadw temp value 0 sb!vm:other-pointer-lowtag) + ;; Is it one? + (inst cmpwi temp (+ (ash 1 sb!vm:n-widetag-bits) sb!vm:bignum-widetag)) + (inst beq single-word) + ;; If it's other than two, we can't be an (unsigned-byte 32) + (inst cmpwi temp (+ (ash 2 sb!vm:n-widetag-bits) sb!vm:bignum-widetag)) + (inst bne nope) + ;; Get the second digit. + (loadw temp value (1+ sb!vm:bignum-digits-offset) sb!vm:other-pointer-lowtag) + ;; All zeros, its an (unsigned-byte 32). + (inst cmpwi temp 0) + (inst beq yep) + ;; Otherwise, it isn't. + (inst b nope) + + (emit-label single-word) + ;; Get the single digit. + (loadw temp value sb!vm:bignum-digits-offset sb!vm:other-pointer-lowtag) + (inst cmpwi :cr1 temp 0) + + ;; positive implies (unsigned-byte 32). + (emit-label fixnum) + (inst b? :cr1 (if not-p :lt :ge) target) + + (emit-label not-target))))) + +(define-vop (check-unsigned-byte-32 check-type) + (:generator 45 + (let ((nope + (generate-error-code vop object-not-unsigned-byte-32-error value)) + (yep (gen-label)) + (fixnum (gen-label)) + (single-word (gen-label))) + ;; Is it a fixnum? + (inst andi. temp value #x3) + (inst cmpwi :cr1 value 0) + (inst beq fixnum) + + ;; If not, is it an other pointer? + (test-type value temp nope t sb!vm:other-pointer-lowtag) + ;; Get the number of digits. + (loadw temp value 0 sb!vm:other-pointer-lowtag) + ;; Is it one? + (inst cmpwi temp (+ (ash 1 sb!vm:n-widetag-bits) sb!vm:bignum-widetag)) + (inst beq single-word) + ;; If it's other than two, we can't be an (unsigned-byte 32) + (inst cmpwi temp (+ (ash 2 sb!vm:n-widetag-bits) sb!vm:bignum-widetag)) + (inst bne nope) + ;; Get the second digit. + (loadw temp value (1+ sb!vm:bignum-digits-offset) sb!vm:other-pointer-lowtag) + ;; All zeros, its an (unsigned-byte 32). + (inst cmpwi temp 0) + (inst beq yep) + ;; Otherwise, it isn't. + (inst b nope) + + (emit-label single-word) + ;; Get the single digit. + (loadw temp value sb!vm:bignum-digits-offset sb!vm:other-pointer-lowtag) + ;; positive implies (unsigned-byte 32). + (inst cmpwi :cr1 temp 0) + + (emit-label fixnum) + (inst blt :cr1 nope) + + (emit-label yep) + (move result value)))) + + + + +;;;; List/symbol types: +;;; +;;; symbolp (or symbol (eq nil)) +;;; consp (and list (not (eq nil))) + +(define-vop (symbolp type-predicate) + (:translate symbolp) + (:generator 12 + (let* ((drop-thru (gen-label)) + (is-symbol-label (if not-p drop-thru target))) + (inst cmpw value null-tn) + (inst beq is-symbol-label) + (test-type value temp target not-p sb!vm:symbol-header-widetag) + (emit-label drop-thru)))) + +(define-vop (check-symbol check-type) + (:generator 12 + (let ((drop-thru (gen-label)) + (error (generate-error-code vop object-not-symbol-error value))) + (inst cmpw value null-tn) + (inst beq drop-thru) + (test-type value temp error t sb!vm:symbol-header-widetag) + (emit-label drop-thru) + (move result value)))) + +(define-vop (consp type-predicate) + (:translate consp) + (:generator 8 + (let* ((drop-thru (gen-label)) + (is-not-cons-label (if not-p target drop-thru))) + (inst cmpw value null-tn) + (inst beq is-not-cons-label) + (test-type value temp target not-p sb!vm:list-pointer-lowtag) + (emit-label drop-thru)))) + +(define-vop (check-cons check-type) + (:generator 8 + (let ((error (generate-error-code vop object-not-cons-error value))) + (inst cmpw value null-tn) + (inst beq error) + (test-type value temp error t sb!vm:list-pointer-lowtag) + (move result value)))) + diff --git a/src/compiler/ppc/values.lisp b/src/compiler/ppc/values.lisp new file mode 100644 index 0000000..230a13b --- /dev/null +++ b/src/compiler/ppc/values.lisp @@ -0,0 +1,113 @@ +;;; +;;; Written by Rob MacLachlan +;;; +;;; Converted for SPARC by William Lott. +;;; + +(in-package "SB!VM") + +(define-vop (reset-stack-pointer) + (:args (ptr :scs (any-reg))) + (:generator 1 + (move csp-tn ptr))) + + +;;; Push some values onto the stack, returning the start and number of values +;;; pushed as results. It is assumed that the Vals are wired to the standard +;;; argument locations. Nvals is the number of values to push. +;;; +;;; The generator cost is pseudo-random. We could get it right by defining a +;;; bogus SC that reflects the costs of the memory-to-memory moves for each +;;; operand, but this seems unworthwhile. +;;; +(define-vop (push-values) + (:args (vals :more t)) + (:results (start :scs (any-reg) :from :load) + (count :scs (any-reg))) + (:info nvals) + (:temporary (:scs (descriptor-reg)) temp) + (:generator 20 + (inst mr start csp-tn) + (inst addi csp-tn csp-tn (* nvals sb!vm:n-word-bytes)) + (do ((val vals (tn-ref-across val)) + (i 0 (1+ i))) + ((null val)) + (let ((tn (tn-ref-tn val))) + (sc-case tn + (descriptor-reg + (storew tn start i)) + (control-stack + (load-stack-tn temp tn) + (storew temp start i))))) + (inst lr count (fixnumize nvals)))) + +;;; Push a list of values on the stack, returning Start and Count as used in +;;; unknown values continuations. +;;; +(define-vop (values-list) + (:args (arg :scs (descriptor-reg) :target list)) + (:arg-types list) + (:policy :fast-safe) + (:results (start :scs (any-reg)) + (count :scs (any-reg))) + (:temporary (:scs (descriptor-reg) :type list :from (:argument 0)) list) + (:temporary (:scs (descriptor-reg)) temp) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:vop-var vop) + (:save-p :compute-only) + (:generator 0 + (let ((loop (gen-label)) + (done (gen-label))) + + (move list arg) + (move start csp-tn) + + (emit-label loop) + (inst cmpw list null-tn) + (loadw temp list sb!vm:cons-car-slot sb!vm:list-pointer-lowtag) + (inst beq done) + (loadw list list sb!vm:cons-cdr-slot sb!vm:list-pointer-lowtag) + (inst addi csp-tn csp-tn sb!vm:n-word-bytes) + (storew temp csp-tn -1) + (test-type list ndescr loop nil sb!vm:list-pointer-lowtag) + (error-call vop bogus-arg-to-values-list-error list) + + (emit-label done) + (inst sub count csp-tn start)))) + + +;;; Copy the more arg block to the top of the stack so we can use them +;;; as function arguments. +;;; +(define-vop (%more-arg-values) + (:args (context :scs (descriptor-reg any-reg) :target src) + (skip :scs (any-reg zero immediate)) + (num :scs (any-reg) :target count)) + (:arg-types * positive-fixnum positive-fixnum) + (:temporary (:sc any-reg :from (:argument 0)) src) + (:temporary (:sc any-reg :from (:argument 2)) dst) + (:temporary (:sc descriptor-reg :from (:argument 1)) temp) + (:temporary (:sc any-reg) i) + (:results (start :scs (any-reg)) + (count :scs (any-reg))) + (:generator 20 + (sc-case skip + (zero + (inst mr src context)) + (immediate + (inst addi src context (* (tn-value skip) n-word-bytes))) + (any-reg + (inst add src context skip))) + (inst mr. count num) + (inst mr start csp-tn) + (inst beq done) + (inst mr dst csp-tn) + (inst add csp-tn csp-tn count) + (inst mr i count) + LOOP + (inst cmpwi i 4) + (inst subi i i 4) + (inst lwzx temp src i) + (inst stwx temp dst i) + (inst bne loop) + DONE)) diff --git a/src/compiler/ppc/vm.lisp b/src/compiler/ppc/vm.lisp new file mode 100644 index 0000000..7b482c4 --- /dev/null +++ b/src/compiler/ppc/vm.lisp @@ -0,0 +1,327 @@ +;;; +(in-package "SB!VM") + + +;;;; Define the registers + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar *register-names* (make-array 32 :initial-element nil))) + +(macrolet ((defreg (name offset) + (let ((offset-sym (symbolicate name "-OFFSET"))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant ,offset-sym ,offset) + (setf (svref *register-names* ,offset-sym) ,(symbol-name name))))) + + (defregset (name &rest regs) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter ,name + (list ,@(mapcar #'(lambda (name) + (symbolicate name "-OFFSET")) regs)))))) + + (defreg zero 0) + (defreg nsp 1) + (defreg rtoc 2) ; May be "NULL" someday. + (defreg nl0 3) + (defreg nl1 4) + (defreg nl2 5) + (defreg nl3 6) + (defreg nl4 7) + (defreg nl5 8) + (defreg nl6 9) + (defreg fdefn 10) ; was nl7 + (defreg nargs 11) + (defreg nfp 12) + (defreg cfunc 13) + (defreg bsp 14) + (defreg cfp 15) + (defreg csp 16) + (defreg alloc 17) + (defreg null 18) + (defreg code 19) + (defreg cname 20) + (defreg lexenv 21) + (defreg ocfp 22) + (defreg lra 23) + (defreg a0 24) + (defreg a1 25) + (defreg a2 26) + (defreg a3 27) + (defreg l0 28) + (defreg l1 29) + (defreg l2 30) + (defreg lip 31) + + (defregset non-descriptor-regs + nl0 nl1 nl2 nl3 nl4 nl5 nl6 #+nil nl7 cfunc nargs nfp) + + (defregset descriptor-regs + fdefn a0 a1 a2 a3 ocfp lra cname lexenv l0 l1 l2 ) + + + (defregset *register-arg-offsets* a0 a1 a2 a3) + (defparameter register-arg-names '(a0 a1 a2 a3))) + + + +;;;; SB and SC definition: + +(define-storage-base registers :finite :size 32) +(define-storage-base float-registers :finite :size 32) +(define-storage-base control-stack :unbounded :size 8) +(define-storage-base non-descriptor-stack :unbounded :size 0) +(define-storage-base constant :non-packed) +(define-storage-base immediate-constant :non-packed) + +;;; +;;; Handy macro so we don't have to keep changing all the numbers whenever +;;; we insert a new storage class. +;;; +(defmacro define-storage-classes (&rest classes) + (do ((forms (list 'progn) + (let* ((class (car classes)) + (sc-name (car class)) + (constant-name (intern (concatenate 'simple-string + (string sc-name) + "-SC-NUMBER")))) + (list* `(define-storage-class ,sc-name ,index + ,@(cdr class)) + `(defconstant ,constant-name ,index) + forms))) + (index 0 (1+ index)) + (classes classes (cdr classes))) + ((null classes) + (nreverse forms)))) + +;; XXX this is most likely wrong. Check with Eric Marsden next time you +;; see him +(defconstant sb!vm::kludge-nondeterministic-catch-block-size 7) + +(define-storage-classes + + ;; Non-immediate contstants in the constant pool + (constant constant) + + ;; ZERO and NULL are in registers. + (zero immediate-constant) + (null immediate-constant) + + ;; Anything else that can be an immediate. + (immediate immediate-constant) + + + ;; **** The stacks. + + ;; The control stack. (Scanned by GC) + (control-stack control-stack) + + ;; The non-descriptor stacks. + (signed-stack non-descriptor-stack) ; (signed-byte 32) + (unsigned-stack non-descriptor-stack) ; (unsigned-byte 32) + (base-char-stack non-descriptor-stack) ; non-descriptor characters. + (sap-stack non-descriptor-stack) ; System area pointers. + (single-stack non-descriptor-stack) ; single-floats + (double-stack non-descriptor-stack + :element-size 2 :alignment 2) ; double floats. + (complex-single-stack non-descriptor-stack :element-size 2) + (complex-double-stack non-descriptor-stack :element-size 4 :alignment 2) + + + ;; **** Things that can go in the integer registers. + + ;; Immediate descriptor objects. Don't have to be seen by GC, but nothing + ;; bad will happen if they are. (fixnums, characters, header values, etc). + (any-reg + registers + :locations #.(append non-descriptor-regs descriptor-regs) + :constant-scs (zero immediate) + :save-p t + :alternate-scs (control-stack)) + + ;; Pointer descriptor objects. Must be seen by GC. + (descriptor-reg registers + :locations #.descriptor-regs + :constant-scs (constant null immediate) + :save-p t + :alternate-scs (control-stack)) + + ;; Non-Descriptor characters + (base-char-reg registers + :locations #.non-descriptor-regs + :constant-scs (immediate) + :save-p t + :alternate-scs (base-char-stack)) + + ;; Non-Descriptor SAP's (arbitrary pointers into address space) + (sap-reg registers + :locations #.non-descriptor-regs + :constant-scs (immediate) + :save-p t + :alternate-scs (sap-stack)) + + ;; Non-Descriptor (signed or unsigned) numbers. + (signed-reg registers + :locations #.non-descriptor-regs + :constant-scs (zero immediate) + :save-p t + :alternate-scs (signed-stack)) + (unsigned-reg registers + :locations #.non-descriptor-regs + :constant-scs (zero immediate) + :save-p t + :alternate-scs (unsigned-stack)) + + ;; Random objects that must not be seen by GC. Used only as temporaries. + (non-descriptor-reg registers + :locations #.non-descriptor-regs) + + ;; Pointers to the interior of objects. Used only as a temporary. + (interior-reg registers + :locations (#.lip-offset)) + + + ;; **** Things that can go in the floating point registers. + + ;; Non-Descriptor single-floats. + (single-reg float-registers + :locations #.(loop for i from 0 to 31 collect i) + ;; ### Note: We really should have every location listed, but then we + ;; would have to make load-tns work with element-sizes other than 1. + :constant-scs () + :save-p t + :alternate-scs (single-stack)) + + ;; Non-Descriptor double-floats. + (double-reg float-registers + :locations #.(loop for i from 0 to 31 collect i) + ;; ### Note: load-tns don't work with an element-size other than 1. + ;; :element-size 2 :alignment 2 + :constant-scs () + :save-p t + :alternate-scs (double-stack)) + + (complex-single-reg float-registers + :locations #.(loop for i from 0 to 30 by 2 collect i) + :element-size 2 + :constant-scs () + :save-p t + :alternate-scs (complex-single-stack)) + + (complex-double-reg float-registers + :locations #.(loop for i from 0 to 30 by 2 collect i) + :element-size 2 + :constant-scs () + :save-p t + :alternate-scs (complex-double-stack)) + + ;; A catch or unwind block. + (catch-block control-stack + :element-size sb!vm::kludge-nondeterministic-catch-block-size)) + + + +;;;; Make some random tns for important registers. + +(macrolet ((defregtn (name sc) + (let ((offset-sym (symbolicate name "-OFFSET")) + (tn-sym (symbolicate name "-TN"))) + `(defparameter ,tn-sym + (make-random-tn :kind :normal + :sc (sc-or-lose ',sc) + :offset ,offset-sym))))) + + (defregtn zero any-reg) + (defregtn lip interior-reg) + (defregtn null descriptor-reg) + (defregtn code descriptor-reg) + (defregtn alloc any-reg) + + (defregtn nargs any-reg) + (defregtn bsp any-reg) + (defregtn csp any-reg) + (defregtn cfp any-reg) + (defregtn ocfp any-reg) + (defregtn nsp any-reg)) + + + +;;; Immediate-Constant-SC -- Interface +;;; +;;; If value can be represented as an immediate constant, then return the +;;; appropriate SC number, otherwise return NIL. +;;; +(!def-vm-support-routine immediate-constant-sc (value) + (typecase value + ((integer 0 0) + (sc-number-or-lose 'zero)) + (null + (sc-number-or-lose 'null)) + ((or fixnum system-area-pointer character) + (sc-number-or-lose 'immediate)) + (symbol + (if (static-symbol-p value) + (sc-number-or-lose 'immediate) + nil)))) + + +;;;; Function Call Parameters + +;;; The SC numbers for register and stack arguments/return values. +;;; +(defconstant register-arg-scn (meta-sc-number-or-lose 'descriptor-reg)) +(defconstant immediate-arg-scn (meta-sc-number-or-lose 'any-reg)) +(defconstant control-stack-arg-scn (meta-sc-number-or-lose 'control-stack)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + +;;; Offsets of special stack frame locations +(defconstant ocfp-save-offset 0) +(defconstant lra-save-offset 1) +(defconstant nfp-save-offset 2) + +;;; The number of arguments/return values passed in registers. +;;; +(defconstant register-arg-count 4) + +;;; Names to use for the argument registers. +;;; + + +); Eval-When (:compile-toplevel :load-toplevel :execute) + + +;;; A list of TN's describing the register arguments. +;;; +(defparameter *register-arg-tns* + (mapcar #'(lambda (n) + (make-random-tn :kind :normal + :sc (sc-or-lose 'descriptor-reg) + :offset n)) + *register-arg-offsets*)) + +(export 'single-value-return-byte-offset) + +;;; SINGLE-VALUE-RETURN-BYTE-OFFSET +;;; +;;; This is used by the debugger. +;;; +(defconstant single-value-return-byte-offset 8) + + +;;; LOCATION-PRINT-NAME -- Interface +;;; +;;; This function is called by debug output routines that want a pretty name +;;; for a TN's location. It returns a thing that can be printed with PRINC. +;;; +(!def-vm-support-routine location-print-name (tn) + (declare (type tn tn)) + (let ((sb (sb-name (sc-sb (tn-sc tn)))) + (offset (tn-offset tn))) + (ecase sb + (registers (or (svref *register-names* offset) + (format nil "R~D" offset))) + (float-registers (format nil "F~D" offset)) + (control-stack (format nil "CS~D" offset)) + (non-descriptor-stack (format nil "NS~D" offset)) + (constant (format nil "Const~D" offset)) + (immediate-constant "Immed")))) diff --git a/src/runtime/GNUmakefile b/src/runtime/GNUmakefile index 48cb4a9..99c0719 100644 --- a/src/runtime/GNUmakefile +++ b/src/runtime/GNUmakefile @@ -55,5 +55,9 @@ clean: rm -f depend *.o sbcl sbcl.nm core *.tmp ; true depend: ${SRCS} sbcl.h - $(CC) -MM -E ${DEPEND_FLAGS} ${CFLAGS} ${CPPFLAGS} $? > depend.tmp + $(CC) -MM -E ${DEPEND_FLAGS} ${CFLAGS} ${CPPFLAGS} $^ > depend.tmp mv -f depend.tmp depend + +# By including this file, we cause GNU to automatically make depend if +# it can't find it or it is out of date +include depend diff --git a/src/runtime/breakpoint.c b/src/runtime/breakpoint.c index d69e9c2..e45082f 100644 --- a/src/runtime/breakpoint.c +++ b/src/runtime/breakpoint.c @@ -62,7 +62,7 @@ void breakpoint_do_displaced_inst(os_context_t* context, * * -dan 2001.08.09 */ -#if !(defined(hpux) || defined(irix) || defined(__i386__) || defined(alpha)) +#if (defined(sparc) && defined (solaris)) undo_fake_foreign_function_call(context); #endif arch_do_displaced_inst(context, orig_inst); diff --git a/src/runtime/globals.h b/src/runtime/globals.h index 6989820..495e855 100644 --- a/src/runtime/globals.h +++ b/src/runtime/globals.h @@ -53,6 +53,9 @@ extern void globals_init(void); #define EXTERN(name,bytes) .globl name #endif #endif +#ifdef ppc +#define EXTERN(name,bytes) .globl name +#endif #ifdef __i386__ #ifdef __linux__ /* I'm very dubious about this. Linux hasn't used _ on external names diff --git a/src/runtime/ldso-stubs.S b/src/runtime/ldso-stubs.S index a4a0868..40ce64d 100644 --- a/src/runtime/ldso-stubs.S +++ b/src/runtime/ldso-stubs.S @@ -42,10 +42,6 @@ ldso_stub__ ## fct: ; \ .size ldso_stub__ ## fct,.L ## fct ## e1-ldso_stub__ ## fct ; #elif defined alpha - - /* I _hope_ this is correct - I haven't checked in the manual - * yet. It works to the point of building and passing tests, - * at any rate - dan 2001.05.10 */ #define LDSO_STUBIFY(fct) \ .globl ldso_stub__ ## fct ; \ .type ldso_stub__ ## fct,@function ; \ @@ -53,6 +49,15 @@ ldso_stub__ ## fct: ; \ jmp fct ; \ .L ## fct ## e1: ; \ .size ldso_stub__ ## fct,.L ## fct ## e1-ldso_stub__ ## fct ; + +#elif defined ppc +#define LDSO_STUBIFY(fct) \ +.globl ldso_stub__ ## fct ; \ + .type ldso_stub__ ## fct,@function ; \ +ldso_stub__ ## fct: ; \ + b fct ; \ +.L ## fct ## e1: ; \ + .size ldso_stub__ ## fct,.L ## fct ## e1-ldso_stub__ ## fct ; #else #error unsupported CPU architecture diff --git a/version.lisp-expr b/version.lisp-expr index 352ad23..4120a1c 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; for internal versions, especially for internal versions off the ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.1.44" +"0.7.1.45"