--- /dev/null
+(in-package "SB!VM")
+
+;;; But we do everything inline now that we have a better pseudo-atomic.
--- /dev/null
+(in-package "SB!VM")
+
+
+\f
+;;;; 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))
+
+
+\f
+;;;; 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))
+
+
+\f
+;;;; 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))
+
+\f
+;;;; 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))
--- /dev/null
+(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))
+
+
+\f
+;;;; 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))
--- /dev/null
+(in-package "SB!VM")
+
+\f
+;;;; 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))
+
+
+\f
+;;;; 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))
+
+
+\f
+;;;; 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)))
+
+
+
--- /dev/null
+(in-package "SB!VM")
+
+\f
+;;;; 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))
+
+\f
+;;;; 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))
+
+
+\f
+;;;; 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
--- /dev/null
+(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)))
(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)
--- /dev/null
+;;; 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))
+
+\f
+;;;; 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?")
+
+
+\f
+;;; 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)
+
+
+\f
+;;;; 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))))))
+
+
+\f
+;;; 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)
+
+
+\f
+;;; 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)
+
(: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))
(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
--- /dev/null
+;;;
+;;; Written by William Lott.
+;;;
+
+(in-package "SB!VM")
+
+\f
+;;;; 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))
+
+\f
+;;;; 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)))
+
+
+\f
+;;;; 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))))
--- /dev/null
+;;;
+;;; Converted by William Lott.
+;;;
+
+(in-package "SB!VM")
+
+
+\f
+;;;; 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)))
+
+
+\f
+;;;; 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))))
+
+\f
+;;;; 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 :ge :lt) target)))
+
+(define-vop (fast-if-<-c/fixnum fast-conditional-c/fixnum)
+ (:translate <)
+ (:generator 3
+ (inst cmpwi x (fixnumize y))
+ (inst b? (if not-p :ge :lt) target)))
+
+(define-vop (fast-if-</signed fast-conditional/signed)
+ (:translate <)
+ (:generator 6
+ (inst cmpw x y)
+ (inst b? (if not-p :ge :lt) target)))
+
+(define-vop (fast-if-<-c/signed fast-conditional-c/signed)
+ (:translate <)
+ (:generator 5
+ (inst cmpwi x y)
+ (inst b? (if not-p :ge :lt) target)))
+
+(define-vop (fast-if-</unsigned fast-conditional/unsigned)
+ (:translate <)
+ (:generator 6
+ (inst cmplw x y)
+ (inst b? (if not-p :ge :lt) target)))
+
+(define-vop (fast-if-<-c/unsigned fast-conditional-c/unsigned)
+ (:translate <)
+ (:generator 5
+ (inst cmplwi x y)
+ (inst b? (if not-p :ge :lt) target)))
+
+(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))
+
+\f
+;;;; 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)))
+
+
+
+\f
+;;;; 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)))
+
+\f
+;;;; 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)
--- /dev/null
+;;;
+;;; Written by William Lott
+;;;
+(in-package "SB!VM")
+
+\f
+;;;; 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)))
+
+\f
+;;;; 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)))
+
+
+\f
+;;;; 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))))
+
+
+\f
+;;;; 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))))
+
+\f
+;;; 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)))))
+
+\f
+;;; 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))
+
+
+\f
+;;;; 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))
+
+\f
+;;;
+
+(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))
+
--- /dev/null
+(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)
+
--- /dev/null
+;;; 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)))))))
--- /dev/null
+;;;; 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")
+\f
+;;;; 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))
+
+\f
+;;;; 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.
+<end of code>
+
+<elsewhere>
+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))
+
+\f
+;;;; 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))
+
+
+\f
+;;;; 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)))
+
+\f
+;;;; 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)))
+
+\f
+;;;; 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))))
+
+\f
+;;;; 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)))
+
+
+\f
+;;;; 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))
--- /dev/null
+;;; VOPs for the PPC.
+;;;
+;;; Written by Rob MacLachlan
+;;;
+;;; Converted by William Lott.
+;;;
+
+(in-package "SB!VM")
+
+\f
+;;;; 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)))
+
+
+\f
+;;;; 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))
+
+\f
+;;;; 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)))
+
+
+\f
+;;;; 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))))
+
+
+\f
+;;;; 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))
+
+\f
+;;;; 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))
+
+
+\f
+;;;; 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 *))
+
+
+
+\f
+;;;; 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))
+
--- /dev/null
+;;;
+;;; Written by Rob MacLachlan
+;;; Converted for the MIPS R2000 by Christopher Hoover.
+;;; And then to the SPARC by William Lott.
+;;;
+(in-package "SB!VM")
+
+
+\f
+;;;; 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))
+
+
+\f
+;;;; 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)))
+
+\f
+;;; 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 :lt :ge))
+
+(define-vop (fast-char>/base-char base-char-compare)
+ (:translate char>)
+ (:variant :gt :le))
+
--- /dev/null
+;;;
+;;; 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)))
--- /dev/null
+2;;;
+;;; Written by Rob MacLachlan
+;;; Sparc conversion by William Lott.
+;;;
+(in-package "SB!VM")
+
+\f
+;;;; 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)))
+
+
+\f
+;;;; 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))
+
+
+\f
+;;;; 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))
+
+\f
+;;;; 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))
+
+\f
+;;;; 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 </single-float </double-float)
+ (frob > :gt :le >/single-float >/double-float)
+ (frob = :eq :ne eql/single-float eql/double-float))
+
+\f
+;;;; 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))))))))
+
+\f
+;;;; 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))))
+
+\f
+;;;; 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))
+
+\f
--- /dev/null
+;;;
+;;; 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)
+
+
+\f
+;;;; 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)))))
+
+
+\f
+;;;; 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)
+
+
+\f
+;;; 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))
+
+\f
+;;;;
+
+(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))
+
+\f
+;;;;
+
+(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)
+
+\f
+;;;
+
+(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)
+
+\f
+;;;
+
+(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)
+\f
+
+(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)))
+
+
+
+\f
+;;;; 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))
+
+
+\f
+
+(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)))
+
+
+
+\f
+;;; 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))
+
+
+
+|#
+
+
+
+
+\f
+;;; 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))
+
+
+\f
+;;;; 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)))
+
+\f
+;;;; 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))))))
--- /dev/null
+;;;
+
+(in-package "SB!VM")
+
+\f
+;;; 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)))
+
+
+\f
+;;;; 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))))))))
+
+\f
+;;;; 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)))
+
+\f
+;;;; 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)))))
+
+\f
+;;;; 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)))))
+
+
+\f
+;;; 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)))))
+
+
+
--- /dev/null
+;;; 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)))
+
+
+\f
+;;;; 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)
+
--- /dev/null
+;;; 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))))
+
+\f
+;;;; 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))
+
+
+\f
+;;;; 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)))
+
+
+\f
+;;;; 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))
--- /dev/null
+;;; 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))
+
+\f
+;;; 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)))
+
+
+\f
+;;;; 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*)))
+
+\f
+;;;; 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)))
+
--- /dev/null
+;;;; 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))
+
+\f
+
+
+;;; 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)
+
+
+
+\f
+;;;; 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)
+
+\f
+;;;; 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))
+
+\f
+;;;; Assembler parameters:
+
+;;; The number of bits per element in the assemblers code vector.
+;;;
+(defparameter *assembly-unit-length* 8)
--- /dev/null
+;;;
+;;; Converted by William Lott.
+;;;
+
+(in-package "SB!VM")
+
+\f
+;;;; 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)))
+
+\f
+;;;; 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)))
--- /dev/null
+;;; 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))))
--- /dev/null
+;;;
+;;; Written by William Lott.
+;;;
+(in-package "SB!VM")
+
+\f
+;;;; 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))
+
+
+\f
+;;;; 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)))
+
+
+\f
+;;;; 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)))
+
+
+\f
+;;;; 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))
+
+
+\f
+;;; 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))))
+
+\f
+;;; 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
--- /dev/null
+;;; 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))))
--- /dev/null
+;;; 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)))))
--- /dev/null
+;;;
+;;; Written by William Lott.
+;;;
+(in-package "SB!VM")
+
+
+\f
+;;;; 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)
+
--- /dev/null
+;;;
+;;; Written by Rob MacLachlan
+;;;
+;;; Mips conversion by William Lott and Christopher Hoover.
+;;;
+(in-package "SB!VM")
+
+
+\f
+;;;; 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)))))
+
+\f
+;;;; 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)))
+
+\f
+;;;; 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)))
+
+
+\f
+;;;; 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)))
+
+
+\f
+;;;; 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))))
--- /dev/null
+(in-package "SB!VM")
+
+;;; Let's see if an empty file works here. It does on the Alpha.
--- /dev/null
+(in-package "SB!VM")
+
+\f
+;;;; 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))
+
+\f
+;;;; 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))))
+
+
+
+\f
+;;;; 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))))
+
--- /dev/null
+;;;
+;;; 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))
--- /dev/null
+;;;
+(in-package "SB!VM")
+
+\f
+;;;; 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)))
+
+
+\f
+;;;; 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))
+
+
+\f
+;;;; 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))
+
+
+\f
+;;; 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))))
+
+\f
+;;;; 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)
+
+\f
+;;; 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"))))
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
*
* -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);
#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
.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 ; \
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
;;; 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"
projects / sbcl.git / commitdiff