is no longer a static symbol.)
changes in sbcl-0.7.7 relative to sbcl-0.7.6:
+ * An alpha-quality port to the parisc architecture running Linux,
+ based on the old CMUCL backend has been made. This, even more so
+ than the other backends, should be considered still a work in
+ progress.
* fixed bug 189: The compiler now respects NOTINLINE declarations for
functions declared in FLET and LABELS. (I.e. "LET conversion" is
suppressed.) Also now that the compiler is looking at declarations
sparc*) guessed_sbcl_arch=sparc ;;
sun*) guessed_sbcl_arch=sparc ;;
ppc) guessed_sbcl_arch=ppc ;;
+ parisc) guessed_sbcl_arch=hppa ;;
*)
# If we're not building on a supported target architecture, we
# we have no guess, but it's not an error yet, since maybe
--- /dev/null
+(in-package "SB!VM")
+
+;;; Given that the pseudo-atomic sequence is so short, there is
+;;; nothing that qualifies. But we want to keep the file around
+;;; in case we decide to add something later.
+
--- /dev/null
+(in-package "SB!VM")
+
+\f
+;;;; Multiplication and Division helping routines.
+
+;;; ?? FIXME: Where are generic-* and generic-/?
+#+sb-assembling
+(define-assembly-routine
+ multiply
+ ((:arg x (signed-reg) nl0-offset)
+ (:arg y (signed-reg) nl1-offset)
+
+ (:res res (signed-reg) nl2-offset)
+
+ (:temp tmp (unsigned-reg) nl3-offset)
+ (:temp sign (unsigned-reg) nl4-offset))
+
+ ;; Determine the sign of the result.
+ (inst extrs x 0 1 sign :=)
+ (inst sub zero-tn x x)
+ (inst extrs y 0 1 tmp :=)
+ (inst sub zero-tn y y)
+ (inst xor sign tmp sign)
+
+ ;; Make sure X is less then Y.
+ (inst comclr x y tmp :<<)
+ (inst xor x y tmp)
+ (inst xor x tmp x)
+ (inst xor y tmp y)
+ ;; Blow out of here if the result is zero.
+ (inst comb := x zero-tn done)
+ (inst li 0 res)
+
+ LOOP
+ (inst extru x 31 1 zero-tn :ev)
+ (inst add y res res)
+ (inst extru x 30 1 zero-tn :ev)
+ (inst sh1add y res res)
+ (inst extru x 29 1 zero-tn :ev)
+ (inst sh2add y res res)
+ (inst extru x 28 1 zero-tn :ev)
+ (inst sh3add y res res)
+
+ (inst srl x 4 x)
+ (inst comb :<> x zero-tn loop)
+ (inst sll y 4 y)
+
+ DONE
+ (inst xor res sign res)
+ (inst add res sign res))
+
+
+#+sb-assembling
+(define-assembly-routine
+ (truncate)
+ ((:arg dividend signed-reg nl0-offset)
+ (:arg divisor signed-reg nl1-offset)
+
+ (:res quo signed-reg nl2-offset)
+ (:res rem signed-reg nl3-offset))
+
+ ;; Move abs(divident) into quo.
+ (inst move dividend quo :>=)
+ (inst sub zero-tn quo quo)
+ ;; Do one divive-step with -divisor to prime V (use rem as a temp)
+ (inst sub zero-tn divisor rem)
+ (inst ds zero-tn rem zero-tn)
+ ;; Shift the divident/quotient one bit, setting the carry flag.
+ (inst add quo quo quo)
+ ;; The first real divive-step.
+ (inst ds zero-tn divisor rem)
+ (inst addc quo quo quo)
+ ;; And 31 more of them.
+ (dotimes (i 31)
+ (inst ds rem divisor rem)
+ (inst addc quo quo quo))
+ ;; If the remainder is negative, we need to add the absolute value of the
+ ;; divisor.
+ (inst comb :>= rem zero-tn remainder-positive)
+ (inst comclr divisor zero-tn zero-tn :<)
+ (inst add rem divisor rem :tr)
+ (inst sub rem divisor rem)
+ REMAINDER-POSITIVE
+ ;; Now we have to fix the signs of quo and rem.
+ (inst xor divisor dividend zero-tn :>=)
+ (inst sub zero-tn quo quo)
+ (inst move dividend zero-tn :>=)
+ (inst sub zero-tn rem rem))
+
+
+\f
+;;;; Generic arithmetic.
+
+(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 lip interior-reg lip-offset)
+ (:temp lra descriptor-reg lra-offset)
+ (:temp nargs any-reg nargs-offset)
+ (:temp ocfp any-reg ocfp-offset))
+ (inst extru x 31 2 zero-tn :=)
+ (inst b do-static-fun :nullify t)
+ (inst extru y 31 2 zero-tn :=)
+ (inst b do-static-fun :nullify t)
+ (inst addo x y res)
+ (lisp-return lra :offset 1)
+
+ DO-STATIC-FUN
+ (inst ldw (static-fun-offset 'two-arg-+) null-tn lip)
+ (inst li (fixnumize 2) nargs)
+ (inst move cfp-tn ocfp)
+ (inst bv lip)
+ (inst move csp-tn cfp-tn))
+
+(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 lip interior-reg lip-offset)
+ (:temp lra descriptor-reg lra-offset)
+ (:temp nargs any-reg nargs-offset)
+ (:temp ocfp any-reg ocfp-offset))
+ (inst extru x 31 2 zero-tn :=)
+ (inst b do-static-fun :nullify t)
+ (inst extru y 31 2 zero-tn :=)
+ (inst b do-static-fun :nullify t)
+ (inst subo x y res)
+ (lisp-return lra :offset 1)
+
+ DO-STATIC-FUN
+ (inst ldw (static-fun-offset 'two-arg--) null-tn lip)
+ (inst li (fixnumize 2) nargs)
+ (inst move cfp-tn ocfp)
+ (inst bv lip)
+ (inst move csp-tn cfp-tn))
+
+
+\f
+;;;; Comparison routines.
+
+(macrolet
+ ((define-cond-assem-rtn (name translate static-fn cond)
+ `(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 lra descriptor-reg lra-offset)
+ (:temp nargs any-reg nargs-offset)
+ (:temp ocfp any-reg ocfp-offset))
+ (inst extru x 31 2 zero-tn :=)
+ (inst b do-static-fn :nullify t)
+ (inst extru y 31 2 zero-tn :=)
+ (inst b do-static-fn :nullify t)
+
+ (inst comclr x y zero-tn ,cond)
+ (inst move null-tn res :tr)
+ (load-symbol res t)
+ (lisp-return lra :offset 1)
+
+ DO-STATIC-FN
+ (inst ldw (static-fun-offset ',static-fn) null-tn lip)
+ (inst li (fixnumize 2) nargs)
+ (inst move cfp-tn ocfp)
+ (inst bv lip)
+ (inst move csp-tn cfp-tn))))
+
+ (define-cond-assem-rtn generic-< < two-arg-< :<)
+ (define-cond-assem-rtn generic-> > two-arg-> :>))
+
+
+(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 lip interior-reg lip-offset)
+ (:temp lra descriptor-reg lra-offset)
+ (:temp nargs any-reg nargs-offset)
+ (:temp ocfp any-reg ocfp-offset))
+
+ (inst comb := x y return-t :nullify t)
+ (inst extru x 31 2 zero-tn :<>)
+ (inst b return-nil :nullify t)
+ (inst extru y 31 2 zero-tn :=)
+ (inst b do-static-fn :nullify t)
+
+ RETURN-NIL
+ (inst move null-tn res)
+ (lisp-return lra :offset 1)
+
+ DO-STATIC-FN
+ (inst ldw (static-fun-offset 'eql) null-tn lip)
+ (inst li (fixnumize 2) nargs)
+ (inst move cfp-tn ocfp)
+ (inst bv lip)
+ (inst move csp-tn cfp-tn)
+
+ 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 comb := x y return-t :nullify t)
+ (inst extru x 31 2 zero-tn :=)
+ (inst b do-static-fn :nullify t)
+ (inst extru y 31 2 zero-tn :=)
+ (inst b do-static-fn :nullify t)
+
+ (inst move null-tn res)
+ (lisp-return lra :offset 1)
+
+ DO-STATIC-FN
+ (inst ldw (static-fun-offset 'two-arg-=) null-tn lip)
+ (inst li (fixnumize 2) nargs)
+ (inst move cfp-tn ocfp)
+ (inst bv lip)
+ (inst move csp-tn cfp-tn)
+
+ RETURN-T
+ (load-symbol res t))
--- /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 vector descriptor-reg a3-offset))
+ (pseudo-atomic ()
+ (move alloc-tn vector)
+ (inst dep other-pointer-lowtag 31 3 vector)
+ (inst addi (* (1+ vector-data-offset) n-word-bytes) words ndescr)
+ (inst dep 0 31 3 ndescr)
+ (inst add ndescr alloc-tn alloc-tn)
+ (inst srl type word-shift ndescr)
+ (storew ndescr vector 0 other-pointer-lowtag)
+ (storew length vector vector-length-slot other-pointer-lowtag))
+ (move vector result))
+
+
+\f
+;;;; Hash primitives
+
+;;; FIXME: This looks kludgy bad and wrong.
+#+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 offset non-descriptor-reg nl2-offset))
+
+ (declare (ignore result accum data offset))
+
+ ;; Save the return address.
+ (inst b *sxhash-simple-substring-entry*)
+ (loadw length string vector-length-slot other-pointer-lowtag))
+
+(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 offset non-descriptor-reg nl2-offset))
+
+ (emit-label *sxhash-simple-substring-entry*)
+
+ (inst li (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) offset)
+ (inst b test)
+ (move zero-tn accum)
+
+ LOOP
+ (inst xor accum data accum)
+ (inst shd accum accum 5 accum)
+
+ TEST
+ (inst ldwx offset string data)
+ (inst addib :>= (fixnumize -4) length loop)
+ (inst addi (fixnumize 1) offset offset)
+
+ (inst addi (fixnumize 4) length length)
+ (inst comb := zero-tn length done :nullify t)
+ (inst sub zero-tn length length)
+ (inst sll length 1 length)
+ (inst mtctl length :sar)
+ (inst shd zero-tn data :variable data)
+ (inst xor accum data accum)
+
+ DONE
+
+ (inst sll accum 5 result)
+ (inst srl result 3 result))
--- /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 old-fp any-reg nl1-offset)
+ (:temp lra descriptor-reg lra-offset)
+
+ ;; These are just needed to facilitate the transfer
+ (:temp count any-reg nl2-offset)
+ (:temp src any-reg nl3-offset)
+ (:temp dst any-reg nl4-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)
+ (:temp a4 descriptor-reg a4-offset)
+ (:temp a5 descriptor-reg a5-offset))
+
+ (inst movb := nvals count default-a0-and-on :nullify t)
+ (loadw a0 vals 0)
+ (inst addib := (fixnumize -1) count default-a1-and-on :nullify t)
+ (loadw a1 vals 1)
+ (inst addib := (fixnumize -1) count default-a2-and-on :nullify t)
+ (loadw a2 vals 2)
+ (inst addib := (fixnumize -1) count default-a3-and-on :nullify t)
+ (loadw a3 vals 3)
+ (inst addib := (fixnumize -1) count default-a4-and-on :nullify t)
+ (loadw a4 vals 4)
+ (inst addib := (fixnumize -1) count default-a5-and-on :nullify t)
+ (loadw a5 vals 5)
+ (inst addib := (fixnumize -1) count done :nullify t)
+
+ ;; Copy the remaining args to the top of the stack.
+ (inst addi (* 6 n-word-bytes) vals src)
+ (inst addi (* 6 n-word-bytes) cfp-tn dst)
+
+ LOOP
+ (inst ldwm 4 src temp)
+ (inst addib :> (fixnumize -1) count loop)
+ (inst stwm temp 4 dst)
+
+ (inst b done :nullify t)
+
+ DEFAULT-A0-AND-ON
+ (inst move null-tn a0)
+ DEFAULT-A1-AND-ON
+ (inst move null-tn a1)
+ DEFAULT-A2-AND-ON
+ (inst move null-tn a2)
+ DEFAULT-A3-AND-ON
+ (inst move null-tn a3)
+ DEFAULT-A4-AND-ON
+ (inst move null-tn a4)
+ DEFAULT-A5-AND-ON
+ (inst move null-tn a5)
+
+ DONE
+ ;; Clear the stack.
+ (move cfp-tn ocfp-tn)
+ (move old-fp cfp-tn)
+ (inst add ocfp-tn nvals csp-tn)
+
+ ;; Return.
+ (lisp-return lra))
+
+
+\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)
+
+ ;; 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)
+ (:temp a4 descriptor-reg a4-offset)
+ (:temp a5 descriptor-reg a5-offset))
+
+
+ ;; Calculate NARGS (as a fixnum)
+ (inst sub csp-tn args nargs)
+
+ ;; Load the argument regs (must do this now, 'cause the blt might
+ ;; trash these locations)
+ (loadw a0 args 0)
+ (loadw a1 args 1)
+ (loadw a2 args 2)
+ (loadw a3 args 3)
+ (loadw a4 args 4)
+ (loadw a5 args 5)
+
+ ;; Calc SRC, DST, and COUNT
+ (inst addi (fixnumize (- register-arg-count)) nargs count)
+ (inst comb :<= count zero-tn done :nullify t)
+ (inst addi (* n-word-bytes register-arg-count) args src)
+ (inst addi (* n-word-bytes register-arg-count) cfp-tn dst)
+
+ LOOP
+ ;; Copy one arg.
+ (inst ldwm 4 src temp)
+ (inst addib :> (fixnumize -1) count loop)
+ (inst stwm temp 4 dst)
+
+ DONE
+ ;; We are done. Do the jump.
+ (loadw temp lexenv closure-fun-slot fun-pointer-lowtag)
+ (lisp-jump temp))
+
+
+\f
+;;;; Non-local exit noise.
+
+;;; FIXME: Really?
+#+sb-assembling
+(defparameter *unwind-entry-point* (gen-label))
+
+(define-assembly-routine
+ (unwind
+ (: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 cur-uwp any-reg nl0-offset)
+ (:temp next-uwp any-reg nl1-offset)
+ (:temp target-uwp any-reg nl2-offset))
+ (declare (ignore start count))
+
+ (emit-label *unwind-entry-point*)
+
+ (let ((error (generate-error-code nil invalid-unwind-error)))
+ (inst bc := nil block zero-tn error))
+
+ (load-symbol-value cur-uwp *current-unwind-protect-block*)
+ (loadw target-uwp block unwind-block-current-uwp-slot)
+ (inst bc :<> nil cur-uwp target-uwp do-uwp)
+
+ (move block cur-uwp)
+
+ 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 :frob-code nil)
+
+ DO-UWP
+
+ (loadw next-uwp cur-uwp unwind-block-current-uwp-slot)
+ (inst b do-exit)
+ (store-symbol-value next-uwp *current-unwind-protect-block*))
+
+
+(define-assembly-routine
+ throw
+ ((: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)) ; We just need them in the registers.
+
+ (load-symbol-value catch *current-catch-block*)
+
+ LOOP
+ (let ((error (generate-error-code nil unseen-throw-tag-error target)))
+ (inst bc := nil catch zero-tn error))
+ (loadw tag catch catch-block-tag-slot)
+ (inst comb :<> tag target loop :nullify t)
+ (loadw catch catch catch-block-previous-catch-slot)
+
+ (inst b *unwind-entry-point*)
+ (inst move catch target))
--- /dev/null
+(in-package "SB!VM")
+
+
+(!def-vm-support-routine generate-call-sequence (name style vop)
+ (ecase style
+ (:raw
+ (let ((fixup (gensym "FIXUP-")))
+ (values
+ `((let ((fixup (make-fixup ',name :assembly-routine)))
+ (inst ldil fixup ,fixup)
+ (inst ble fixup lisp-heap-space ,fixup :nullify t))
+ (inst nop))
+ `((:temporary (:scs (any-reg) :from (:eval 0) :to (:eval 1))
+ ,fixup)))))
+ (: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 code-tn lra-label ,temp ,lra)
+ (note-this-location ,vop :call-site)
+ (let ((fixup (make-fixup ',name :assembly-routine)))
+ (inst ldil fixup ,temp)
+ (inst be fixup lisp-heap-space ,temp :nullify t))
+ (emit-return-pc lra-label)
+ (note-this-location ,vop :single-value-return)
+ (move ocfp-tn csp-tn)
+ (inst compute-code-from-lra code-tn lra-label ,temp code-tn)
+ (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
+ (let ((fixup (gensym "FIXUP-")))
+ (values
+ `((let ((fixup (make-fixup ',name :assembly-routine)))
+ (inst ldil fixup ,fixup)
+ (inst be fixup lisp-heap-space ,fixup :nullify t)))
+ `((:temporary (:scs (any-reg) :from (:eval 0) :to (:eval 1))
+ ,fixup)))))))
+
+
+(!def-vm-support-routine generate-return-sequence (style)
+ (ecase style
+ (:raw
+ `((inst bv lip-tn :nullify t)))
+ (:full-call
+ `((lisp-return (make-random-tn :kind :normal
+ :sc (sc-or-lose 'descriptor-reg)
+ :offset lra-offset)
+ :offset 1)))
+ (:none)))
--- /dev/null
+(in-package "SB!VM")
+\f
+(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."
+ "HPPA")
+
+(defun machine-version ()
+ "Returns a string describing the version of the local machine."
+ "HPPA")
+
+\f
+;;; FIXUP-CODE-OBJECT -- Interface
+;;;
+(defun fixup-code-object (code offset value kind)
+ (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)))
+ (inst (sap-ref-32 sap offset)))
+ (setf (sap-ref-32 sap offset)
+ (ecase kind
+ (:load
+ (logior (ash (ldb (byte 11 0) value) 1)
+ (logand inst #xffffc000)))
+ (:load-short
+ (let ((low-bits (ldb (byte 11 0) value)))
+ (assert (<= 0 low-bits (1- (ash 1 4))))
+ (logior (ash low-bits 17)
+ (logand inst #xffe0ffff))))
+ (:hi
+ (logior (ash (ldb (byte 5 13) value) 16)
+ (ash (ldb (byte 2 18) value) 14)
+ (ash (ldb (byte 2 11) value) 12)
+ (ash (ldb (byte 11 20) value) 1)
+ (ldb (byte 1 31) value)
+ (logand inst #xffe00000)))
+ (:branch
+ (let ((bits (ldb (byte 9 2) value)))
+ (assert (zerop (ldb (byte 2 0) value)))
+ (logior (ash bits 3)
+ (logand inst #xffe0e002)))))))))
+\f
+(define-alien-routine ("os_context_pc_addr" context-pc-addr) (* unsigned-int)
+ (context (* os-context-t)))
+
+(defun context-pc (context)
+ (declare (type (alien (* os-context-t)) context))
+ (int-sap (logandc2 (deref (context-pc-addr context)) 3)))
+
+(define-alien-routine ("os_context_register_addr" context-register-addr)
+ (* unsigned-int)
+ (context (* os-context-t))
+ (index int))
+
+;;; FIXME: Should this and CONTEXT-PC be INLINE to reduce consing?
+;;; (Are they used in anything time-critical, or just the debugger?)
+(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))
+
+#!+linux
+;;; For now.
+(defun context-floating-point-modes (context)
+ (warn "stub CONTEXT-FLOATING-POINT-MODES")
+ 0)
+
+;;;; Internal-error-arguments.
+
+;;; INTERNAL-ERROR-ARGUMENTS -- 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)))
+ (declare (type system-area-pointer pc))
+ (let* ((length (sap-ref-8 pc 4))
+ (vector (make-array length :element-type '(unsigned-byte 8))))
+ (declare (type (unsigned-byte 8) length)
+ (type (simple-array (unsigned-byte 8) (*)) vector))
+ (copy-from-system-area pc (* n-byte-bits 5)
+ vector (* n-word-bits
+ vector-data-offset)
+ (* length 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)))))))
(type disassem-state dstate)
(optimize (speed 3) (safety 0)))
(sign-extend (read-suffix length dstate) length))
+\f
+;;; All state during disassembly. We store some seemingly redundant
+;;; information so that we can allow garbage collect during disassembly and
+;;; not get tripped up by a code block being moved...
+(defstruct (disassem-state (:conc-name dstate-)
+ (:constructor %make-dstate)
+ (:copier nil))
+ ;; offset of current pos in segment
+ (cur-offs 0 :type offset)
+ ;; offset of next position
+ (next-offs 0 :type offset)
+ ;; a sap pointing to our segment
+ (segment-sap (missing-arg) :type sb!sys:system-area-pointer)
+ ;; the current segment
+ (segment nil :type (or null segment))
+ ;; what to align to in most cases
+ (alignment sb!vm:n-word-bytes :type alignment)
+ (byte-order :little-endian
+ :type (member :big-endian :little-endian))
+ ;; for user code to hang stuff off of
+ (properties nil :type list)
+ (filtered-values (make-array max-filtered-value-index)
+ :type filtered-value-vector)
+ ;; used for prettifying printing
+ (addr-print-len nil :type (or null (integer 0 20)))
+ (argument-column 0 :type column)
+ ;; to make output look nicer
+ (output-state :beginning
+ :type (member :beginning
+ :block-boundary
+ nil))
+
+ ;; alist of (address . label-number)
+ (labels nil :type list)
+ ;; same as LABELS slot data, but in a different form
+ (label-hash (make-hash-table) :type hash-table)
+ ;; list of function
+ (fun-hooks nil :type list)
+
+ ;; alist of (address . label-number), popped as it's used
+ (cur-labels nil :type list)
+ ;; OFFS-HOOKs, popped as they're used
+ (cur-offs-hooks nil :type list)
+
+ ;; for the current location
+ (notes nil :type list)
+
+ ;; currently active source variables
+ (current-valid-locations nil :type (or null (vector bit))))
+(def!method print-object ((dstate disassem-state) stream)
+ (print-unreadable-object (dstate stream :type t)
+ (format stream
+ "+~W~@[ in ~S~]"
+ (dstate-cur-offs dstate)
+ (dstate-segment dstate))))
+
+;;; Return the absolute address of the current instruction in DSTATE.
+(defun dstate-cur-addr (dstate)
+ (the address (+ (seg-virtual-location (dstate-segment dstate))
+ (dstate-cur-offs dstate))))
+
+;;; Return the absolute address of the next instruction in DSTATE.
+(defun dstate-next-addr (dstate)
+ (the address (+ (seg-virtual-location (dstate-segment dstate))
+ (dstate-next-offs dstate))))
;;; Get the value of the property called NAME in DSTATE. Also SETF'able.
;;;
(descriptor-gspace code-object))))
(ecase +backend-fasl-file-implementation+
;; See CMU CL source for other formerly-supported architectures
- ;; (and note that you have to rewrite them to use VECTOR-REF
- ;; unstead of SAP-REF).
+ ;; (and note that you have to rewrite them to use BVREF-X
+ ;; instead of SAP-REF).
(:alpha
(ecase kind
(:jmp-hint
(ldb (byte 8 0) value)
(bvref-8 gspace-bytes (1+ gspace-byte-offset))
(ldb (byte 8 8) value)))))
+ (:hppa
+ (ecase kind
+ (:load
+ (setf (bvref-32 gspace-bytes gspace-byte-offset)
+ (logior (ash (ldb (byte 11 0) value) 1)
+ (logand (bvref-32 gspace-bytes gspace-byte-offset)
+ #xffffc000))))
+ (:load-short
+ (let ((low-bits (ldb (byte 11 0) value)))
+ (assert (<= 0 low-bits (1- (ash 1 4))))
+ (setf (bvref-32 gspace-bytes gspace-byte-offset)
+ (logior (ash low-bits 17)
+ (logand (bvref-32 gspace-bytes gspace-byte-offset)
+ #xffe0ffff)))))
+ (:hi
+ (setf (bvref-32 gspace-bytes gspace-byte-offset)
+ (logior (ash (ldb (byte 5 13) value) 16)
+ (ash (ldb (byte 2 18) value) 14)
+ (ash (ldb (byte 2 11) value) 12)
+ (ash (ldb (byte 11 20) value) 1)
+ (ldb (byte 1 31) value)
+ (logand (bvref-32 gspace-bytes gspace-byte-offset)
+ #xffe00000))))
+ (:branch
+ (let ((bits (ldb (byte 9 2) value)))
+ (assert (zerop (ldb (byte 2 0) value)))
+ (setf (bvref-32 gspace-bytes gspace-byte-offset)
+ (logior (ash bits 3)
+ (logand (bvref-32 gspace-bytes gspace-byte-offset)
+ #xffe0e002)))))))
(:ppc
(ecase kind
(:ba
--- /dev/null
+(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)
+ (:info num)
+ (:results (result :scs (descriptor-reg)))
+ (:variant-vars star)
+ (:policy :safe)
+ (:generator 0
+ (cond
+ ((zerop num)
+ (move null-tn result))
+ ((and star (= num 1))
+ (move (tn-ref-tn things) result))
+ (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 (:extra alloc)
+ (move alloc-tn res)
+ (inst dep list-pointer-lowtag 31 3 res)
+ (move res ptr)
+ (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 (pad-data-block cons-size) ptr ptr)
+ (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 res result)))))))
+
+
+(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)
+ (:generator 100
+ (inst addi (fixnumize (1+ code-trace-table-offset-slot)) boxed-arg boxed)
+ (inst dep 0 31 3 boxed)
+ (inst srl unboxed-arg word-shift unboxed)
+ (inst addi lowtag-mask unboxed unboxed)
+ (inst dep 0 31 3 unboxed)
+ (pseudo-atomic ()
+ ;; Note: we don't have to subtract off the 4 that was added by
+ ;; pseudo-atomic, because depositing other-pointer-lowtag just adds
+ ;; it right back.
+ (inst move alloc-tn result)
+ (inst dep other-pointer-lowtag 31 3 result)
+ (inst add alloc-tn boxed alloc-tn)
+ (inst add alloc-tn unboxed alloc-tn)
+ (inst sll boxed (- n-widetag-bits word-shift) ndescr)
+ (inst addi code-header-widetag ndescr ndescr)
+ (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)
+ (:results (result :scs (descriptor-reg) :from :argument))
+ (:policy :fast-safe)
+ (:translate make-fdefn)
+ (:generator 37
+ (with-fixed-allocation (result temp fdefn-widetag fdefn-size)
+ (inst li (make-fixup "undefined_tramp" :foreign) temp)
+ (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)
+ (:results (result :scs (descriptor-reg)))
+ (:generator 10
+ (let ((size (+ length closure-info-offset)))
+ (pseudo-atomic (:extra (pad-data-block size))
+ (inst move alloc-tn result)
+ (inst dep fun-pointer-lowtag 31 3 result)
+ (inst li (logior (ash (1- size) n-widetag-bits) closure-header-widetag) temp)
+ (storew temp result 0 fun-pointer-lowtag)))
+ (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)
+ (:results (result :scs (descriptor-reg)))
+ (:generator 10
+ (with-fixed-allocation
+ (result 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 unbound-marker-widetag result)))
+
+(define-vop (fixed-alloc)
+ (:args)
+ (:info name words type lowtag)
+ (:ignore name)
+ (:results (result :scs (descriptor-reg)))
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:generator 4
+ (pseudo-atomic (:extra (pad-data-block words))
+ (inst move alloc-tn result)
+ (inst dep lowtag 31 3 result)
+ (when type
+ (inst li (logior (ash (1- words) n-widetag-bits) type) temp)
+ (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)
+ (:generator 6
+ (inst addi (* (1+ words) n-word-bytes) extra bytes)
+ (inst sll bytes (- n-widetag-bits 2) header)
+ (inst addi (+ (ash -2 n-widetag-bits) type) header header)
+ (inst dep 0 31 3 bytes)
+ (pseudo-atomic ()
+ (inst move alloc-tn result)
+ (inst dep lowtag 31 3 result)
+ (storew header result 0 lowtag)
+ (inst add alloc-tn bytes alloc-tn))))
--- /dev/null
+(in-package "SB!VM")
+
+
+\f
+;;;; Unary operations.
+
+(define-vop (fixnum-unop)
+ (:args (x :scs (any-reg)))
+ (:results (res :scs (any-reg)))
+ (:note "inline fixnum arithmetic")
+ (:arg-types tagged-num)
+ (:result-types tagged-num)
+ (:policy :fast-safe))
+
+(define-vop (signed-unop)
+ (:args (x :scs (signed-reg)))
+ (:results (res :scs (signed-reg)))
+ (:note "inline (signed-byte 32) arithmetic")
+ (:arg-types signed-num)
+ (:result-types signed-num)
+ (:policy :fast-safe))
+
+(define-vop (fast-negate/fixnum fixnum-unop)
+ (:translate %negate)
+ (:generator 1
+ (inst sub zero-tn x res)))
+
+(define-vop (fast-negate/signed signed-unop)
+ (:translate %negate)
+ (:generator 2
+ (inst sub zero-tn x res)))
+
+(define-vop (fast-lognot/fixnum fixnum-unop)
+ (:temporary (:scs (any-reg) :type fixnum :to (:result 0))
+ temp)
+ (:translate lognot)
+ (:generator 2
+ (inst li (fixnumize -1) temp)
+ (inst xor x temp res)))
+
+(define-vop (fast-lognot/signed signed-unop)
+ (:translate lognot)
+ (:generator 1
+ (inst uaddcm zero-tn x res)))
+
+
+\f
+;;;; Binary fixnum operations.
+
+;;; Assume that any constant operand is the second arg...
+
+(define-vop (fast-fixnum-binop)
+ (:args (x :target r :scs (any-reg))
+ (y :target r :scs (any-reg)))
+ (:arg-types tagged-num tagged-num)
+ (:results (r :scs (any-reg)))
+ (:result-types tagged-num)
+ (:note "inline fixnum arithmetic")
+ (:effects)
+ (:affected)
+ (:policy :fast-safe))
+
+(define-vop (fast-unsigned-binop)
+ (:args (x :target r :scs (unsigned-reg))
+ (y :target r :scs (unsigned-reg)))
+ (:arg-types unsigned-num unsigned-num)
+ (:results (r :scs (unsigned-reg)))
+ (:result-types unsigned-num)
+ (:note "inline (unsigned-byte 32) arithmetic")
+ (:effects)
+ (:affected)
+ (:policy :fast-safe))
+
+(define-vop (fast-signed-binop)
+ (:args (x :target r :scs (signed-reg))
+ (y :target r :scs (signed-reg)))
+ (:arg-types signed-num signed-num)
+ (:results (r :scs (signed-reg)))
+ (:result-types signed-num)
+ (:note "inline (signed-byte 32) arithmetic")
+ (:effects)
+ (:affected)
+ (:policy :fast-safe))
+
+(defmacro define-binop (translate cost untagged-cost op)
+ `(progn
+ (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
+ fast-fixnum-binop)
+ (:args (x :target r :scs (any-reg))
+ (y :target r :scs (any-reg)))
+ (:translate ,translate)
+ (:generator ,cost
+ (inst ,op x y r)))
+ (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
+ fast-signed-binop)
+ (:args (x :target r :scs (signed-reg))
+ (y :target r :scs (signed-reg)))
+ (:translate ,translate)
+ (:generator ,untagged-cost
+ (inst ,op x y r)))
+ (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED")
+ fast-unsigned-binop)
+ (:args (x :target r :scs (unsigned-reg))
+ (y :target r :scs (unsigned-reg)))
+ (:translate ,translate)
+ (:generator ,untagged-cost
+ (inst ,op x y r)))))
+
+(define-binop + 2 6 add)
+(define-binop - 2 6 sub)
+(define-binop logior 1 2 or)
+(define-binop logand 1 2 and)
+(define-binop logandc2 1 2 andcm)
+(define-binop logxor 1 2 xor)
+
+(define-vop (fast-fixnum-c-binop fast-fixnum-binop)
+ (:args (x :target r :scs (any-reg)))
+ (:info y)
+ (:arg-types tagged-num (:constant integer)))
+
+(define-vop (fast-signed-c-binop fast-signed-binop)
+ (:args (x :target r :scs (signed-reg)))
+ (:info y)
+ (:arg-types tagged-num (:constant integer)))
+
+(define-vop (fast-unsigned-c-binop fast-unsigned-binop)
+ (:args (x :target r :scs (unsigned-reg)))
+ (:info y)
+ (:arg-types tagged-num (:constant integer)))
+
+(defmacro define-c-binop (translate cost untagged-cost tagged-type
+ untagged-type inst)
+ `(progn
+ (define-vop (,(symbolicate "FAST-" translate "-C/FIXNUM=>FIXNUM")
+ fast-fixnum-c-binop)
+ (:arg-types tagged-num (:constant ,tagged-type))
+ (:translate ,translate)
+ (:generator ,cost
+ (let ((y (fixnumize y)))
+ ,inst)))
+ (define-vop (,(symbolicate "FAST-" translate "-C/SIGNED=>SIGNED")
+ fast-signed-c-binop)
+ (:arg-types signed-num (:constant ,untagged-type))
+ (:translate ,translate)
+ (:generator ,untagged-cost
+ ,inst))
+ (define-vop (,(symbolicate "FAST-" translate "-C/UNSIGNED=>UNSIGNED")
+ fast-unsigned-c-binop)
+ (:arg-types unsigned-num (:constant ,untagged-type))
+ (:translate ,translate)
+ (:generator ,untagged-cost
+ ,inst))))
+
+(define-c-binop + 1 3 (signed-byte 9) (signed-byte 11)
+ (inst addi y x r))
+(define-c-binop - 1 3
+ (integer #.(- (1- (ash 1 9))) #.(ash 1 9))
+ (integer #.(- (1- (ash 1 11))) #.(ash 1 11))
+ (inst addi (- y) x r))
+
+;;; Special case fixnum + and - that trap on overflow. Useful when we don't
+;;; know that the result is going to be a fixnum.
+
+(define-vop (fast-+/fixnum fast-+/fixnum=>fixnum)
+ (:results (r :scs (any-reg descriptor-reg)))
+ (:result-types (:or signed-num unsigned-num))
+ (:note nil)
+ (:generator 4
+ (inst addo x y r)))
+
+(define-vop (fast-+-c/fixnum fast-+-c/fixnum=>fixnum)
+ (:results (r :scs (any-reg descriptor-reg)))
+ (:result-types (:or signed-num unsigned-num))
+ (:note nil)
+ (:generator 3
+ (inst addio (fixnumize y) x r)))
+
+(define-vop (fast--/fixnum fast--/fixnum=>fixnum)
+ (:results (r :scs (any-reg descriptor-reg)))
+ (:result-types (:or signed-num unsigned-num))
+ (:note nil)
+ (:generator 4
+ (inst subo x y r)))
+
+(define-vop (fast---c/fixnum fast---c/fixnum=>fixnum)
+ (:results (r :scs (any-reg descriptor-reg)))
+ (:result-types (:or signed-num unsigned-num))
+ (:note nil)
+ (:generator 3
+ (inst addio (- (fixnumize y)) x r)))
+
+;;; Shifting
+
+(define-vop (fast-ash/unsigned=>unsigned)
+ (:policy :fast-safe)
+ (:translate ash)
+ (:note "inline word ASH")
+ (:args (number :scs (unsigned-reg))
+ (count :scs (signed-reg)))
+ (:arg-types unsigned-num tagged-num)
+ (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
+ (:results (result :scs (unsigned-reg)))
+ (:result-types unsigned-num)
+ (:generator 8
+ (inst comb :>= count zero-tn positive :nullify t)
+ (inst sub zero-tn count temp)
+ (inst comiclr 31 temp zero-tn :>=)
+ (inst li 31 temp)
+ (inst mtctl temp :sar)
+ (inst extrs number 0 1 temp)
+ (inst b done)
+ (inst shd temp number :variable result)
+ POSITIVE
+ (inst subi 31 count temp)
+ (inst mtctl temp :sar)
+ (inst zdep number :variable 32 result)
+ DONE))
+
+(define-vop (fast-ash/signed=>signed)
+ (:policy :fast-safe)
+ (:translate ash)
+ (:note "inline word ASH")
+ (:args (number :scs (signed-reg))
+ (count :scs (signed-reg)))
+ (:arg-types signed-num tagged-num)
+ (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
+ (:results (result :scs (signed-reg)))
+ (:result-types signed-num)
+ (:generator 8
+ (inst comb :>= count zero-tn positive :nullify t)
+ (inst sub zero-tn count temp)
+ (inst comiclr 31 temp zero-tn :>=)
+ (inst li 31 temp)
+ (inst mtctl temp :sar)
+ (inst extrs number 0 1 temp)
+ (inst b done)
+ (inst shd temp number :variable result)
+ POSITIVE
+ (inst subi 31 count temp)
+ (inst mtctl temp :sar)
+ (inst zdep number :variable 32 result)
+ DONE))
+
+(define-vop (fast-ash-c/unsigned=>unsigned)
+ (:policy :fast-safe)
+ (:translate ash)
+ (:note nil)
+ (:args (number :scs (unsigned-reg)))
+ (:info count)
+ (:arg-types unsigned-num (:constant integer))
+ (:results (result :scs (unsigned-reg)))
+ (:result-types unsigned-num)
+ (:generator 1
+ (cond ((< count 0)
+ ;; It is a right shift.
+ (inst srl number (min (- count) 31) result))
+ ((> count 0)
+ ;; It is a left shift.
+ (inst sll number (min count 31) result))
+ (t
+ ;; Count=0? Shouldn't happen, but it's easy:
+ (move number result)))))
+
+(define-vop (fast-ash-c/signed=>signed)
+ (:policy :fast-safe)
+ (:translate ash)
+ (:note nil)
+ (:args (number :scs (signed-reg)))
+ (:info count)
+ (:arg-types signed-num (:constant integer))
+ (:results (result :scs (signed-reg)))
+ (:result-types signed-num)
+ (:generator 1
+ (cond ((< count 0)
+ ;; It is a right shift.
+ (inst sra number (min (- count) 31) result))
+ ((> count 0)
+ ;; It is a left shift.
+ (inst sll number (min count 31) result))
+ (t
+ ;; Count=0? Shouldn't happen, but it's easy:
+ (move number result)))))
+
+
+(define-vop (signed-byte-32-len)
+ (:translate integer-length)
+ (:note "inline (signed-byte 32) integer-length")
+ (:policy :fast-safe)
+ (:args (arg :scs (signed-reg) :target shift))
+ (:arg-types signed-num)
+ (:results (res :scs (any-reg)))
+ (:result-types positive-fixnum)
+ (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift)
+ (:generator 30
+ (inst move arg shift :>=)
+ (inst uaddcm zero-tn shift shift)
+ (inst comb := shift zero-tn done)
+ (inst li 0 res)
+ LOOP
+ (inst srl shift 1 shift)
+ (inst comb :<> shift zero-tn loop)
+ (inst addi (fixnumize 1) res res)
+ DONE))
+
+(define-vop (unsigned-byte-32-count)
+ (:translate logcount)
+ (:note "inline (unsigned-byte 32) logcount")
+ (:policy :fast-safe)
+ (:args (arg :scs (unsigned-reg) :target num))
+ (:arg-types unsigned-num)
+ (:results (res :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:temporary (:scs (non-descriptor-reg) :from (:argument 0) :to (:result 0)
+ :target res) num)
+ (:temporary (:scs (non-descriptor-reg)) mask temp)
+ (:generator 30
+ (inst li #x55555555 mask)
+ (inst srl arg 1 temp)
+ (inst and arg mask num)
+ (inst and temp mask temp)
+ (inst add num temp num)
+ (inst li #x33333333 mask)
+ (inst srl num 2 temp)
+ (inst and num mask num)
+ (inst and temp mask temp)
+ (inst add num temp num)
+ (inst li #x0f0f0f0f mask)
+ (inst srl num 4 temp)
+ (inst and num mask num)
+ (inst and temp mask temp)
+ (inst add num temp num)
+ (inst li #x00ff00ff mask)
+ (inst srl num 8 temp)
+ (inst and num mask num)
+ (inst and temp mask temp)
+ (inst add num temp num)
+ (inst li #x0000ffff mask)
+ (inst srl num 16 temp)
+ (inst and num mask num)
+ (inst and temp mask temp)
+ (inst add num temp res)))
+
+;;; Multiply and Divide.
+
+(define-vop (fast-*/fixnum=>fixnum fast-fixnum-binop)
+ (:args (x :scs (any-reg) :target x-pass)
+ (y :scs (any-reg) :target y-pass))
+ (:temporary (:sc signed-reg :offset nl0-offset
+ :from (:argument 0) :to (:result 0)) x-pass)
+ (:temporary (:sc signed-reg :offset nl1-offset
+ :from (:argument 1) :to (:result 0)) y-pass)
+ (:temporary (:sc signed-reg :offset nl2-offset :target r
+ :from (:argument 1) :to (:result 0)) res-pass)
+ (:temporary (:sc signed-reg :offset nl3-offset :to (:result 0)) tmp)
+ (:temporary (:sc signed-reg :offset nl4-offset
+ :from (:argument 1) :to (:result 0)) sign)
+ (:temporary (:sc interior-reg :offset lip-offset) lip)
+ (:ignore lip sign)
+ (:translate *)
+ (:generator 30
+ (unless (location= y y-pass)
+ (inst sra x 2 x-pass))
+ (let ((fixup (make-fixup 'multiply :assembly-routine)))
+ (inst ldil fixup tmp)
+ (inst ble fixup lisp-heap-space tmp))
+ (if (location= y y-pass)
+ (inst sra x 2 x-pass)
+ (inst move y y-pass))
+ (move res-pass r)))
+
+(define-vop (fast-*/signed=>signed fast-signed-binop)
+ (:translate *)
+ (:args (x :scs (signed-reg) :target x-pass)
+ (y :scs (signed-reg) :target y-pass))
+ (:temporary (:sc signed-reg :offset nl0-offset
+ :from (:argument 0) :to (:result 0)) x-pass)
+ (:temporary (:sc signed-reg :offset nl1-offset
+ :from (:argument 1) :to (:result 0)) y-pass)
+ (:temporary (:sc signed-reg :offset nl2-offset :target r
+ :from (:argument 1) :to (:result 0)) res-pass)
+ (:temporary (:sc signed-reg :offset nl3-offset :to (:result 0)) tmp)
+ (:temporary (:sc signed-reg :offset nl4-offset
+ :from (:argument 1) :to (:result 0)) sign)
+ (:temporary (:sc interior-reg :offset lip-offset) lip)
+ (:ignore lip sign)
+ (:translate *)
+ (:generator 31
+ (let ((fixup (make-fixup 'multiply :assembly-routine)))
+ (move x x-pass)
+ (move y y-pass)
+ (inst ldil fixup tmp)
+ (inst ble fixup lisp-heap-space tmp :nullify t)
+ (inst nop)
+ (move res-pass r))))
+
+(define-vop (fast-truncate/fixnum fast-fixnum-binop)
+ (:translate truncate)
+ (:args (x :scs (any-reg) :target x-pass)
+ (y :scs (any-reg) :target y-pass))
+ (:temporary (:sc signed-reg :offset nl0-offset
+ :from (:argument 0) :to (:result 0)) x-pass)
+ (:temporary (:sc signed-reg :offset nl1-offset
+ :from (:argument 1) :to (:result 0)) y-pass)
+ (:temporary (:sc signed-reg :offset nl2-offset :target q
+ :from (:argument 1) :to (:result 0)) q-pass)
+ (:temporary (:sc signed-reg :offset nl3-offset :target r
+ :from (:argument 1) :to (:result 1)) r-pass)
+ (:results (q :scs (signed-reg))
+ (r :scs (any-reg)))
+ (:result-types tagged-num tagged-num)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 30
+ (let ((zero (generate-error-code vop division-by-zero-error x y)))
+ (inst bc := nil y zero-tn zero))
+ (move x x-pass)
+ (move y y-pass)
+ (let ((fixup (make-fixup 'truncate :assembly-routine)))
+ (inst ldil fixup q-pass)
+ (inst ble fixup lisp-heap-space q-pass :nullify t))
+ (inst nop)
+ (move q-pass q)
+ (move r-pass r)))
+
+(define-vop (fast-truncate/signed fast-signed-binop)
+ (:translate truncate)
+ (:args (x :scs (signed-reg) :target x-pass)
+ (y :scs (signed-reg) :target y-pass))
+ (:temporary (:sc signed-reg :offset nl0-offset
+ :from (:argument 0) :to (:result 0)) x-pass)
+ (:temporary (:sc signed-reg :offset nl1-offset
+ :from (:argument 1) :to (:result 0)) y-pass)
+ (:temporary (:sc signed-reg :offset nl2-offset :target q
+ :from (:argument 1) :to (:result 0)) q-pass)
+ (:temporary (:sc signed-reg :offset nl3-offset :target r
+ :from (:argument 1) :to (:result 1)) r-pass)
+ (:results (q :scs (signed-reg))
+ (r :scs (signed-reg)))
+ (:result-types signed-num signed-num)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 35
+ (let ((zero (generate-error-code vop division-by-zero-error x y)))
+ (inst bc := nil y zero-tn zero))
+ (move x x-pass)
+ (move y y-pass)
+ (let ((fixup (make-fixup 'truncate :assembly-routine)))
+ (inst ldil fixup q-pass)
+ (inst ble fixup lisp-heap-space q-pass :nullify t))
+ (inst nop)
+ (move q-pass q)
+ (move r-pass r)))
+
+\f
+;;;; Binary conditional VOPs:
+
+(define-vop (fast-conditional)
+ (:conditional)
+ (:info target not-p)
+ (:effects)
+ (:affected)
+ (:policy :fast-safe))
+
+(define-vop (fast-conditional/fixnum fast-conditional)
+ (:args (x :scs (any-reg))
+ (y :scs (any-reg)))
+ (:arg-types tagged-num tagged-num)
+ (:note "inline fixnum comparison"))
+
+(define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
+ (:args (x :scs (any-reg)))
+ (:arg-types tagged-num (:constant (signed-byte 9)))
+ (:info target not-p y))
+
+(define-vop (fast-conditional/signed fast-conditional)
+ (:args (x :scs (signed-reg))
+ (y :scs (signed-reg)))
+ (: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)))
+ (:arg-types signed-num (:constant (signed-byte 11)))
+ (:info target not-p y))
+
+(define-vop (fast-conditional/unsigned fast-conditional)
+ (:args (x :scs (unsigned-reg))
+ (y :scs (unsigned-reg)))
+ (: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)))
+ (:arg-types unsigned-num (:constant (signed-byte 11)))
+ (:info target not-p y))
+
+
+(defmacro define-conditional-vop (translate signed-cond unsigned-cond)
+ `(progn
+ ,@(mapcar #'(lambda (suffix cost signed imm)
+ (unless (and (member suffix '(/fixnum -c/fixnum))
+ (eq translate 'eql))
+ `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)"
+ translate suffix))
+ ,(intern
+ (format nil "~:@(FAST-CONDITIONAL~A~)"
+ suffix)))
+ (:translate ,translate)
+ (:generator ,cost
+ (inst ,(if imm 'bci 'bc)
+ ,(if signed signed-cond unsigned-cond)
+ not-p
+ ,(if (eq suffix '-c/fixnum)
+ '(fixnumize y)
+ 'y)
+ x
+ target)))))
+ '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
+ '(3 2 5 4 5 4)
+ '(t t t t nil nil)
+ '(nil t nil t nil t))))
+
+;; We switch < and > because the immediate has to come first.
+
+(define-conditional-vop < :> :>>)
+(define-conditional-vop > :< :<<)
+
+;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
+;;; known fixnum.
+;;;
+(define-conditional-vop eql := :=)
+
+;;; 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))
+ (y :scs (any-reg)))
+ (:arg-types tagged-num tagged-num)
+ (:note "inline fixnum comparison")
+ (:translate eql)
+ (:generator 3
+ (inst bc := not-p x y 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)))
+ (:arg-types tagged-num (:constant (signed-byte 9)))
+ (:info target not-p y)
+ (:translate eql)
+ (:generator 2
+ (inst bci := not-p (fixnumize y) x target)))
+;;;
+(define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
+ (:arg-types * (:constant (signed-byte 9)))
+ (:variant-cost 6))
+
+\f
+;;;; 32-bit logical operations
+
+(define-vop (32bit-logical)
+ (:args (x :scs (unsigned-reg))
+ (y :scs (unsigned-reg)))
+ (: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)))
+ (:arg-types unsigned-num)
+ (:generator 1
+ (inst uaddcm zero-tn x r)))
+
+(define-vop (32bit-logical-and 32bit-logical)
+ (:translate 32bit-logical-and)
+ (:generator 1
+ (inst and x y r)))
+
+(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 x y r)))
+
+(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 x y r)))
+
+(deftransform 32bit-logical-eqv ((x y) (* *))
+ '(32bit-logical-not (32bit-logical-xor x y)))
+
+(deftransform 32bit-logical-andc1 ((x y) (* *))
+ '(32bit-logical-and (32bit-logical-not x) y))
+
+(define-vop (32bit-logical-andc2 32bit-logical)
+ (:translate 32bit-logical-andc2)
+ (:generator 1
+ (inst andcm x y r)))
+
+(deftransform 32bit-logical-orc1 ((x y) (* *))
+ '(32bit-logical-or (32bit-logical-not x) y))
+
+(deftransform 32bit-logical-orc2 ((x y) (* *))
+ '(32bit-logical-or x (32bit-logical-not y)))
+
+
+(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)
+ (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
+ (:note "SHIFT-TOWARDS-START")
+ (:generator 1
+ (inst subi 31 amount temp)
+ (inst mtctl temp :sar)
+ (inst zdep num :variable 32 r)))
+
+(define-vop (shift-towards-end shift-towards-someplace)
+ (:translate shift-towards-end)
+ (:note "SHIFT-TOWARDS-END")
+ (:generator 1
+ (inst mtctl amount :sar)
+ (inst shd zero-tn num :variable r)))
+
+
+\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-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag
+ (unsigned-reg) unsigned-num sb!bignum::%bignum-ref)
+
+(define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag
+ (unsigned-reg) unsigned-num sb!bignum::%bignum-set)
+
+(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)
+ (:conditional)
+ (:info target not-p)
+ (:effects)
+ (:affected)
+ (:generator 1
+ (inst bc :>= not-p digit zero-tn target)))
+
+(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 (unsigned-reg)))
+ (:arg-types unsigned-num unsigned-num positive-fixnum)
+ (:results (result :scs (unsigned-reg))
+ (carry :scs (unsigned-reg)))
+ (:result-types unsigned-num positive-fixnum)
+ (:generator 3
+ (inst addi -1 c zero-tn)
+ (inst addc a b result)
+ (inst addc zero-tn zero-tn carry)))
+
+(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 (unsigned-reg)))
+ (:arg-types unsigned-num unsigned-num positive-fixnum)
+ (:results (result :scs (unsigned-reg))
+ (borrow :scs (unsigned-reg)))
+ (:result-types unsigned-num positive-fixnum)
+ (:generator 4
+ (inst addi -1 c zero-tn)
+ (inst subb a b result)
+ (inst addc zero-tn zero-tn borrow)))
+
+(define-vop (bignum-mult)
+ (:translate sb!bignum::%multiply)
+ (:policy :fast-safe)
+ (:args (x-arg :scs (unsigned-reg) :target x)
+ (y-arg :scs (unsigned-reg) :target y))
+ (:arg-types unsigned-num unsigned-num)
+ (:temporary (:scs (signed-reg) :from (:argument 0)) x)
+ (:temporary (:scs (signed-reg) :from (:argument 1)) y)
+ (:temporary (:scs (signed-reg)) tmp)
+ (:results (hi :scs (unsigned-reg))
+ (lo :scs (unsigned-reg)))
+ (:result-types unsigned-num unsigned-num)
+ (:generator 3
+ ;; Make sure X is less then Y.
+ (inst comclr x-arg y-arg tmp :<<)
+ (inst xor x-arg y-arg tmp)
+ (inst xor x-arg tmp x)
+ (inst xor y-arg tmp y)
+
+ ;; Blow out of here if the result is zero.
+ (inst li 0 hi)
+ (inst comb := x zero-tn done)
+ (inst li 0 lo)
+ (inst li 0 tmp)
+
+ LOOP
+ (inst comb :ev x zero-tn next-bit)
+ (inst srl x 1 x)
+ (inst add lo y lo)
+ (inst addc hi tmp hi)
+ NEXT-BIT
+ (inst add y y y)
+ (inst comb :<> x zero-tn loop)
+ (inst addc tmp tmp tmp)
+
+ DONE))
+
+(define-source-transform sb!bignum:%multiply-and-add (x y carry &optional (extra 0))
+ #+nil ;; This would be greate if it worked, but it doesn't.
+ (if (eql extra 0)
+ `(multiple-value-call #'sb!bignum::%dual-word-add
+ (sb!bignum:%multiply ,x ,y)
+ (values ,carry))
+ `(multiple-value-call #'sb!bignum::%dual-word-add
+ (multiple-value-call #'sb!bignum::%dual-word-add
+ (sb!bignum:%multiply ,x ,y)
+ (values ,carry))
+ (values ,extra)))
+ (let ((hi (gensym "HI-"))
+ (lo (gensym "LO-")))
+ (if (eql extra 0)
+ `(multiple-value-bind (,hi ,lo) (sb!bignum:%multiply ,x ,y)
+ (sb!bignum::%dual-word-add ,hi ,lo ,carry))
+ `(multiple-value-bind (,hi ,lo) (sb!bignum:%multiply ,x ,y)
+ (multiple-value-bind
+ (,hi ,lo)
+ (sb!bignum::%dual-word-add ,hi ,lo ,carry)
+ (sb!bignum::%dual-word-add ,hi ,lo ,extra))))))
+
+(defknown sb!bignum::%dual-word-add
+ (sb!bignum:bignum-element-type sb!bignum:bignum-element-type sb!bignum:bignum-element-type)
+ (values sb!bignum:bignum-element-type sb!bignum:bignum-element-type)
+ (flushable movable))
+
+(define-vop (dual-word-add)
+ (:policy :fast-safe)
+ (:translate sb!bignum::%dual-word-add)
+ (:args (hi :scs (unsigned-reg) :to (:result 1))
+ (lo :scs (unsigned-reg))
+ (extra :scs (unsigned-reg)))
+ (:arg-types unsigned-num unsigned-num unsigned-num)
+ (:results (hi-res :scs (unsigned-reg) :from (:result 1))
+ (lo-res :scs (unsigned-reg) :from (:result 0)))
+ (:result-types unsigned-num unsigned-num)
+ (:affected)
+ (:effects)
+ (:generator 3
+ (inst add lo extra lo-res)
+ (inst addc hi zero-tn hi-res)))
+
+(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 uaddcm zero-tn x r)))
+
+(define-vop (fixnum-to-digit)
+ (:translate sb!bignum::%fixnum-to-digit)
+ (:policy :fast-safe)
+ (:args (fixnum :scs (signed-reg)))
+ (:arg-types tagged-num)
+ (:results (digit :scs (unsigned-reg)))
+ (:result-types unsigned-num)
+ (:generator 1
+ (move fixnum digit)))
+
+(define-vop (bignum-floor)
+ (:translate sb!bignum::%floor)
+ (:policy :fast-safe)
+ (:args (hi :scs (unsigned-reg) :to (:argument 1))
+ (lo :scs (unsigned-reg) :to (:argument 0))
+ (divisor :scs (unsigned-reg)))
+ (:arg-types unsigned-num unsigned-num unsigned-num)
+ (:temporary (:scs (unsigned-reg) :to (:argument 1)) temp)
+ (:results (quo :scs (unsigned-reg) :from (:argument 0))
+ (rem :scs (unsigned-reg) :from (:argument 1)))
+ (:result-types unsigned-num unsigned-num)
+ (:generator 65
+ (inst sub zero-tn divisor temp)
+ (inst ds zero-tn temp zero-tn)
+ (inst add lo lo quo)
+ (inst ds hi divisor rem)
+ (inst addc quo quo quo)
+ (dotimes (i 31)
+ (inst ds rem divisor rem)
+ (inst addc quo quo quo))
+ (inst comclr rem zero-tn zero-tn :>=)
+ (inst add divisor rem 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 (signed-reg)))
+ (:result-types signed-num)
+ (:generator 1
+ (move digit res)))
+
+(define-vop (digit-lshr)
+ (:translate sb!bignum::%digit-logical-shift-right)
+ (: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 2
+ (inst mtctl count :sar)
+ (inst shd zero-tn digit :variable result)))
+
+(define-vop (digit-ashr digit-lshr)
+ (:translate sb!bignum::%ashr)
+ (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
+ (:generator 1
+ (inst extrs digit 0 1 temp)
+ (inst mtctl count :sar)
+ (inst shd temp digit :variable result)))
+
+(define-vop (digit-ashl digit-ashr)
+ (:translate sb!bignum::%ashl)
+ (:generator 1
+ (inst subi 31 count temp)
+ (inst mtctl temp :sar)
+ (inst zdep digit :variable 32 result)))
+
+\f
+;;;; Static functions.
+
+(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 %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
+(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 (:scs (non-descriptor-reg) :type random) ndescr)
+ (:results (result :scs (descriptor-reg)))
+ (:generator 0
+ (pseudo-atomic ()
+ (inst move alloc-tn header)
+ (inst dep other-pointer-lowtag 31 3 header)
+ (inst addi (* (1+ array-dimensions-offset) n-word-bytes) rank ndescr)
+ (inst dep 0 31 3 ndescr)
+ (inst add alloc-tn ndescr alloc-tn)
+ (inst addi (fixnumize (1- array-dimensions-offset)) rank ndescr)
+ (inst sll ndescr n-widetag-bits ndescr)
+ (inst or ndescr type ndescr)
+ (inst srl ndescr 2 ndescr)
+ (storew ndescr header 0 other-pointer-lowtag))
+ (move header result)))
+
+\f
+;;;; Additional accessors and setters for the array header.
+
+(defknown sb!impl::%array-dimension (t index) index
+ (flushable))
+(defknown sb!impl::%set-array-dimension (t index index) index
+ ())
+
+(define-full-reffer %array-dimension *
+ array-dimensions-offset other-pointer-lowtag
+ (any-reg) positive-fixnum sb!impl::%array-dimension)
+
+(define-full-setter %set-array-dimension *
+ array-dimensions-offset other-pointer-lowtag
+ (any-reg) positive-fixnum sb!impl::%set-array-dimension)
+
+
+(defknown sb!impl::%array-rank (t) index (flushable))
+
+(define-vop (array-rank-vop)
+ (:translate sb!impl::%array-rank)
+ (:policy :fast-safe)
+ (:args (x :scs (descriptor-reg)))
+ (:results (res :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:generator 6
+ (loadw res x 0 other-pointer-lowtag)
+ (inst srl res n-widetag-bits res)
+ (inst addi (- (1- array-dimensions-offset)) res res)))
+
+
+\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 bc :>= nil index bound error))
+ (move index result)))
+
+\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-full-data-vector-frobs (type element-type &rest scs)
+ `(progn
+ (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type
+ vector-data-offset other-pointer-lowtag ,scs ,element-type
+ data-vector-ref)
+ (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type
+ vector-data-offset other-pointer-lowtag ,scs ,element-type
+ data-vector-set)))
+
+ (def-partial-data-vector-frobs
+ (type element-type size signed &rest scs)
+ `(progn
+ (define-partial-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type
+ ,size ,signed vector-data-offset other-pointer-lowtag ,scs
+ ,element-type data-vector-ref)
+ (define-partial-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type
+ ,size vector-data-offset other-pointer-lowtag ,scs
+ ,element-type data-vector-set))))
+
+ (def-full-data-vector-frobs simple-vector * descriptor-reg any-reg)
+
+ (def-partial-data-vector-frobs simple-string base-char :byte nil base-char-reg)
+
+ (def-partial-data-vector-frobs simple-array-unsigned-byte-8 positive-fixnum
+ :byte nil unsigned-reg signed-reg)
+
+ (def-partial-data-vector-frobs simple-array-unsigned-byte-16 positive-fixnum
+ :short nil unsigned-reg signed-reg)
+
+ (def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num
+ unsigned-reg)
+
+ (def-partial-data-vector-frobs simple-array-signed-byte-8 tagged-num
+ :byte t signed-reg)
+
+ (def-partial-data-vector-frobs simple-array-signed-byte-16 tagged-num
+ :short t signed-reg)
+
+ (def-full-data-vector-frobs simple-array-signed-byte-30 tagged-num any-reg)
+
+ (def-full-data-vector-frobs simple-array-signed-byte-32 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 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 (result :scs (unsigned-reg) :from (:argument 0)))
+ (:result-types positive-fixnum)
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:temporary (:scs (interior-reg)) lip)
+ (:generator 20
+ (inst srl index ,bit-shift temp)
+ (inst sh2add temp object lip)
+ (loadw result lip vector-data-offset other-pointer-lowtag)
+ (inst zdep index ,(- 32 (integer-length bits)) ,bit-shift temp)
+ ,@(unless (= bits 1)
+ `((inst addi ,(1- bits) temp temp)))
+ (inst mtctl temp :sar)
+ (inst extru result :variable ,bits result)))
+ (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)
+ (let ((offset (- (* (+ word vector-data-offset) n-word-bytes)
+ other-pointer-lowtag)))
+ (cond ((typep offset '(signed-byte 14))
+ (inst ldw offset object result))
+ (t
+ (inst ldil (ldb (byte 21 11) offset) temp)
+ (inst ldw (ldb (byte 11 0) offset) temp result))))
+ (inst extru result (+ (* extra ,bits) ,(1- bits)) ,bits result))))
+ (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))
+ (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)
+ (:temporary (:scs (interior-reg)) lip)
+ (:generator 25
+ (inst srl index ,bit-shift temp)
+ (inst sh2add temp object lip)
+ (loadw old lip vector-data-offset other-pointer-lowtag)
+ (inst zdep index ,(- 32 (integer-length bits)) ,bit-shift temp)
+ ,@(unless (= bits 1)
+ `((inst addi ,(1- bits) temp temp)))
+ (inst mtctl temp :sar)
+ (inst dep (sc-case value (immediate (tn-value value)) (t value))
+ :variable ,bits old)
+ (storew old lip vector-data-offset other-pointer-lowtag)
+ (sc-case value
+ (immediate
+ (inst li (tn-value value) result))
+ (t
+ (move value result)))))
+ (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)) old)
+ (:temporary (:scs (interior-reg)) lip)
+ (:generator 20
+ (multiple-value-bind (word extra) (floor index ,elements-per-word)
+ (let ((offset (- (* (+ word vector-data-offset) n-word-bytes)
+ other-pointer-lowtag)))
+ (cond ((typep offset '(signed-byte 14))
+ (inst ldw offset object old))
+ (t
+ (inst move object lip)
+ (inst addil (ldb (byte 21 11) offset) lip)
+ (inst ldw (ldb (byte 11 0) offset) lip old)))
+ (inst dep (sc-case value
+ (immediate (tn-value value))
+ (t value))
+ (+ (* extra ,bits) ,(1- bits))
+ ,bits
+ old)
+ (if (typep offset '(signed-byte 14))
+ (inst stw old offset object)
+ (inst stw old (ldb (byte 11 0) offset) lip)))
+ (sc-case value
+ (immediate
+ (inst li (tn-value value) result))
+ (t
+ (move value result))))))))))
+ (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) :to (:argument 1))
+ (index :scs (any-reg) :to (:argument 0) :target offset))
+ (:arg-types simple-array-single-float positive-fixnum)
+ (:results (value :scs (single-reg)))
+ (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) offset)
+ (:result-types single-float)
+ (:generator 5
+ (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
+ index offset)
+ (inst fldx offset object value)))
+
+(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) :to (:argument 1))
+ (index :scs (any-reg) :to (:argument 0) :target offset)
+ (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) :from (:argument 0)) offset)
+ (:generator 5
+ (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
+ index offset)
+ (inst fstx value offset object)
+ (unless (location= result value)
+ (inst funop :copy value result))))
+
+(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) :to (:argument 1))
+ (index :scs (any-reg) :to (:argument 0) :target offset))
+ (:arg-types simple-array-double-float positive-fixnum)
+ (:results (value :scs (double-reg)))
+ (:result-types double-float)
+ (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) offset)
+ (:generator 7
+ (inst sll index 1 offset)
+ (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
+ offset offset)
+ (inst fldx offset object value)))
+
+(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) :to (:argument 1))
+ (index :scs (any-reg) :to (:argument 0) :target offset)
+ (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) :from (:argument 0)) offset)
+ (:generator 20
+ (inst sll index 1 offset)
+ (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
+ offset offset)
+ (inst fstx value offset object)
+ (unless (location= result value)
+ (inst funop :copy value result))))
+
+\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) :to :result)
+ (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
+ (inst sll index 1 offset)
+ (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
+ offset offset)
+ (let ((real-tn (complex-single-reg-real-tn value)))
+ (inst fldx offset object real-tn))
+ (let ((imag-tn (complex-single-reg-imag-tn value)))
+ (inst addi n-word-bytes offset offset)
+ (inst fldx offset object imag-tn))))
+
+(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) :to :result)
+ (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
+ (inst sll index 1 offset)
+ (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
+ offset offset)
+ (let ((value-real (complex-single-reg-real-tn value))
+ (result-real (complex-single-reg-real-tn result)))
+ (inst fstx value-real offset object)
+ (unless (location= result-real value-real)
+ (inst funop :copy value-real result-real)))
+ (let ((value-imag (complex-single-reg-imag-tn value))
+ (result-imag (complex-single-reg-imag-tn result)))
+ (inst addi n-word-bytes offset offset)
+ (inst fstx value-imag offset object)
+ (unless (location= result-imag value-imag)
+ (inst funop :copy value-imag result-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
+ (inst sll index 2 offset)
+ (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
+ offset offset)
+ (let ((real-tn (complex-double-reg-real-tn value)))
+ (inst fldx offset object real-tn))
+ (let ((imag-tn (complex-double-reg-imag-tn value)))
+ (inst addi (* 2 n-word-bytes) offset offset)
+ (inst fldx offset object imag-tn))))
+
+(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
+ (inst sll index 2 offset)
+ (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
+ offset offset)
+ (let ((value-real (complex-double-reg-real-tn value))
+ (result-real (complex-double-reg-real-tn result)))
+ (inst fstx value-real offset object)
+ (unless (location= result-real value-real)
+ (inst funop :copy value-real result-real)))
+ (let ((value-imag (complex-double-reg-imag-tn value))
+ (result-imag (complex-double-reg-imag-tn result)))
+ (inst addi (* 2 n-word-bytes) offset offset)
+ (inst fstx value-imag offset object)
+ (unless (location= result-imag value-imag)
+ (inst funop :copy value-imag result-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-full-reffer raw-bits * 0 other-pointer-lowtag (unsigned-reg) unsigned-num
+ %raw-bits)
+(define-full-setter set-raw-bits * 0 other-pointer-lowtag (unsigned-reg)
+ unsigned-num %set-raw-bits)
+
+
+\f
+;;;; Misc. Array VOPs.
+
+(define-vop (get-vector-subtype get-header-data))
+(define-vop (set-vector-subtype set-header-data))
+
--- /dev/null
+(in-package "SB!VM")
+
+(def!constant +backend-fasl-file-implementation+ :hppa)
+(setf *backend-register-save-penalty* 3)
+(setf *backend-byte-order* :big-endian)
+(setf *backend-page-size* 4096)
+
--- /dev/null
+(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
+ (args 0))
+
+(defstruct (arg-info
+ (:constructor make-arg-info (offset prim-type reg-sc stack-sc)))
+ offset
+ prim-type
+ reg-sc
+ stack-sc)
+
+(define-alien-type-method (integer :arg-tn) (type state)
+ (let ((args (arg-state-args state)))
+ (setf (arg-state-args state) (1+ args))
+ (if (alien-integer-type-signed type)
+ (make-arg-info args 'signed-byte-32 'signed-reg 'signed-stack)
+ (make-arg-info args 'unsigned-byte-32 'unsigned-reg 'unsigned-stack))))
+
+(define-alien-type-method (system-area-pointer :arg-tn) (type state)
+ (declare (ignore type))
+ (let ((args (arg-state-args state)))
+ (setf (arg-state-args state) (1+ args))
+ (make-arg-info args 'system-area-pointer 'sap-reg 'sap-stack)))
+
+(define-alien-type-method (single-float :arg-tn) (type state)
+ (declare (ignore type))
+ (let ((args (arg-state-args state)))
+ (setf (arg-state-args state) (1+ args))
+ (make-arg-info args 'single-float 'single-reg 'single-stack)))
+
+(define-alien-type-method (double-float :arg-tn) (type state)
+ (declare (ignore type))
+ (let ((args (logior (1+ (arg-state-args state)) 1)))
+ (setf (arg-state-args state) (1+ args))
+ (make-arg-info args 'double-float 'double-reg 'double-stack)))
+
+(define-alien-type-method (integer :result-tn) (type)
+ (if (alien-integer-type-signed type)
+ (my-make-wired-tn 'signed-byte-32 'signed-reg nl4-offset)
+ (my-make-wired-tn 'unsigned-byte-32 'unsigned-reg nl4-offset)))
+
+(define-alien-type-method (system-area-pointer :result-tn) (type)
+ (declare (ignore type))
+ (my-make-wired-tn 'system-area-pointer 'sap-reg nl4-offset))
+
+(define-alien-type-method (single-float :result-tn) (type)
+ (declare (ignore type))
+ (my-make-wired-tn 'single-float 'single-reg 4))
+
+(define-alien-type-method (double-float :result-tn) (type)
+ (declare (ignore type))
+ (my-make-wired-tn 'double-float 'double-reg 4))
+
+(define-alien-type-method (values :result-tn) (type)
+ (let ((values (alien-values-type-values type)))
+ (when values
+ (assert (null (cdr values)))
+ (invoke-alien-type-method :result-tn (car values)))))
+
+(defun make-arg-tns (type)
+ (let* ((state (make-arg-state))
+ (args (mapcar #'(lambda (arg-type)
+ (invoke-alien-type-method :arg-tn arg-type state))
+ (alien-fun-type-arg-types type)))
+ ;; We need 8 words of cruft, and we need to round up to a multiple
+ ;; of 16 words.
+ (frame-size (logandc2 (+ (arg-state-args state) 8 15) 15)))
+ (values
+ (mapcar #'(lambda (arg)
+ (declare (type arg-info arg))
+ (let ((offset (arg-info-offset arg))
+ (prim-type (arg-info-prim-type arg)))
+ (cond ((>= offset 4)
+ (my-make-wired-tn prim-type (arg-info-stack-sc arg)
+ (- frame-size offset 8 1)))
+ ((or (eq prim-type 'single-float)
+ (eq prim-type 'double-float))
+ (my-make-wired-tn prim-type (arg-info-reg-sc arg)
+ (+ offset 4)))
+ (t
+ (my-make-wired-tn prim-type (arg-info-reg-sc arg)
+ (- nl0-offset offset))))))
+ args)
+ (* frame-size n-word-bytes))))
+
+(!def-vm-support-routine make-call-out-tns (type)
+ (declare (type alien-fun-type type))
+ (multiple-value-bind
+ (arg-tns stack-size)
+ (make-arg-tns type)
+ (values (make-normal-tn *fixnum-primitive-type*)
+ stack-size
+ 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 li (make-fixup foreign-symbol :foreign) res)))
+
+(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 (:scs (any-reg) :to (:result 0)) temp)
+ (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
+ (:vop-var vop)
+ (:generator 0
+ (let ((cur-nfp (current-nfp-tn vop)))
+ (when cur-nfp
+ (store-stack-tn nfp-save cur-nfp))
+ (move function cfunc)
+ (let ((fixup (make-fixup "call_into_c" :foreign)))
+ (inst ldil fixup temp)
+ (inst ble fixup c-text-space temp :nullify t))
+ (inst nop)
+ (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
+ (move nsp-tn result)
+ (unless (zerop amount)
+ (let ((delta (logandc2 (+ amount 63) 63)))
+ (cond ((< delta (ash 1 10))
+ (inst addi delta nsp-tn nsp-tn))
+ (t
+ (inst li delta temp)
+ (inst add temp nsp-tn nsp-tn)))))))
+
+(define-vop (dealloc-number-stack-space)
+ (:info amount)
+ (:policy :fast-safe)
+ (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
+ (:generator 0
+ (unless (zerop amount)
+ (let ((delta (- (logandc2 (+ amount 63) 63))))
+ (cond ((<= (- (ash 1 10)) delta)
+ (inst addi delta nsp-tn nsp-tn))
+ (t
+ (inst li delta temp)
+ (inst add temp nsp-tn nsp-tn)))))))
--- /dev/null
+(in-package "SB!VM")
+
+\f
+;;;; Interfaces to IR2 conversion:
+
+;;; Standard-Argument-Location -- Interface
+;;;
+;;; 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-Return-PC-Passing-Location -- Interface
+;;;
+;;; 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-Arg-Count-Location -- Interface
+;;;
+;;; 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-NFP-TN -- Interface
+;;;
+;;; 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)))
+
+;;; MAKE-STACK-POINTER-TN ()
+;;;
+(!def-vm-support-routine make-stack-pointer-tn ()
+ (make-normal-tn *fixnum-primitive-type*))
+
+;;; MAKE-NUMBER-STACK-POINTER-TN ()
+;;;
+(!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:
+
+;;; BYTES-NEEDED-FOR-NON-DESCRIPTOR-STACK-FRAME -- internal
+;;;
+;;; Return the number of bytes needed for the current non-descriptor stack.
+;;; We have to allocate multiples of 64 bytes.
+;;;
+(defun bytes-needed-for-non-descriptor-stack-frame ()
+ (logandc2 (+ (* (sb-allocated-size 'non-descriptor-stack) n-word-bytes) 63)
+ 63))
+
+;;; Used for setting up the Old-FP in local call.
+;;;
+(define-vop (current-fp)
+ (:results (val :scs (any-reg)))
+ (:generator 1
+ (move cfp-tn val)))
+
+;;; 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 (- (bytes-needed-for-non-descriptor-stack-frame))
+ nfp val)))))
+
+(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 fun-header-word)
+ (dotimes (i (1- simple-fun-code-offset))
+ (inst word 0))
+ ;; The start of the actual code.
+ ;; Fix CODE, cause the function object was passed in.
+ (let ((entry-point (gen-label)))
+ (emit-label entry-point)
+ (inst compute-code-from-fn lip-tn entry-point temp code-tn))
+ ;; Build our stack frames.
+ (inst addi (* n-word-bytes (sb-allocated-size 'control-stack))
+ cfp-tn csp-tn)
+ (let ((nfp (current-nfp-tn vop)))
+ (when nfp
+ (move nsp-tn nfp)
+ (inst addi (bytes-needed-for-non-descriptor-stack-frame)
+ nsp-tn nsp-tn)))
+ (trace-table-entry trace-table-normal)))
+
+(define-vop (allocate-frame)
+ (:results (res :scs (any-reg))
+ (nfp :scs (any-reg)))
+ (:info callee)
+ (:generator 2
+ (move csp-tn res)
+ (inst addi (* n-word-bytes (sb-allocated-size 'control-stack))
+ csp-tn csp-tn)
+ (when (ir2-physenv-number-stack-p callee)
+ (move nsp-tn nfp)
+ (inst addi (bytes-needed-for-non-descriptor-stack-frame)
+ nsp-tn nsp-tn))))
+
+;;; 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 csp-tn res)
+ (inst addi (* nargs n-word-bytes) csp-tn csp-tn))))
+
+\f
+;;; Default-Unknown-Values -- Internal
+;;;
+;;; 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
+;;; called 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
+ subu temp nargs register-arg-count
+
+ bltz temp default-value-7 ; jump to default code
+ addu temp temp -1
+ loadw move-temp old-fp-tn 6 ; Move value to correct location.
+ store-stack-tn val4-tn move-temp
+
+ bltz temp default-value-8
+ addu temp temp -1
+ loadw move-temp old-fp-tn 7
+ store-stack-tn val5-tn move-temp
+
+ ...
+
+defaulting-done
+ move sp old-fp ; 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
+|#
+;;;
+(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))
+ (cond
+ ((<= nvals 1)
+ (assemble ()
+ ;; Note that this is a single-value return point. This is actually
+ ;; the multiple-value entry point for a single desired value, but
+ ;; the code location has to be here, or the debugger backtrace
+ ;; gets confused.
+ (note-this-location vop :single-value-return)
+ (move ocfp-tn csp-tn)
+ (inst compute-code-from-lra code-tn lra-label temp code-tn)))
+ ((<= nvals register-arg-count)
+ (assemble ()
+ ;; Note that this is an unknown-values return point.
+ (note-this-location vop :unknown-return)
+ ;; Branch off to the MV case.
+ (inst b regs-defaulted :nullify t)
+
+ ;; Default any unsupplied values.
+ (do ((val (tn-ref-across values) (tn-ref-across val)))
+ ((null val))
+ (inst move null-tn (tn-ref-tn val)
+ (if (tn-ref-across val)
+ :never
+ :tr)))
+
+ REGS-DEFAULTED
+
+ ;; Clear the stack. Note: the last move in the single value reg
+ ;; defaulting nullifies this, so this only happens in the mv case.
+ (move ocfp-tn csp-tn)
+
+ ;; Fix CODE.
+ (inst compute-code-from-lra code-tn lra-label temp code-tn)))
+ (t
+ (collect ((defaults))
+ (assemble (nil nil :labels (default-stack-vals))
+ ;; Note that this is an unknown-values return point.
+ (note-this-location vop :unknown-return)
+ ;; Branch off to the MV case.
+ (inst b regs-defaulted :nullify t)
+
+ ;; Default any unsupplied register values.
+ (do ((i 1 (1+ i))
+ (val (tn-ref-across values) (tn-ref-across val)))
+ ((= i register-arg-count))
+ (inst move null-tn (tn-ref-tn val)))
+ (inst b default-stack-vals)
+ (move ocfp-tn csp-tn)
+
+ REGS-DEFAULTED
+
+ (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 bci :>= nil (fixnumize i) nargs-tn default-lab)
+ (loadw move-temp ocfp-tn i)
+ (store-stack-tn tn move-temp)))
+
+ DEFAULTING-DONE
+ (move ocfp-tn csp-tn)
+ (inst compute-code-from-lra code-tn lra-label temp code-tn)
+
+ (let ((defaults (defaults)))
+ (assert defaults)
+ (assemble (*elsewhere*)
+ (trace-table-entry trace-table-call-site)
+ DEFAULT-STACK-VALS
+ (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)))))))
+ (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))
+ (assemble (nil nil :labels (variable-values))
+ (inst b variable-values :nullify t)
+
+ (inst compute-code-from-lra code-tn lra-label temp code-tn)
+ (inst move csp-tn start)
+ (inst stwm (first register-arg-tns) n-word-bytes csp-tn)
+ (inst li (fixnumize 1) count)
+
+ DONE
+
+ (assemble (*elsewhere*)
+ (trace-table-entry trace-table-call-site)
+ VARIABLE-VALUES
+ (inst compute-code-from-lra code-tn lra-label temp code-tn)
+ (do ((arg register-arg-tns (rest arg))
+ (i 0 (1+ i)))
+ ((null arg))
+ (storew (first arg) args i))
+ (move args start)
+ (move nargs count)
+ (inst b done :nullify t)
+ (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 (cfp)
+ (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) 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) 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 cfp)
+ (inst compute-lra-from-code code-tn label temp
+ (callee-return-pc-tn callee))
+ (note-this-location vop :call-site)
+ (inst b target :nullify t)
+ (emit-return-pc label)
+ (default-unknown-values vop values nvals move-temp temp label)
+ (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 (cfp)
+ (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)
+ (: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)))
+ (when callee-nfp
+ (maybe-load-stack-tn callee-nfp nfp)))
+ (maybe-load-stack-tn cfp-tn cfp)
+ (inst compute-lra-from-code code-tn label temp
+ (callee-return-pc-tn callee))
+ (note-this-location vop :call-site)
+ (inst b target :nullify t)
+ (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 (cfp)
+ (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 cfp)
+ (inst compute-lra-from-code code-tn label temp
+ (callee-return-pc-tn callee))
+ (note-this-location vop :call-site)
+ (inst b target :nullify t)
+ (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)
+ (:temporary (:scs (interior-reg)) lip)
+ (: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 cfp-tn csp-tn)
+ (let ((cur-nfp (current-nfp-tn vop)))
+ (when cur-nfp
+ (move cur-nfp nsp-tn)))
+ (inst addi (- n-word-bytes other-pointer-lowtag) return-pc-temp lip)
+ (inst bv lip)
+ (move old-fp-temp cfp-tn)
+ (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.
+;;;
+(macrolet ((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
+ '(fdefn :target fdefn-pass)
+ '(arg-fun :target lexenv))
+
+ ,@(when (eq return :tail)
+ '((ocfp :target ocfp-pass)
+ (lra :target lra-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
+ ,@(when (eq return :tail)
+ '(:from (:argument 1)))
+ ,@(unless (eq return :fixed)
+ '(:to :eval)))
+ ocfp-pass)
+
+ (:temporary (:sc descriptor-reg
+ :offset lra-offset
+ ,@(when (eq return :tail)
+ '(:from (:argument 2)))
+ :to :eval)
+ lra-pass)
+
+ ,@(if named
+ `((:temporary (:sc descriptor-reg :offset fdefn-offset
+ :from (:argument ,(if (eq return :tail) 0 1))
+ :to :eval)
+ fdefn-pass))
+
+ `((:temporary (:sc descriptor-reg :offset lexenv-offset
+ :from (:argument ,(if (eq return :tail) 0 1))
+ :to :eval)
+ lexenv)
+ (:temporary (:scs (descriptor-reg)
+ :from (:argument ,(if (eq return :tail) 2 1))
+ :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 (:scs (interior-reg) :type interior) lip)
+
+ (: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
+ (list :load-nargs
+ ,@(if (eq return :tail)
+ '((unless (location= ocfp ocfp-pass)
+ :load-ocfp)
+ (unless (location= lra lra-pass)
+ :load-lra)
+ (when cur-nfp
+ :frob-nfp))
+ '((when cur-nfp
+ :frob-nfp)
+ :comp-lra
+ :save-fp
+ :load-fp)))))
+ (labels
+ ((do-next-filler ()
+ (when filler
+ (ecase (pop filler)
+ ((nil) (do-next-filler))
+ (:load-nargs
+ ,@(if variable
+ `((inst sub csp-tn new-fp nargs-pass)
+ ,@(let ((index -1))
+ (mapcar #'(lambda (name)
+ `(loadw ,name new-fp
+ ,(incf index)))
+ register-arg-names)))
+ '((inst li (fixnumize nargs) nargs-pass))))
+ ,@(if (eq return :tail)
+ '((:load-ocfp
+ (sc-case ocfp
+ (any-reg
+ (inst move ocfp ocfp-pass))
+ (control-stack
+ (loadw ocfp-pass cfp-tn (tn-offset ocfp)))))
+ (:load-lra
+ (sc-case lra
+ (descriptor-reg
+ (inst move lra lra-pass))
+ (control-stack
+ (loadw lra-pass cfp-tn (tn-offset lra)))))
+ (:frob-nfp
+ (inst move cur-nfp nsp-tn)))
+ `((:frob-nfp
+ (store-stack-tn nfp-save cur-nfp))
+ (:comp-lra
+ (inst compute-lra-from-code
+ code-tn lra-label temp lra-pass))
+ (:save-fp
+ (inst move cfp-tn ocfp-pass))
+ (:load-fp
+ ,(if variable
+ '(move new-fp cfp-tn)
+ '(if (> nargs register-arg-count)
+ (move new-fp cfp-tn)
+ (move csp-tn cfp-tn))))))))))
+
+ ,@(if named
+ `((sc-case fdefn
+ (descriptor-reg (move fdefn fdefn-pass))
+ (control-stack
+ (loadw fdefn-pass cfp-tn (tn-offset fdefn))
+ (do-next-filler))
+ (constant
+ (loadw fdefn-pass code-tn (tn-offset fdefn)
+ other-pointer-lowtag)
+ (do-next-filler)))
+ (loadw lip fdefn-pass fdefn-raw-addr-slot
+ other-pointer-lowtag)
+ (do-next-filler))
+ `((sc-case arg-fun
+ (descriptor-reg (move arg-fun lexenv))
+ (control-stack
+ (loadw lexenv cfp-tn (tn-offset arg-fun))
+ (do-next-filler))
+ (constant
+ (loadw lexenv code-tn (tn-offset arg-fun)
+ other-pointer-lowtag)
+ (do-next-filler)))
+ (loadw function lexenv closure-fun-slot
+ fun-pointer-lowtag)
+ (do-next-filler)
+ (inst addi (- (ash simple-fun-code-offset word-shift)
+ fun-pointer-lowtag)
+ function lip)))
+ (loop
+ (cond ((null filler)
+ (return))
+ ((null (car filler))
+ (pop filler))
+ ((null (cdr filler))
+ (return))
+ (t
+ (do-next-filler))))
+
+ (note-this-location vop :call-site)
+ (inst bv lip :nullify (null filler))
+ (do-next-filler))
+
+ ,@(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)
+ (:temporary (:scs (any-reg) :from (:argument 3)) tmp)
+
+ (:vop-var vop)
+
+ (:generator 75
+
+ ;; Move these into the passing locations if they are not already there.
+ (move args-arg args)
+ (move function-arg lexenv)
+ (move old-fp-arg old-fp)
+ (move lra-arg lra)
+
+ ;; Clear the number stack if anything is there.
+ (let ((cur-nfp (current-nfp-tn vop)))
+ (when cur-nfp
+ (inst move cur-nfp nsp-tn)))
+
+ ;; And jump to the assembly-routine that does the bliting.
+ (let ((fixup (make-fixup 'tail-call-variable :assembly-routine)))
+ (inst ldil fixup tmp)
+ (inst be fixup lisp-heap-space tmp :nullify t))))
+
+\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)
+ (:vop-var vop)
+ (:generator 6
+ ;; Clear the number stack.
+ (trace-table-entry trace-table-fun-epilogue)
+ (let ((cur-nfp (current-nfp-tn vop)))
+ (when cur-nfp
+ (inst move cur-nfp nsp-tn)))
+ ;; Clear the control stack, and restore the frame pointer.
+ (move cfp-tn csp-tn)
+ (move old-fp cfp-tn)
+ ;; Out of here.
+ (lisp-return return-pc :offset 1)
+ (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 descriptor-reg :offset a4-offset :from (:eval 0)) a4)
+ (:temporary (:sc descriptor-reg :offset a5-offset :from (:eval 0)) a5)
+ (:temporary (:sc any-reg :offset nargs-offset) nargs)
+ (:temporary (:sc any-reg :offset ocfp-offset) val-ptr)
+ (:vop-var vop)
+ (:generator 6
+ ;; Clear the number stack.
+ (trace-table-entry trace-table-fun-epilogue)
+ (let ((cur-nfp (current-nfp-tn vop)))
+ (when cur-nfp
+ (inst move cur-nfp nsp-tn)))
+ ;; Establish the values pointer and values count.
+ (move cfp-tn val-ptr)
+ (inst li (fixnumize nvals) nargs)
+ ;; restore the frame pointer and clear as much of the control
+ ;; stack as possible.
+ (move old-fp cfp-tn)
+ (inst addi (* nvals n-word-bytes) val-ptr csp-tn)
+ ;; pre-default any argument register that need it.
+ (when (< nvals register-arg-count)
+ (dolist (reg (subseq (list a0 a1 a2 a3 a4 a5) nvals))
+ (move null-tn reg)))
+ ;; And away we go.
+ (lisp-return return-pc)
+ (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 (any-reg) :from (:eval 0)) tmp)
+
+ (:vop-var vop)
+ (:node-var node)
+
+ (:generator 13
+ (trace-table-entry trace-table-fun-epilogue)
+ ;; Clear the number stack.
+ (let ((cur-nfp (current-nfp-tn vop)))
+ (when cur-nfp
+ (inst move cur-nfp nsp-tn)))
+
+ (unless (policy node (> space speed))
+ ;; Check for the single case.
+ (inst comib :<> (fixnumize 1) nvals-arg not-single)
+ (loadw a0 vals-arg)
+
+ ;; Return with one value.
+ (move cfp-tn csp-tn)
+ (move old-fp-arg cfp-tn)
+ (lisp-return lra-arg :offset 1))
+
+ ;; Nope, not the single case.
+ NOT-SINGLE
+ (move old-fp-arg old-fp)
+ (move lra-arg lra)
+ (move vals-arg vals)
+ (move nvals-arg nvals)
+ (let ((fixup (make-fixup 'return-multiple :assembly-routine)))
+ (inst ldil fixup tmp)
+ (inst be fixup lisp-heap-space tmp :nullify t))
+ (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 it's 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 lexenv closure)))
+
+;;; 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
+ ;; Figure out how many things we are going to copy.
+ (unless (zerop fixed)
+ (inst addi (- (fixnumize fixed)) nargs-tn count))
+
+ ;; Blow out of here if is nothing to copy.
+ (inst comb :<= (if (zerop fixed) nargs-tn count) zero-tn done :nullify t)
+
+ (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 csp-tn result))
+
+ ;; Allocate the space on the stack.
+ (inst add csp-tn (if (zerop fixed) nargs-tn count) csp-tn)
+
+ (when (< fixed register-arg-count)
+ ;; We must stop when we run out of stack args, not when we run out of
+ ;; args in general.
+ (inst addi (fixnumize (- register-arg-count)) nargs-tn count)
+ ;; Everything of interest in registers.
+ (inst comb :<= count zero-tn do-regs))
+ ;; Initialize dst to be end of stack.
+ (move csp-tn dst)
+
+ ;; Initialize src to be end of args.
+ (inst add cfp-tn nargs-tn src)
+
+ LOOP
+ ;; *--dst = *--src, --count
+ (inst ldwm (- n-word-bytes) src temp)
+ (inst addib :> (fixnumize -1) count loop)
+ (inst stwm temp (- n-word-bytes) dst)
+
+ DO-REGS
+ (when (< fixed register-arg-count)
+ ;; Now we have to deposit any more args that showed up in registers.
+ ;; We know there is at least one more arg, otherwise we would have
+ ;; branched to done up at the top.
+ (inst addi (fixnumize (- fixed)) nargs-tn count)
+ (do ((i fixed (1+ i)))
+ ((>= i register-arg-count))
+ ;; Is this the last one?
+ (inst addib :<= (fixnumize -1) count done)
+ ;; Store it relative to the pointer saved at the start.
+ (storew (nth i register-arg-tns) result (- i fixed))))
+ DONE))
+
+;;; More args are stored consequtively on the stack, starting immediately at
+;;; the context pointer. The context pointer is not typed, so the lowtag is 0.
+;;;
+(define-full-reffer more-arg * 0 0 (descriptor-reg any-reg) * %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)
+ (:results (result :scs (descriptor-reg)))
+ (:translate %listify-rest-args)
+ (:policy :safe)
+ (:generator 20
+ (move context-arg context)
+ (move count-arg count)
+ ;; Check to see if there are any arguments.
+ (inst comb := count zero-tn done)
+ (move null-tn result)
+
+ ;; We need to do this atomically.
+ (pseudo-atomic ()
+ (assemble ()
+ ;; Allocate a cons (2 words) for each item.
+ (inst move alloc-tn result)
+ (inst dep list-pointer-lowtag 31 3 result)
+ (move result dst)
+ (inst sll count 1 temp)
+ (inst add alloc-tn temp alloc-tn)
+
+ LOOP
+ ;; Grab one value and stash it in the car of this cons.
+ (inst ldwm n-word-bytes context temp)
+ (storew temp dst 0 list-pointer-lowtag)
+
+ ;; Dec count, and if != zero, go back for more.
+ (inst addi (* 2 n-word-bytes) dst dst)
+ (inst addib :> (fixnumize -1) count loop :nullify t)
+ (storew dst dst -1 list-pointer-lowtag)
+
+ ;; NIL out the last cons.
+ (storew null-tn dst -1 list-pointer-lowtag)
+ ;; Clear out dst, because it points past the last cons.
+ (move null-tn dst)))
+ 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.
+;;;
+
+;;; WTF? FIXME -- CSR
+;;;(setf (info function source-transform 'c::%more-arg-context) nil)
+;;;
+(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 addi (fixnumize (- fixed)) supplied count)
+ (inst sub csp-tn count context)))
+
+
+;;; Signal wrong argument count error if Nargs isn't = to Count.
+;;;
+(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
+ (let ((err-lab
+ (generate-error-code vop invalid-arg-count-error nargs)))
+ (cond ((zerop count)
+ (inst bc :<> nil nargs zero-tn err-lab))
+ (t
+ (inst bci :<> nil (fixnumize count) nargs err-lab))))))
+
+;;; Signal an argument count error.
+;;;
+(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
+(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 (:type random :scs (non-descriptor-reg)) temp)
+ (: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 object obj-temp)
+ (loadw value obj-temp symbol-value-slot other-pointer-lowtag)
+ (let ((err-lab (generate-error-code vop unbound-symbol-error obj-temp)))
+ (inst li unbound-marker-widetag temp)
+ (inst bc := nil value temp 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)
+ (:temporary (:type random :scs (non-descriptor-reg)) temp))
+
+(define-vop (boundp boundp-frob)
+ (:translate boundp)
+ (:generator 9
+ (loadw value object symbol-value-slot other-pointer-lowtag)
+ (inst li unbound-marker-widetag temp)
+ (inst bc :<> not-p value temp target)))
+
+(define-vop (fast-symbol-value cell-ref)
+ (:variant symbol-value-slot 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)
+ (let ((err-lab (generate-error-code vop undefined-fun-error obj-temp)))
+ (inst bc := nil value null-tn 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
+ (load-type type function (- fun-pointer-lowtag))
+ (inst addi (- simple-fun-header-widetag) type type)
+ (inst comb := type zero-tn normal-fn)
+ (inst addi (- (ash simple-fun-code-offset word-shift) fun-pointer-lowtag)
+ function lip)
+ (inst li (make-fixup "closure_tramp" :foreign) lip)
+ NORMAL-FN
+ (storew function fdefn fdefn-fun-slot other-pointer-lowtag)
+ (storew lip fdefn fdefn-raw-addr-slot other-pointer-lowtag)
+ (move function result)))
+
+(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 li (make-fixup "undefined_tramp" :foreign) temp)
+ (storew temp fdefn fdefn-raw-addr-slot other-pointer-lowtag)
+ (move fdefn result)))
+
+
+\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 symbol-value-slot other-pointer-lowtag)
+ (inst addi (* binding-size n-word-bytes) bsp-tn bsp-tn)
+ (storew temp bsp-tn (- binding-value-slot binding-size))
+ (storew symbol bsp-tn (- binding-symbol-slot binding-size))
+ (storew val symbol symbol-value-slot other-pointer-lowtag)))
+
+(define-vop (unbind)
+ (:temporary (:scs (descriptor-reg)) symbol value)
+ (:generator 0
+ (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
+ (loadw value bsp-tn (- binding-value-slot binding-size))
+ (storew value symbol symbol-value-slot other-pointer-lowtag)
+ (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
+ (inst addi (- (* binding-size n-word-bytes)) bsp-tn bsp-tn)))
+
+(define-vop (unbind-to-here)
+ (:args (where :scs (descriptor-reg any-reg)))
+ (:temporary (:scs (descriptor-reg)) symbol value)
+ (:generator 0
+ (inst comb := where bsp-tn done :nullify t)
+ (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
+
+ LOOP
+ (inst comb := symbol zero-tn skip)
+ (loadw value bsp-tn (- binding-value-slot binding-size))
+ (storew value symbol symbol-value-slot other-pointer-lowtag)
+ (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
+
+ SKIP
+ (inst addi (* -2 n-word-bytes) bsp-tn bsp-tn)
+ (inst comb :<> where bsp-tn loop :nullify t)
+ (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
+
+ DONE))
+
+
+\f
+;;;; Closure indexing.
+
+(define-full-reffer closure-index-ref *
+ closure-info-offset fun-pointer-lowtag
+ (descriptor-reg any-reg) * %closure-index-ref)
+
+(define-full-setter set-funcallable-instance-info *
+ funcallable-instance-info-offset fun-pointer-lowtag
+ (descriptor-reg any-reg) * %set-funcallable-instance-info)
+
+(define-full-reffer funcallable-instance-info *
+ funcallable-instance-info-offset fun-pointer-lowtag
+ (descriptor-reg any-reg) * %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)))
+ (:results (res :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:generator 4
+ (loadw res struct 0 instance-pointer-lowtag)
+ (inst srl res n-widetag-bits res)))
+
+(define-vop (instance-ref slot-ref)
+ (:variant instance-slots-offset instance-pointer-lowtag)
+ (:policy :fast-safe)
+ (:translate %instance-ref)
+ (:arg-types instance (:constant index)))
+
+#+nil ; As per usual (cf sbcl-devel discussion about this VOP which
+ ; appears to return no values)
+(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-full-reffer instance-index-ref * instance-slots-offset
+ instance-pointer-lowtag (descriptor-reg any-reg) * %instance-ref)
+
+(define-full-setter instance-index-set * instance-slots-offset
+ instance-pointer-lowtag (descriptor-reg any-reg) * %instance-set)
+
+
+\f
+;;;; Code object frobbing.
+
+(define-full-reffer code-header-ref * 0 other-pointer-lowtag
+ (descriptor-reg any-reg) * code-header-ref)
+
+(define-full-setter code-header-set * 0 other-pointer-lowtag
+ (descriptor-reg any-reg) * code-header-set)
--- /dev/null
+(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)))
+ (:generator 1
+ (inst srl x n-widetag-bits y)))
+;;;
+(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)))
+ (:generator 1
+ (inst sll x n-widetag-bits y)
+ (inst addi base-char-widetag y y)))
+;;;
+(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))))
+ (:effects)
+ (:affected)
+ (:generator 0
+ (move x y)))
+;;;
+(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-argument)
+ (:args (x :target y
+ :scs (base-char-reg))
+ (fp :scs (any-reg)
+ :load-if (not (sc-is y base-char-reg))))
+ (:results (y))
+ (:generator 0
+ (sc-case y
+ (base-char-reg
+ (move x y))
+ (base-char-stack
+ (storew x fp (tn-offset y))))))
+;;;
+(define-move-vop move-base-char-argument :move-arg
+ (any-reg base-char-reg) (base-char-reg))
+
+
+;;; Use standard MOVE-ARGUMENT + coercion to move an untagged base-char
+;;; to a descriptor passing location.
+;;;
+(define-move-vop move-argument :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 (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:generator 1
+ (move ch res)))
+
+(define-vop (code-char)
+ (:translate code-char)
+ (:policy :fast-safe)
+ (:args (code :scs (unsigned-reg) :target res))
+ (:arg-types positive-fixnum)
+ (:results (res :scs (base-char-reg)))
+ (:result-types base-char)
+ (:generator 1
+ (move code res)))
+
+\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 cond)
+ (:generator 3
+ (inst bc cond not-p x y target)))
+
+(define-vop (fast-char=/base-char base-char-compare)
+ (:translate char=)
+ (:variant :=))
+
+(define-vop (fast-char</base-char base-char-compare)
+ (:translate char<)
+ (:variant :<<))
+
+(define-vop (fast-char>/base-char base-char-compare)
+ (:translate char>)
+ (:variant :>>))
--- /dev/null
+(in-package "SB!VM")
+
+
+(define-vop (debug-cur-sp)
+ (:translate current-sp)
+ (:policy :fast-safe)
+ (:results (res :scs (sap-reg)))
+ (:result-types system-area-pointer)
+ (:generator 1
+ (move csp-tn res)))
+
+(define-vop (debug-cur-fp)
+ (:translate current-fp)
+ (:policy :fast-safe)
+ (:results (res :scs (sap-reg)))
+ (:result-types system-area-pointer)
+ (:generator 1
+ (move cfp-tn res)))
+
+(define-vop (read-control-stack)
+ (:translate stack-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (sap-reg))
+ (offset :scs (any-reg)))
+ (:arg-types system-area-pointer positive-fixnum)
+ (:results (result :scs (descriptor-reg)))
+ (:result-types *)
+ (:generator 5
+ (inst ldwx offset object result)))
+
+(define-vop (read-control-stack-c)
+ (:translate stack-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (sap-reg)))
+ (:info offset)
+ (:arg-types system-area-pointer (:constant (signed-byte 12)))
+ (:results (result :scs (descriptor-reg)))
+ (:result-types *)
+ (:generator 4
+ (inst ldw (* offset n-word-bytes) object result)))
+
+(define-vop (write-control-stack)
+ (:translate %set-stack-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (sap-reg) :target sap)
+ (offset :scs (any-reg))
+ (value :scs (descriptor-reg) :target result))
+ (:arg-types system-area-pointer positive-fixnum *)
+ (:results (result :scs (descriptor-reg)))
+ (:result-types *)
+ (:temporary (:scs (sap-reg) :from (:argument 1)) sap)
+ (:generator 2
+ (inst add object offset sap)
+ (inst stw value 0 sap)
+ (move value result)))
+
+(define-vop (write-control-stack-c)
+ (:translate %set-stack-ref)
+ (:policy :fast-safe)
+ (:args (sap :scs (sap-reg))
+ (value :scs (descriptor-reg) :target result))
+ (:info offset)
+ (:arg-types system-area-pointer (:constant (signed-byte 12)) *)
+ (:results (result :scs (descriptor-reg)))
+ (:result-types *)
+ (:generator 1
+ (inst stw value (* offset n-word-bytes) sap)
+ (move value result)))
+
+(define-vop (code-from-mumble)
+ (:policy :fast-safe)
+ (:args (thing :scs (descriptor-reg) :to :save))
+ (:results (code :scs (descriptor-reg)))
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:variant-vars lowtag)
+ (:generator 5
+ (loadw temp thing 0 lowtag)
+ (inst srl temp n-widetag-bits temp)
+ (inst comb := zero-tn temp done)
+ (move null-tn code)
+ (inst sll temp (1- (integer-length n-word-bytes)) temp)
+ (unless (= lowtag other-pointer-lowtag)
+ (inst addi (- lowtag other-pointer-lowtag) temp temp))
+ (inst sub thing temp code)
+ DONE))
+
+(define-vop (code-from-lra code-from-mumble)
+ (:translate lra-code-header)
+ (:variant other-pointer-lowtag))
+
+(define-vop (code-from-fun code-from-mumble)
+ (:translate fun-code-header)
+ (:variant fun-pointer-lowtag))
+
+(define-vop (make-lisp-obj)
+ (:policy :fast-safe)
+ (:translate make-lisp-obj)
+ (:args (value :scs (unsigned-reg) :target result))
+ (:arg-types unsigned-num)
+ (:results (result :scs (descriptor-reg)))
+ (:generator 1
+ (move value result)))
+
+(define-vop (get-lisp-obj-address)
+ (:policy :fast-safe)
+ (:translate get-lisp-obj-address)
+ (:args (thing :scs (descriptor-reg) :target result))
+ (:results (result :scs (unsigned-reg)))
+ (:result-types unsigned-num)
+ (:generator 1
+ (move thing result)))
+
+(define-vop (fun-word-offset)
+ (:policy :fast-safe)
+ (:translate 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 srl res n-widetag-bits res)))
--- /dev/null
+(in-package "SB!VM")
+
+\f
+;;;; Move functions.
+
+(define-move-fun (load-fp-zero 1) (vop x y)
+ ((fp-single-zero) (single-reg)
+ (fp-double-zero) (double-reg))
+ (inst funop :copy x y))
+
+(defun ld-float (offset base r)
+ (cond ((< offset (ash 1 4))
+ (inst flds offset base r))
+ (t
+ (inst ldo offset zero-tn lip-tn)
+ (inst fldx lip-tn base r))))
+
+(define-move-fun (load-float 1) (vop x y)
+ ((single-stack) (single-reg)
+ (double-stack) (double-reg))
+ (let ((offset (* (tn-offset x) n-word-bytes)))
+ (ld-float offset (current-nfp-tn vop) y)))
+
+(defun str-float (x offset base)
+ (cond ((< offset (ash 1 4))
+ (inst fsts x offset base))
+ (t
+ (inst ldo offset zero-tn lip-tn)
+ (inst fstx x lip-tn base))))
+
+(define-move-fun (store-float 1) (vop x y)
+ ((single-reg) (single-stack)
+ (double-reg) (double-stack))
+ (let ((offset (* (tn-offset y) n-word-bytes)))
+ (str-float x offset (current-nfp-tn vop))))
+
+\f
+;;;; Move VOPs
+
+(define-vop (move-float)
+ (:args (x :scs (single-reg double-reg)
+ :target y
+ :load-if (not (location= x y))))
+ (:results (y :scs (single-reg double-reg)
+ :load-if (not (location= x y))))
+ (:note "float move")
+ (:generator 0
+ (unless (location= y x)
+ (inst funop :copy x y))))
+
+(define-move-vop move-float :move (single-reg) (single-reg))
+(define-move-vop move-float :move (double-reg) (double-reg))
+
+
+(define-vop (move-from-float)
+ (:args (x :to :save))
+ (:results (y :scs (descriptor-reg)))
+ (:temporary (:scs (non-descriptor-reg)) ndescr)
+ (:variant-vars size type data)
+ (:note "float to pointer coercion")
+ (:generator 13
+ (with-fixed-allocation (y ndescr type size))
+ (inst fsts x (- (* data n-word-bytes) other-pointer-lowtag) y)))
+
+(macrolet ((frob (name sc &rest args)
+ `(progn
+ (define-vop (,name move-from-float)
+ (:args (x :scs (,sc) :to :save))
+ (:variant ,@args))
+ (define-move-vop ,name :move (,sc) (descriptor-reg)))))
+ (frob move-from-single single-reg
+ single-float-size single-float-widetag single-float-value-slot)
+ (frob move-from-double double-reg
+ double-float-size double-float-widetag double-float-value-slot))
+
+(define-vop (move-to-float)
+ (:args (x :scs (descriptor-reg)))
+ (:results (y))
+ (:variant-vars offset)
+ (:note "pointer to float coercion")
+ (:generator 2
+ (inst flds (- (* offset n-word-bytes) other-pointer-lowtag) x y)))
+
+(macrolet ((frob (name sc offset)
+ `(progn
+ (define-vop (,name move-to-float)
+ (:results (y :scs (,sc)))
+ (:variant ,offset))
+ (define-move-vop ,name :move (descriptor-reg) (,sc)))))
+ (frob move-to-single single-reg single-float-value-slot)
+ (frob move-to-double double-reg double-float-value-slot))
+
+
+(define-vop (move-float-argument)
+ (:args (x :scs (single-reg double-reg) :target y)
+ (nfp :scs (any-reg)
+ :load-if (not (sc-is y single-reg double-reg))))
+ (:results (y))
+ (:note "float argument move")
+ (:generator 1
+ (sc-case y
+ ((single-reg double-reg)
+ (unless (location= x y)
+ (inst funop :copy x y)))
+ ((single-stack double-stack)
+ (let ((offset (* (tn-offset y) n-word-bytes)))
+ (str-float x offset nfp))))))
+
+(define-move-vop move-float-argument :move-arg
+ (single-reg descriptor-reg) (single-reg))
+(define-move-vop move-float-argument :move-arg
+ (double-reg descriptor-reg) (double-reg))
+
+\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 (1+ (tn-offset x))))
+
+
+(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) n-word-bytes)))
+ (let ((real-tn (complex-single-reg-real-tn y)))
+ (ld-float offset nfp real-tn))
+ (let ((imag-tn (complex-single-reg-imag-tn y)))
+ (ld-float (+ offset n-word-bytes) nfp imag-tn))))
+
+(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) n-word-bytes)))
+ (let ((real-tn (complex-single-reg-real-tn x)))
+ (str-float real-tn offset nfp))
+ (let ((imag-tn (complex-single-reg-imag-tn x)))
+ (str-float imag-tn (+ offset n-word-bytes) nfp))))
+
+
+(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) n-word-bytes)))
+ (let ((real-tn (complex-double-reg-real-tn y)))
+ (ld-float offset nfp real-tn))
+ (let ((imag-tn (complex-double-reg-imag-tn y)))
+ (ld-float (+ offset (* 2 n-word-bytes)) nfp imag-tn))))
+
+(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) n-word-bytes)))
+ (let ((real-tn (complex-double-reg-real-tn x)))
+ (str-float real-tn offset nfp))
+ (let ((imag-tn (complex-double-reg-imag-tn x)))
+ (str-float imag-tn (+ offset (* 2 n-word-bytes)) nfp))))
+
+;;;
+;;; 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 funop :copy x-real y-real))
+ (let ((x-imag (complex-single-reg-imag-tn x))
+ (y-imag (complex-single-reg-imag-tn y)))
+ (inst funop :copy x-imag y-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 funop :copy x-real y-real))
+ (let ((x-imag (complex-double-reg-imag-tn x))
+ (y-imag (complex-double-reg-imag-tn y)))
+ (inst funop :copy x-imag y-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)
+ (:note "complex single float to pointer coercion")
+ (:generator 13
+ (with-fixed-allocation (y ndescr complex-single-float-widetag
+ complex-single-float-size))
+ (let ((real-tn (complex-single-reg-real-tn x)))
+ (inst fsts real-tn (- (* complex-single-float-real-slot n-word-bytes)
+ other-pointer-lowtag)
+ y))
+ (let ((imag-tn (complex-single-reg-imag-tn x)))
+ (inst fsts imag-tn (- (* complex-single-float-imag-slot n-word-bytes)
+ other-pointer-lowtag)
+ y))))
+;;;
+(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)
+ (:note "complex double float to pointer coercion")
+ (:generator 13
+ (with-fixed-allocation (y ndescr complex-double-float-widetag
+ complex-double-float-size))
+ (let ((real-tn (complex-double-reg-real-tn x)))
+ (inst fsts real-tn (- (* complex-double-float-real-slot n-word-bytes)
+ other-pointer-lowtag)
+ y))
+ (let ((imag-tn (complex-double-reg-imag-tn x)))
+ (inst fsts imag-tn (- (* complex-double-float-imag-slot n-word-bytes)
+ other-pointer-lowtag)
+ y))))
+;;;
+(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 flds (- (* complex-single-float-real-slot n-word-bytes)
+ other-pointer-lowtag)
+ x real-tn))
+ (let ((imag-tn (complex-single-reg-imag-tn y)))
+ (inst flds (- (* complex-single-float-imag-slot n-word-bytes)
+ other-pointer-lowtag)
+ x imag-tn))))
+(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 flds (- (* complex-double-float-real-slot n-word-bytes)
+ other-pointer-lowtag)
+ x real-tn))
+ (let ((imag-tn (complex-double-reg-imag-tn y)))
+ (inst flds (- (* complex-double-float-imag-slot n-word-bytes)
+ other-pointer-lowtag)
+ x imag-tn))))
+(define-move-vop move-to-complex-double :move
+ (descriptor-reg) (complex-double-reg))
+
+;;;
+;;; Complex float move-argument vop
+;;;
+(define-vop (move-complex-single-float-argument)
+ (:args (x :scs (complex-single-reg) :target y)
+ (nfp :scs (any-reg) :load-if (not (sc-is y complex-single-reg))))
+ (:results (y))
+ (:note "float argument 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 funop :copy x-real y-real))
+ (let ((x-imag (complex-single-reg-imag-tn x))
+ (y-imag (complex-single-reg-imag-tn y)))
+ (inst funop :copy x-imag y-imag))))
+ (complex-single-stack
+ (let ((offset (* (tn-offset y) n-word-bytes)))
+ (let ((real-tn (complex-single-reg-real-tn x)))
+ (str-float real-tn offset nfp))
+ (let ((imag-tn (complex-single-reg-imag-tn x)))
+ (str-float imag-tn (+ offset n-word-bytes) nfp)))))))
+;;;
+(define-move-vop move-complex-single-float-argument :move-arg
+ (complex-single-reg descriptor-reg) (complex-single-reg))
+
+(define-vop (move-complex-double-float-argument)
+ (:args (x :scs (complex-double-reg) :target y)
+ (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-reg))))
+ (:results (y))
+ (:note "float argument move")
+ (:generator 1
+ (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 funop :copy x-real y-real))
+ (let ((x-imag (complex-double-reg-imag-tn x))
+ (y-imag (complex-double-reg-imag-tn y)))
+ (inst funop :copy x-imag y-imag))))
+ (complex-double-stack
+ (let ((offset (* (tn-offset y) n-word-bytes)))
+ (let ((real-tn (complex-double-reg-real-tn x)))
+ (str-float real-tn offset nfp))
+ (let ((imag-tn (complex-double-reg-imag-tn x)))
+ (str-float imag-tn (+ offset (* 2 n-word-bytes)) nfp)))))))
+;;;
+(define-move-vop move-complex-double-float-argument :move-arg
+ (complex-double-reg descriptor-reg) (complex-double-reg))
+
+
+(define-move-vop move-argument :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))
+ (:variant-vars operation)
+ (:policy :fast-safe)
+ (:note "inline float arithmetic")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:node-var node)
+ (:generator 0
+ (inst fbinop operation x y r)
+ (when (policy node (or (= debug 3) (> safety speed)))
+ (note-next-instruction vop :internal-error)
+ (inst fsts fp-single-zero-tn 0 csp-tn))))
+
+(macrolet ((frob (name sc zero-sc ptype)
+ `(define-vop (,name float-op)
+ (:args (x :scs (,sc ,zero-sc))
+ (y :scs (,sc ,zero-sc)))
+ (:results (r :scs (,sc)))
+ (:arg-types ,ptype ,ptype)
+ (:result-types ,ptype))))
+ (frob single-float-op single-reg fp-single-zero single-float)
+ (frob double-float-op double-reg fp-double-zero double-float))
+
+(macrolet ((frob (translate op sname scost dname dcost)
+ `(progn
+ (define-vop (,sname single-float-op)
+ (:translate ,translate)
+ (:variant ,op)
+ (:variant-cost ,scost))
+ (define-vop (,dname double-float-op)
+ (:translate ,translate)
+ (:variant ,op)
+ (:variant-cost ,dcost)))))
+ (frob + :add +/single-float 2 +/double-float 2)
+ (frob - :sub -/single-float 2 -/double-float 2)
+ (frob * :mpy */single-float 4 */double-float 5)
+ (frob / :div //single-float 12 //double-float 19))
+
+
+(macrolet ((frob (name translate sc type inst)
+ `(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)
+ (:node-var node)
+ (:generator 1
+ ,inst
+ (when (policy node (or (= debug 3) (> safety speed)))
+ (note-next-instruction vop :internal-error)
+ (inst fsts fp-single-zero-tn 0 csp-tn))))))
+ (frob abs/single-float abs single-reg single-float
+ (inst funop :abs x y))
+ (frob abs/double-float abs double-reg double-float
+ (inst funop :abs x y))
+ (frob %negate/single-float %negate single-reg single-float
+ (inst fbinop :sub fp-single-zero-tn x y))
+ (frob %negate/double-float %negate double-reg double-float
+ (inst fbinop :sub fp-double-zero-tn x y)))
+
+\f
+;;;; Comparison:
+
+(define-vop (float-compare)
+ (:args (x) (y))
+ (:conditional)
+ (:info target not-p)
+ (:variant-vars condition complement)
+ (:policy :fast-safe)
+ (:note "inline float comparison")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 3
+ ;; This is the condition to nullify the branch, so it is inverted.
+ (inst fcmp (if not-p condition complement) x y)
+ (note-next-instruction vop :internal-error)
+ (inst ftest)
+ (inst b target :nullify t)))
+
+(macrolet ((frob (name sc zero-sc ptype)
+ `(define-vop (,name float-compare)
+ (:args (x :scs (,sc ,zero-sc))
+ (y :scs (,sc ,zero-sc)))
+ (:arg-types ,ptype ,ptype))))
+ (frob single-float-compare single-reg fp-single-zero single-float)
+ (frob double-float-compare double-reg fp-double-zero double-float))
+
+(macrolet ((frob (translate condition complement sname dname)
+ `(progn
+ (define-vop (,sname single-float-compare)
+ (:translate ,translate)
+ (:variant ,condition ,complement))
+ (define-vop (,dname double-float-compare)
+ (:translate ,translate)
+ (:variant ,condition ,complement)))))
+ (frob < #b01001 #b10101 </single-float </double-float)
+ (frob > #b10001 #b01101 >/single-float >/double-float)
+ (frob = #b00101 #b11001 eql/single-float eql/double-float))
+
+\f
+;;;; Conversion:
+
+(macrolet ((frob (name translate 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)
+ (:node-var node)
+ (:generator 2
+ (inst fcnvff x y)
+ (when (policy node (or (= debug 3) (> safety speed)))
+ (note-next-instruction vop :internal-error)
+ (inst fsts fp-single-zero-tn 0 csp-tn))))))
+ (frob %single-float/double-float %single-float
+ double-reg double-float
+ single-reg single-float)
+ (frob %double-float/single-float %double-float
+ single-reg single-float
+ double-reg double-float))
+
+(macrolet ((frob (name translate to-sc to-type)
+ `(define-vop (,name)
+ (:args (x :scs (signed-reg)
+ :load-if (not (sc-is x signed-stack))
+ :target stack-temp))
+ (:arg-types signed-num)
+ (:results (y :scs (,to-sc)))
+ (:result-types ,to-type)
+ (:policy :fast-safe)
+ (:note "inline float coercion")
+ (:translate ,translate)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:node-var node)
+ (:temporary (:scs (signed-stack) :from (:argument 0))
+ stack-temp)
+ (:temporary (:scs (single-reg) :to (:result 0) :target y)
+ fp-temp)
+ (:temporary (:scs (any-reg) :from (:argument 0)
+ :to (:result 0)) index)
+ (:generator 5
+ (let* ((nfp (current-nfp-tn vop))
+ (stack-tn
+ (sc-case x
+ (signed-stack
+ x)
+ (signed-reg
+ (storew x nfp (tn-offset stack-temp))
+ stack-temp)))
+ (offset (* (tn-offset stack-tn) n-word-bytes)))
+ (cond ((< offset (ash 1 4))
+ (inst flds offset nfp fp-temp))
+ (t
+ (inst ldo offset zero-tn index)
+ (inst fldx index nfp fp-temp)))
+ (inst fcnvxf fp-temp y)
+ (when (policy node (or (= debug 3) (> safety speed)))
+ (note-next-instruction vop :internal-error)
+ (inst fsts fp-single-zero-tn 0 csp-tn)))))))
+ (frob %single-float/signed %single-float
+ single-reg single-float)
+ (frob %double-float/signed %double-float
+ double-reg double-float))
+
+
+(macrolet ((frob (trans from-sc from-type inst note)
+ `(define-vop (,(symbolicate trans "/" from-type))
+ (:args (x :scs (,from-sc)
+ :target fp-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 ,note)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:temporary (:scs (single-reg) :from (:argument 0)) fp-temp)
+ (:temporary (:scs (signed-stack) :to (:result 0) :target y)
+ stack-temp)
+ (:temporary (:scs (any-reg) :from (:argument 0)
+ :to (:result 0)) index)
+ (:generator 3
+ (let* ((nfp (current-nfp-tn vop))
+ (stack-tn
+ (sc-case y
+ (signed-stack y)
+ (signed-reg stack-temp)))
+ (offset (* (tn-offset stack-tn) n-word-bytes)))
+ (inst ,inst x fp-temp)
+ (cond ((< offset (ash 1 4))
+ (note-next-instruction vop :internal-error)
+ (inst fsts fp-temp offset nfp))
+ (t
+ (inst ldo offset zero-tn index)
+ (note-next-instruction vop :internal-error)
+ (inst fstx fp-temp index nfp)))
+ (unless (eq y stack-tn)
+ (loadw y nfp (tn-offset stack-tn))))))))
+ (frob %unary-round single-reg single-float fcnvfx "inline float round")
+ (frob %unary-round double-reg double-float fcnvfx "inline float round")
+ (frob %unary-truncate single-reg single-float fcnvfxt
+ "inline float truncate")
+ (frob %unary-truncate double-reg double-float fcnvfxt
+ "inline float truncate"))
+
+
+(define-vop (make-single-float)
+ (:args (bits :scs (signed-reg)
+ :load-if (or (not (sc-is bits signed-stack))
+ (sc-is res single-stack))
+ :target res))
+ (:results (res :scs (single-reg)
+ :load-if (not (sc-is bits single-stack))))
+ (:arg-types signed-num)
+ (:result-types single-float)
+ (:translate make-single-float)
+ (:policy :fast-safe)
+ (:vop-var vop)
+ (:temporary (:scs (single-stack) :from (:argument 0) :to (:result 0)) temp)
+ (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
+ (:generator 2
+ (let ((nfp (current-nfp-tn vop)))
+ (sc-case bits
+ (signed-reg
+ (sc-case res
+ (single-reg
+ (let ((offset (* (tn-offset temp) n-word-bytes)))
+ (inst stw bits offset nfp)
+ (cond ((< offset (ash 1 4))
+ (inst flds offset nfp res))
+ (t
+ (inst ldo offset zero-tn index)
+ (inst fldx index nfp res)))))
+ (single-stack
+ (inst stw bits (* (tn-offset res) n-word-bytes) nfp))))
+ (signed-stack
+ (sc-case res
+ (single-reg
+ (let ((offset (* (tn-offset bits) n-word-bytes)))
+ (cond ((< offset (ash 1 4))
+ (inst flds offset nfp res))
+ (t
+ (inst ldo offset zero-tn index)
+ (inst fldx index nfp res)))))))))))
+
+(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))))
+ (:arg-types signed-num unsigned-num)
+ (:result-types double-float)
+ (:translate make-double-float)
+ (:policy :fast-safe)
+ (:temporary (:scs (double-stack) :to (:result 0)) temp)
+ (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
+ (:vop-var vop)
+ (:generator 2
+ (let* ((nfp (current-nfp-tn vop))
+ (stack-tn (sc-case res
+ (double-stack res)
+ (double-reg temp)))
+ (offset (* (tn-offset stack-tn) n-word-bytes)))
+ (inst stw hi-bits offset nfp)
+ (inst stw lo-bits (+ offset n-word-bytes) nfp)
+ (cond ((eq stack-tn res))
+ ((< offset (ash 1 4))
+ (inst flds offset nfp res))
+ (t
+ (inst ldo offset zero-tn index)
+ (inst fldx index nfp res))))))
+
+
+(define-vop (single-float-bits)
+ (:args (float :scs (single-reg)
+ :load-if (not (sc-is float single-stack))))
+ (:results (bits :scs (signed-reg)
+ :load-if (or (not (sc-is bits signed-stack))
+ (sc-is float single-stack))))
+ (:arg-types single-float)
+ (:result-types signed-num)
+ (:translate single-float-bits)
+ (:policy :fast-safe)
+ (:vop-var vop)
+ (:temporary (:scs (signed-stack) :from (:argument 0) :to (:result 0)) temp)
+ (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
+ (:generator 2
+ (let ((nfp (current-nfp-tn vop)))
+ (sc-case float
+ (single-reg
+ (sc-case bits
+ (signed-reg
+ (let ((offset (* (tn-offset temp) n-word-bytes)))
+ (cond ((< offset (ash 1 4))
+ (inst fsts float offset nfp))
+ (t
+ (inst ldo offset zero-tn index)
+ (inst fstx float index nfp)))
+ (inst ldw offset nfp bits)))
+ (signed-stack
+ (let ((offset (* (tn-offset bits) n-word-bytes)))
+ (cond ((< offset (ash 1 4))
+ (inst fsts float offset nfp))
+ (t
+ (inst ldo offset zero-tn index)
+ (inst fstx float index nfp)))))))
+ (single-stack
+ (sc-case bits
+ (signed-reg
+ (inst ldw (* (tn-offset float) n-word-bytes) nfp bits))))))))
+
+(define-vop (double-float-high-bits)
+ (:args (float :scs (double-reg)
+ :load-if (not (sc-is float double-stack))))
+ (:results (hi-bits :scs (signed-reg)
+ :load-if (or (not (sc-is hi-bits signed-stack))
+ (sc-is float double-stack))))
+ (:arg-types double-float)
+ (:result-types signed-num)
+ (:translate double-float-high-bits)
+ (:policy :fast-safe)
+ (:vop-var vop)
+ (:temporary (:scs (signed-stack) :from (:argument 0) :to (:result 0)) temp)
+ (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
+ (:generator 2
+ (let ((nfp (current-nfp-tn vop)))
+ (sc-case float
+ (double-reg
+ (sc-case hi-bits
+ (signed-reg
+ (let ((offset (* (tn-offset temp) n-word-bytes)))
+ (cond ((< offset (ash 1 4))
+ (inst fsts float offset nfp :side 0))
+ (t
+ (inst ldo offset zero-tn index)
+ (inst fstx float index nfp :side 0)))
+ (inst ldw offset nfp hi-bits)))
+ (signed-stack
+ (let ((offset (* (tn-offset hi-bits) n-word-bytes)))
+ (cond ((< offset (ash 1 4))
+ (inst fsts float offset nfp :side 0))
+ (t
+ (inst ldo offset zero-tn index)
+ (inst fstx float index nfp :side 0)))))))
+ (double-stack
+ (sc-case hi-bits
+ (signed-reg
+ (let ((offset (* (tn-offset float) n-word-bytes)))
+ (inst ldw offset nfp hi-bits)))))))))
+
+(define-vop (double-float-low-bits)
+ (:args (float :scs (double-reg)
+ :load-if (not (sc-is float double-stack))))
+ (:results (lo-bits :scs (unsigned-reg)
+ :load-if (or (not (sc-is lo-bits unsigned-stack))
+ (sc-is float double-stack))))
+ (:arg-types double-float)
+ (:result-types unsigned-num)
+ (:translate double-float-low-bits)
+ (:policy :fast-safe)
+ (:vop-var vop)
+ (:temporary (:scs (unsigned-stack) :from (:argument 0) :to (:result 0)) temp)
+ (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
+ (:generator 2
+ (let ((nfp (current-nfp-tn vop)))
+ (sc-case float
+ (double-reg
+ (sc-case lo-bits
+ (unsigned-reg
+ (let ((offset (* (tn-offset temp) n-word-bytes)))
+ (cond ((< offset (ash 1 4))
+ (inst fsts float offset nfp :side 1))
+ (t
+ (inst ldo offset zero-tn index)
+ (inst fstx float index nfp :side 1)))
+ (inst ldw offset nfp lo-bits)))
+ (unsigned-stack
+ (let ((offset (* (tn-offset lo-bits) n-word-bytes)))
+ (cond ((< offset (ash 1 4))
+ (inst fsts float offset nfp :side 1))
+ (t
+ (inst ldo offset zero-tn index)
+ (inst fstx float index nfp :side 1)))))))
+ (double-stack
+ (sc-case lo-bits
+ (unsigned-reg
+ (let ((offset (* (1+ (tn-offset float)) n-word-bytes)))
+ (inst ldw offset nfp lo-bits)))))))))
+
+
+\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)
+ :load-if (not (sc-is res unsigned-stack))))
+ (:result-types unsigned-num)
+ (:translate floating-point-modes)
+ (:policy :fast-safe)
+ (:temporary (:scs (unsigned-stack) :to (:result 0)) temp)
+ (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
+ (:vop-var vop)
+ (:generator 3
+ (let* ((nfp (current-nfp-tn vop))
+ (stack-tn (sc-case res
+ (unsigned-stack res)
+ (unsigned-reg temp)))
+ (offset (* (tn-offset stack-tn) n-word-bytes)))
+ (cond ((< offset (ash 1 4))
+ (inst fsts fp-single-zero-tn offset nfp))
+ (t
+ (inst ldo offset zero-tn index)
+ (inst fstx fp-single-zero-tn index nfp)))
+ (unless (eq stack-tn res)
+ (inst ldw offset nfp res)))))
+
+(define-vop (set-floating-point-modes)
+ (:args (new :scs (unsigned-reg)
+ :load-if (not (sc-is new unsigned-stack))))
+ (:results (res :scs (unsigned-reg)))
+ (:arg-types unsigned-num)
+ (:result-types unsigned-num)
+ (:translate (setf floating-point-modes))
+ (:policy :fast-safe)
+ (:temporary (:scs (unsigned-stack) :from (:argument 0) :to (:result 0)) temp)
+ (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
+ (:vop-var vop)
+ (:generator 3
+ (let* ((nfp (current-nfp-tn vop))
+ (stack-tn (sc-case new
+ (unsigned-stack new)
+ (unsigned-reg temp)))
+ (offset (* (tn-offset stack-tn) n-word-bytes)))
+ (unless (eq new stack-tn)
+ (inst stw new offset nfp))
+ (cond ((< offset (ash 1 4))
+ (inst flds offset nfp fp-single-zero-tn))
+ (t
+ (inst ldo offset zero-tn index)
+ (inst fldx index nfp fp-single-zero-tn)))
+ (inst ldw offset nfp res))))
+
+\f
+;;;; Complex float VOPs
+
+(define-vop (make-complex-single-float)
+ (:translate complex)
+ (:args (real :scs (single-reg) :target 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 funop :copy real r-real)))
+ (let ((r-imag (complex-single-reg-imag-tn r)))
+ (unless (location= imag r-imag)
+ (inst funop :copy imag r-imag))))
+ (complex-single-stack
+ (let ((nfp (current-nfp-tn vop))
+ (offset (* (tn-offset r) n-word-bytes)))
+ (str-float real offset nfp)
+ (str-float imag (+ offset n-word-bytes) nfp))))))
+
+(define-vop (make-complex-double-float)
+ (:translate complex)
+ (:args (real :scs (double-reg) :target 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 funop :copy real r-real)))
+ (let ((r-imag (complex-double-reg-imag-tn r)))
+ (unless (location= imag r-imag)
+ (inst funop :copy imag r-imag))))
+ (complex-double-stack
+ (let ((nfp (current-nfp-tn vop))
+ (offset (* (tn-offset r) n-word-bytes)))
+ (str-float real offset nfp)
+ (str-float imag (+ offset (* 2 n-word-bytes)) nfp))))))
+
+
+(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 funop :copy value-tn r))))
+ (complex-single-stack
+ (ld-float (* (+ (ecase slot (:real 0) (:imag 1)) (tn-offset x))
+ n-word-bytes)
+ (current-nfp-tn vop) r)))))
+
+(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 funop :copy value-tn r))))
+ (complex-double-stack
+ (ld-float (* (+ (ecase slot (:real 0) (:imag 2)) (tn-offset x))
+ n-word-bytes)
+ (current-nfp-tn vop) r)))))
+
+(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))
--- /dev/null
+(in-package "SB!VM")
+
+;;; (def-assembler-params
+;;; :scheduler-p nil)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (setf sb!assem:*assem-scheduler-p* nil))
+
+\f
+;;;; Utility functions.
+
+(defun reg-tn-encoding (tn)
+ (declare (type tn tn))
+ (sc-case tn
+ (null null-offset)
+ (zero zero-offset)
+ (t
+ (assert (eq (sb-name (sc-sb (tn-sc tn))) 'registers))
+ (tn-offset tn))))
+
+(defun fp-reg-tn-encoding (tn)
+ (declare (type tn tn))
+ (sc-case tn
+ (fp-single-zero (values 0 nil))
+ (single-reg (values (tn-offset tn) nil))
+ (fp-double-zero (values 0 t))
+ (double-reg (values (tn-offset tn) t))))
+
+(defconstant-eqx compare-conditions
+ '(:never := :< :<= :<< :<<= :sv :od :tr :<> :>= :> :>>= :>> :nsv :ev)
+ #'equalp)
+
+(deftype compare-condition ()
+ `(member nil ,@compare-conditions))
+
+(defun compare-condition (cond)
+ (declare (type compare-condition cond))
+ (if cond
+ (let ((result (or (position cond compare-conditions :test #'eq)
+ (error "Bogus Compare/Subtract condition: ~S" cond))))
+ (values (ldb (byte 3 0) result)
+ (logbitp 3 result)))
+ (values 0 nil)))
+
+(defconstant-eqx add-conditions
+ '(:never := :< :<= :nuv :znv :sv :od :tr :<> :>= :> :uv :vnz :nsv :ev)
+ #'equalp)
+
+(deftype add-condition ()
+ `(member nil ,@add-conditions))
+
+(defun add-condition (cond)
+ (declare (type add-condition cond))
+ (if cond
+ (let ((result (or (position cond add-conditions :test #'eq)
+ (error "Bogus Add condition: ~S" cond))))
+ (values (ldb (byte 3 0) result)
+ (logbitp 3 result)))
+ (values 0 nil)))
+
+(defconstant-eqx logical-conditions
+ '(:never := :< :<= nil nil nil :od :tr :<> :>= :> nil nil nil :ev)
+ #'equalp)
+
+(deftype logical-condition ()
+ `(member nil ,@(remove nil logical-conditions)))
+
+(defun logical-condition (cond)
+ (declare (type logical-condition cond))
+ (if cond
+ (let ((result (or (position cond logical-conditions :test #'eq)
+ (error "Bogus Logical condition: ~S" cond))))
+ (values (ldb (byte 3 0) result)
+ (logbitp 3 result)))
+ (values 0 nil)))
+
+(defconstant-eqx unit-conditions
+ '(:never nil :sbz :shz :sdc :sbc :shc :tr nil :nbz :nhz :ndc :nbc :nhc)
+ #'equalp)
+
+(deftype unit-condition ()
+ `(member nil ,@(remove nil unit-conditions)))
+
+(defun unit-condition (cond)
+ (declare (type unit-condition cond))
+ (if cond
+ (let ((result (or (position cond unit-conditions :test #'eq)
+ (error "Bogus Unit condition: ~S" cond))))
+ (values (ldb (byte 3 0) result)
+ (logbitp 3 result)))
+ (values 0 nil)))
+
+(defconstant-eqx extract/deposit-conditions
+ '(:never := :< :od :tr :<> :>= :ev)
+ #'equalp)
+
+(deftype extract/deposit-condition ()
+ `(member nil ,@extract/deposit-conditions))
+
+(defun extract/deposit-condition (cond)
+ (declare (type extract/deposit-condition cond))
+ (if cond
+ (or (position cond extract/deposit-conditions :test #'eq)
+ (error "Bogus Extract/Deposit condition: ~S" cond))
+ 0))
+
+
+(defun space-encoding (space)
+ (declare (type (unsigned-byte 3) space))
+ (dpb (ldb (byte 2 0) space)
+ (byte 2 1)
+ (ldb (byte 1 2) space)))
+
+\f
+;;;; Initial disassembler setup.
+
+(setf sb!disassem:*disassem-inst-alignment-bytes* 4)
+
+(defvar *disassem-use-lisp-reg-names* t)
+
+(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 (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 (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))))
+
+(sb!disassem:define-arg-type fp-fmt-0c
+ :printer #'(lambda (value stream dstate)
+ (declare (ignore dstate) (stream stream) (fixnum value))
+ (ecase value
+ (0 (format stream "~A" '\,SGL))
+ (1 (format stream "~A" '\,DBL))
+ (3 (format stream "~A" '\,QUAD)))))
+
+(defun low-sign-extend (x n)
+ (let ((normal (dpb x (byte 1 (1- n)) (ldb (byte (1- n) 1) x))))
+ (if (logbitp 0 x)
+ (logior (ash -1 (1- n)) normal)
+ normal)))
+
+(defun sign-extend (x n)
+ (if (logbitp (1- n) x)
+ (logior (ash -1 (1- n)) x)
+ x))
+
+(defun assemble-bits (x list)
+ (let ((result 0)
+ (offset 0))
+ (dolist (e (reverse list))
+ (setf result (logior result (ash (ldb e x) offset)))
+ (incf offset (byte-size e)))
+ result))
+
+(defmacro define-imx-decode (name bits)
+ `(sb!disassem:define-arg-type ,name
+ :printer #'(lambda (value stream dstate)
+ (declare (ignore dstate) (stream stream) (fixnum value))
+ (format stream "~S" (low-sign-extend value ,bits)))))
+
+(define-imx-decode im5 5)
+(define-imx-decode im11 11)
+(define-imx-decode im14 14)
+
+(sb!disassem:define-arg-type im3
+ :printer #'(lambda (value stream dstate)
+ (declare (ignore dstate) (stream stream) (fixnum value))
+ (format stream "~S" (assemble-bits value `(,(byte 1 0)
+ ,(byte 2 1))))))
+
+(sb!disassem:define-arg-type im21
+ :printer #'(lambda (value stream dstate)
+ (declare (ignore dstate) (stream stream) (fixnum value))
+ (format stream "~S"
+ (assemble-bits value `(,(byte 1 0) ,(byte 11 1)
+ ,(byte 2 14) ,(byte 5 16)
+ ,(byte 2 12))))))
+
+(sb!disassem:define-arg-type cp
+ :printer #'(lambda (value stream dstate)
+ (declare (ignore dstate) (stream stream) (fixnum value))
+ (format stream "~S" (- 31 value))))
+
+(sb!disassem:define-arg-type clen
+ :printer #'(lambda (value stream dstate)
+ (declare (ignore dstate) (stream stream) (fixnum value))
+ (format stream "~S" (- 32 value))))
+
+(sb!disassem:define-arg-type compare-condition
+ :printer #("" \,= \,< \,<= \,<< \,<<= \,SV \,OD \,TR \,<> \,>=
+ \,> \,>>= \,>> \,NSV \,EV))
+
+(sb!disassem:define-arg-type compare-condition-false
+ :printer #(\,TR \,<> \,>= \,> \,>>= \,>> \,NSV \,EV
+ "" \,= \,< \,<= \,<< \,<<= \,SV \,OD))
+
+(sb!disassem:define-arg-type add-condition
+ :printer #("" \,= \,< \,<= \,NUV \,ZNV \,SV \,OD \,TR \,<> \,>= \,> \,UV
+ \,VNZ \,NSV \,EV))
+
+(sb!disassem:define-arg-type add-condition-false
+ :printer #(\,TR \,<> \,>= \,> \,UV \,VNZ \,NSV \,EV
+ "" \,= \,< \,<= \,NUV \,ZNV \,SV \,OD))
+
+(sb!disassem:define-arg-type logical-condition
+ :printer #("" \,= \,< \,<= "" "" "" \,OD \,TR \,<> \,>= \,> "" "" "" \,EV))
+
+(sb!disassem:define-arg-type unit-condition
+ :printer #("" "" \,SBZ \,SHZ \,SDC \,SBC \,SHC \,TR "" \,NBZ \,NHZ \,NDC
+ \,NBC \,NHC))
+
+(sb!disassem:define-arg-type extract/deposit-condition
+ :printer #("" \,= \,< \,OD \,TR \,<> \,>= \,EV))
+
+(sb!disassem:define-arg-type extract/deposit-condition-false
+ :printer #(\,TR \,<> \,>= \,EV "" \,= \,< \,OD))
+
+(sb!disassem:define-arg-type nullify
+ :printer #("" \,N))
+
+(sb!disassem:define-arg-type fcmp-cond
+ :printer #(\FALSE? \FALSE \? \!<=> \= \=T \?= \!<> \!?>= \< \?<
+ \!>= \!?> \<= \?<= \!> \!?<= \> \?>\ \!<= \!?< \>=
+ \?>= \!< \!?= \<> \!= \!=T \!? \<=> \TRUE? \TRUE))
+
+(sb!disassem:define-arg-type integer
+ :printer #'(lambda (value stream dstate)
+ (declare (ignore dstate) (stream stream) (fixnum value))
+ (format stream "~S" value)))
+
+(sb!disassem:define-arg-type space
+ :printer #("" |1,| |2,| |3,|))
+
+\f
+;;;; Define-instruction-formats for disassembler.
+
+(sb!disassem:define-instruction-format
+ (load/store 32)
+ (op :field (byte 6 26))
+ (b :field (byte 5 21) :type 'reg)
+ (t/r :field (byte 5 16) :type 'reg)
+ (s :field (byte 2 14) :type 'space)
+ (im14 :field (byte 14 0) :type 'im14))
+
+(defconstant-eqx cmplt-index-print '((:cond ((u :constant 1) '\,S))
+ (:cond ((m :constant 1) '\,M)))
+ #'equalp)
+
+(defconstant-eqx cmplt-disp-print '((:cond ((m :constant 1)
+ (:cond ((s :constant 0) '\,MA)
+ (t '\,MB)))))
+ #'equalp)
+
+(defconstant-eqx cmplt-store-print '((:cond ((s :constant 0) '\,B)
+ (t '\,E))
+ (:cond ((m :constant 1) '\,M)))
+ #'equalp)
+
+(sb!disassem:define-instruction-format
+ (extended-load/store 32)
+ (op1 :field (byte 6 26) :value 3)
+ (b :field (byte 5 21) :type 'reg)
+ (x/im5/r :field (byte 5 16) :type 'reg)
+ (s :field (byte 2 14) :type 'space)
+ (u :field (byte 1 13))
+ (op2 :field (byte 3 10))
+ (ext4/c :field (byte 4 6))
+ (m :field (byte 1 5))
+ (t/im5 :field (byte 5 0) :type 'reg))
+
+(sb!disassem:define-instruction-format
+ (ldil 32 :default-printer '(:name :tab im21 "," t))
+ (op :field (byte 6 26))
+ (t :field (byte 5 21) :type 'reg)
+ (im21 :field (byte 21 0) :type 'im21))
+
+(sb!disassem:define-instruction-format
+ (branch17 32)
+ (op1 :field (byte 6 26))
+ (t :field (byte 5 21) :type 'reg)
+ (w :fields `(,(byte 5 16) ,(byte 11 2) ,(byte 1 0))
+ :use-label
+ #'(lambda (value dstate)
+ (declare (type sb!disassem:disassem-state dstate) (list value))
+ (let ((x (logior (ash (first value) 12) (ash (second value) 1)
+ (third value))))
+ (+ (ash (sign-extend
+ (assemble-bits x `(,(byte 1 0) ,(byte 5 12) ,(byte 1 1)
+ ,(byte 10 2))) 17) 2)
+ (sb!disassem:dstate-cur-addr dstate) 8))))
+ (op2 :field (byte 3 13))
+ (n :field (byte 1 1) :type 'nullify))
+
+(sb!disassem:define-instruction-format
+ (branch12 32)
+ (op1 :field (byte 6 26))
+ (r2 :field (byte 5 21) :type 'reg)
+ (r1 :field (byte 5 16) :type 'reg)
+ (w :fields `(,(byte 11 2) ,(byte 1 0))
+ :use-label
+ #'(lambda (value dstate)
+ (declare (type sb!disassem:disassem-state dstate) (list value))
+ (let ((x (logior (ash (first value) 1) (second value))))
+ (+ (ash (sign-extend
+ (assemble-bits x `(,(byte 1 0) ,(byte 1 1) ,(byte 10 2)))
+ 12) 2)
+ (sb!disassem:dstate-cur-addr dstate) 8))))
+ (c :field (byte 3 13))
+ (n :field (byte 1 1) :type 'nullify))
+
+(sb!disassem:define-instruction-format
+ (branch 32)
+ (op1 :field (byte 6 26))
+ (t :field (byte 5 21) :type 'reg)
+ (x :field (byte 5 16) :type 'reg)
+ (op2 :field (byte 3 13))
+ (x1 :field (byte 11 2))
+ (n :field (byte 1 1) :type 'nullify)
+ (x2 :field (byte 1 0)))
+
+(sb!disassem:define-instruction-format
+ (r3-inst 32 :default-printer '(:name c :tab r1 "," r2 "," t))
+ (r3 :field (byte 6 26) :value 2)
+ (r2 :field (byte 5 21) :type 'reg)
+ (r1 :field (byte 5 16) :type 'reg)
+ (c :field (byte 3 13))
+ (f :field (byte 1 12))
+ (op :field (byte 7 5))
+ (t :field (byte 5 0) :type 'reg))
+
+(sb!disassem:define-instruction-format
+ (imm-inst 32 :default-printer '(:name c :tab im11 "," r "," t))
+ (op :field (byte 6 26))
+ (r :field (byte 5 21) :type 'reg)
+ (t :field (byte 5 16) :type 'reg)
+ (c :field (byte 3 13))
+ (f :field (byte 1 12))
+ (o :field (byte 1 11))
+ (im11 :field (byte 11 0) :type 'im11))
+
+(sb!disassem:define-instruction-format
+ (extract/deposit-inst 32)
+ (op1 :field (byte 6 26))
+ (r2 :field (byte 5 21) :type 'reg)
+ (r1 :field (byte 5 16) :type 'reg)
+ (c :field (byte 3 13) :type 'extract/deposit-condition)
+ (op2 :field (byte 3 10))
+ (cp :field (byte 5 5) :type 'cp)
+ (t/clen :field (byte 5 0) :type 'clen))
+
+(sb!disassem:define-instruction-format
+ (break 32 :default-printer '(:name :tab im13 "," im5))
+ (op1 :field (byte 6 26) :value 0)
+ (im13 :field (byte 13 13))
+ (q2 :field (byte 8 5) :value 0)
+ (im5 :field (byte 5 0)))
+
+(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 (* n-byte-bits (1+ offset))
+ vector (* n-word-bits
+ vector-data-offset)
+ (* length n-byte-bits))
+ (collect ((sc-offsets)
+ (lengths))
+ (lengths 1) ; the length byte
+ (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 break-control (chunk inst stream dstate)
+ (declare (ignore inst))
+ (flet ((nt (x) (if stream (sb!disassem:note x dstate))))
+ (case (break-im5 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: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!disassem:define-instruction-format
+ (system-inst 32)
+ (op1 :field (byte 6 26) :value 0)
+ (r1 :field (byte 5 21) :type 'reg)
+ (r2 :field (byte 5 16) :type 'reg)
+ (s :field (byte 3 13))
+ (op2 :field (byte 8 5))
+ (r3 :field (byte 5 0) :type 'reg))
+
+(sb!disassem:define-instruction-format
+ (fp-load/store 32)
+ (op :field (byte 6 26))
+ (b :field (byte 5 21) :type 'reg)
+ (x :field (byte 5 16) :type 'reg)
+ (s :field (byte 2 14) :type 'space)
+ (u :field (byte 1 13))
+ (x1 :field (byte 1 12))
+ (x2 :field (byte 2 10))
+ (x3 :field (byte 1 9))
+ (x4 :field (byte 3 6))
+ (m :field (byte 1 5))
+ (t :field (byte 5 0) :type 'fp-reg))
+
+(sb!disassem:define-instruction-format
+ (fp-class-0-inst 32)
+ (op1 :field (byte 6 26))
+ (r :field (byte 5 21) :type 'fp-reg)
+ (x1 :field (byte 5 16) :type 'fp-reg)
+ (op2 :field (byte 3 13))
+ (fmt :field (byte 2 11) :type 'fp-fmt-0c)
+ (x2 :field (byte 2 9))
+ (x3 :field (byte 3 6))
+ (x4 :field (byte 1 5))
+ (t :field (byte 5 0) :type 'fp-reg))
+
+(sb!disassem:define-instruction-format
+ (fp-class-1-inst 32)
+ (op1 :field (byte 6 26))
+ (r :field (byte 5 21) :type 'fp-reg)
+ (x1 :field (byte 4 17) :value 0)
+ (x2 :field (byte 2 15))
+ (df :field (byte 2 13) :type 'fp-fmt-0c)
+ (sf :field (byte 2 11) :type 'fp-fmt-0c)
+ (x3 :field (byte 2 9) :value 1)
+ (x4 :field (byte 3 6) :value 0)
+ (x5 :field (byte 1 5) :value 0)
+ (t :field (byte 5 0) :type 'fp-reg))
+
+
+\f
+;;;; Load and Store stuff.
+
+(define-bitfield-emitter emit-load/store 32
+ (byte 6 26)
+ (byte 5 21)
+ (byte 5 16)
+ (byte 2 14)
+ (byte 14 0))
+
+
+(defun im14-encoding (segment disp)
+ (declare (type (or fixup (signed-byte 14))))
+ (cond ((fixup-p disp)
+ (note-fixup segment :load disp)
+ (assert (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
+ 0)
+ (t
+ (dpb (ldb (byte 13 0) disp)
+ (byte 13 1)
+ (ldb (byte 1 13) disp)))))
+
+(macrolet ((define-load-inst (name opcode)
+ `(define-instruction ,name (segment disp base reg)
+ (:declare (type tn reg base)
+ (type (or fixup (signed-byte 14)) disp))
+ (:printer load/store ((op ,opcode) (s 0))
+ '(:name :tab im14 "(" s b ")," t/r))
+ (:emitter
+ (emit-load/store segment ,opcode
+ (reg-tn-encoding base) (reg-tn-encoding reg) 0
+ (im14-encoding segment disp)))))
+ (define-store-inst (name opcode)
+ `(define-instruction ,name (segment reg disp base)
+ (:declare (type tn reg base)
+ (type (or fixup (signed-byte 14)) disp))
+ (:printer load/store ((op ,opcode) (s 0))
+ '(:name :tab t/r "," im14 "(" s b ")"))
+ (:emitter
+ (emit-load/store segment ,opcode
+ (reg-tn-encoding base) (reg-tn-encoding reg) 0
+ (im14-encoding segment disp))))))
+ (define-load-inst ldw #x12)
+ (define-load-inst ldh #x11)
+ (define-load-inst ldb #x10)
+ (define-load-inst ldwm #x13)
+ (define-load-inst ldo #x0D)
+
+ (define-store-inst stw #x1A)
+ (define-store-inst sth #x19)
+ (define-store-inst stb #x18)
+ (define-store-inst stwm #x1B))
+
+(define-bitfield-emitter emit-extended-load/store 32
+ (byte 6 26) (byte 5 21) (byte 5 16) (byte 2 14) (byte 1 13)
+ (byte 3 10) (byte 4 6) (byte 1 5) (byte 5 0))
+
+(macrolet ((define-load-indexed-inst (name opcode)
+ `(define-instruction ,name (segment index base reg &key modify scale)
+ (:declare (type tn reg base index)
+ (type (member t nil) modify scale))
+ (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'reg)
+ (op2 0))
+ `(:name ,@cmplt-index-print :tab x/im5/r
+ "(" s b ")" t/im5))
+ (:emitter
+ (emit-extended-load/store
+ segment #x03 (reg-tn-encoding base) (reg-tn-encoding index)
+ 0 (if scale 1 0) 0 ,opcode (if modify 1 0)
+ (reg-tn-encoding reg))))))
+ (define-load-indexed-inst ldwx 2)
+ (define-load-indexed-inst ldhx 1)
+ (define-load-indexed-inst ldbx 0)
+ (define-load-indexed-inst ldcwx 7))
+
+(defun short-disp-encoding (segment disp)
+ (declare (type (or fixup (signed-byte 5)) disp))
+ (cond ((fixup-p disp)
+ (note-fixup segment :load-short disp)
+ (assert (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
+ 0)
+ (t
+ (dpb (ldb (byte 4 0) disp)
+ (byte 4 1)
+ (ldb (byte 1 4) disp)))))
+
+(macrolet ((define-load-short-inst (name opcode)
+ `(define-instruction ,name (segment base disp reg &key modify)
+ (:declare (type tn base reg)
+ (type (or fixup (signed-byte 5)) disp)
+ (type (member :before :after nil) modify))
+ (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'im5)
+ (op2 4))
+ `(:name ,@cmplt-disp-print :tab x/im5/r
+ "(" s b ")" t/im5))
+ (:emitter
+ (multiple-value-bind
+ (m a)
+ (ecase modify
+ ((nil) (values 0 0))
+ (:after (values 1 0))
+ (:before (values 1 1)))
+ (emit-extended-load/store segment #x03 (reg-tn-encoding base)
+ (short-disp-encoding segment disp)
+ 0 a 4 ,opcode m
+ (reg-tn-encoding reg))))))
+ (define-store-short-inst (name opcode)
+ `(define-instruction ,name (segment reg base disp &key modify)
+ (:declare (type tn reg base)
+ (type (or fixup (signed-byte 5)) disp)
+ (type (member :before :after nil) modify))
+ (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'im5)
+ (op2 4))
+ `(:name ,@cmplt-disp-print :tab x/im5/r
+ "," t/im5 "(" s b ")"))
+ (:emitter
+ (multiple-value-bind
+ (m a)
+ (ecase modify
+ ((nil) (values 0 0))
+ (:after (values 1 0))
+ (:before (values 1 1)))
+ (emit-extended-load/store segment #x03 (reg-tn-encoding base)
+ (short-disp-encoding segment disp)
+ 0 a 4 ,opcode m
+ (reg-tn-encoding reg)))))))
+ (define-load-short-inst ldws 2)
+ (define-load-short-inst ldhs 1)
+ (define-load-short-inst ldbs 0)
+ (define-load-short-inst ldcws 7)
+
+ (define-store-short-inst stws 10)
+ (define-store-short-inst sths 9)
+ (define-store-short-inst stbs 8))
+
+(define-instruction stbys (segment reg base disp where &key modify)
+ (:declare (type tn reg base)
+ (type (signed-byte 5) disp)
+ (type (member :begin :end) where)
+ (type (member t nil) modify))
+ (:printer extended-load/store ((ext4/c #xC) (t/im5 nil :type 'im5) (op2 4))
+ `(:name ,@cmplt-store-print :tab x/im5/r "," t/im5 "(" s b ")"))
+ (:emitter
+ (emit-extended-load/store segment #x03 (reg-tn-encoding base)
+ (reg-tn-encoding reg) 0
+ (ecase where (:begin 0) (:end 1))
+ 4 #xC (if modify 1 0)
+ (short-disp-encoding segment disp))))
+
+\f
+;;;; Immediate Instructions.
+
+(define-bitfield-emitter emit-ldil 32
+ (byte 6 26)
+ (byte 5 21)
+ (byte 21 0))
+
+(defun immed-21-encoding (segment value)
+ (declare (type (or fixup (signed-byte 21) (unsigned-byte 21)) value))
+ (cond ((fixup-p value)
+ (note-fixup segment :hi value)
+ (assert (or (null (fixup-offset value)) (zerop (fixup-offset value))))
+ 0)
+ (t
+ (logior (ash (ldb (byte 5 2) value) 16)
+ (ash (ldb (byte 2 7) value) 14)
+ (ash (ldb (byte 2 0) value) 12)
+ (ash (ldb (byte 11 9) value) 1)
+ (ldb (byte 1 20) value)))))
+
+(define-instruction ldil (segment value reg)
+ (:declare (type tn reg)
+ (type (or (signed-byte 21) (unsigned-byte 21) fixup) value))
+ (:printer ldil ((op #x08)))
+ (:emitter
+ (emit-ldil segment #x08 (reg-tn-encoding reg)
+ (immed-21-encoding segment value))))
+
+(define-instruction addil (segment value reg)
+ (:declare (type tn reg)
+ (type (or (signed-byte 21) (unsigned-byte 21) fixup) value))
+ (:printer ldil ((op #x0A)))
+ (:emitter
+ (emit-ldil segment #x0A (reg-tn-encoding reg)
+ (immed-21-encoding segment value))))
+
+\f
+;;;; Branch instructions.
+
+(define-bitfield-emitter emit-branch 32
+ (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
+ (byte 11 2) (byte 1 1) (byte 1 0))
+
+(defun label-relative-displacement (label posn &optional delta-if-after)
+ (declare (type label label) (type index posn))
+ (ash (- (if delta-if-after
+ (label-position label posn delta-if-after)
+ (label-position label))
+ (+ posn 8)) -2))
+
+(defun decompose-branch-disp (segment disp)
+ (declare (type (or fixup (signed-byte 17)) disp))
+ (cond ((fixup-p disp)
+ (note-fixup segment :branch disp)
+ (assert (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
+ (values 0 0 0))
+ (t
+ (values (ldb (byte 5 11) disp)
+ (dpb (ldb (byte 10 0) disp)
+ (byte 10 1)
+ (ldb (byte 1 10) disp))
+ (ldb (byte 1 16) disp)))))
+
+(defun emit-relative-branch (segment opcode link sub-opcode target nullify)
+ (declare (type (unsigned-byte 6) opcode)
+ (type (unsigned-byte 5) link)
+ (type (unsigned-byte 1) sub-opcode)
+ (type label target)
+ (type (member t nil) nullify))
+ (emit-back-patch segment 4
+ #'(lambda (segment posn)
+ (let ((disp (label-relative-displacement target posn)))
+ (assert (<= (- (ash 1 16)) disp (1- (ash 1 16))))
+ (multiple-value-bind
+ (w1 w2 w)
+ (decompose-branch-disp segment disp)
+ (emit-branch segment opcode link w1 sub-opcode w2
+ (if nullify 1 0) w))))))
+
+(define-instruction b (segment target &key nullify)
+ (:declare (type label target) (type (member t nil) nullify))
+ (:emitter
+ (emit-relative-branch segment #x3A 0 0 target nullify)))
+
+(define-instruction bl (segment target reg &key nullify)
+ (:declare (type tn reg) (type label target) (type (member t nil) nullify))
+ (:printer branch17 ((op1 #x3A) (op2 0)) '(:name n :tab w "," t))
+ (:emitter
+ (emit-relative-branch segment #x3A (reg-tn-encoding reg) 0 target nullify)))
+
+(define-instruction gateway (segment target reg &key nullify)
+ (:declare (type tn reg) (type label target) (type (member t nil) nullify))
+ (:printer branch17 ((op1 #x3A) (op2 1)) '(:name n :tab w "," t))
+ (:emitter
+ (emit-relative-branch segment #x3A (reg-tn-encoding reg) 1 target nullify)))
+
+;;; BLR is useless because we have no way to generate the offset.
+
+(define-instruction bv (segment base &key nullify offset)
+ (:declare (type tn base)
+ (type (member t nil) nullify)
+ (type (or tn null) offset))
+ (:printer branch ((op1 #x3A) (op2 6)) '(:name n :tab x "(" t ")"))
+ (:emitter
+ (emit-branch segment #x3A (reg-tn-encoding base)
+ (if offset (reg-tn-encoding offset) 0)
+ 6 0 (if nullify 1 0) 0)))
+
+(define-instruction be (segment disp space base &key nullify)
+ (:declare (type (or fixup (signed-byte 17)) disp)
+ (type tn base)
+ (type (unsigned-byte 3) space)
+ (type (member t nil) nullify))
+ (:printer branch17 ((op1 #x38) (op2 nil :type 'im3))
+ '(:name n :tab w "(" op2 "," t ")"))
+ (:emitter
+ (multiple-value-bind
+ (w1 w2 w)
+ (decompose-branch-disp segment disp)
+ (emit-branch segment #x38 (reg-tn-encoding base) w1
+ (space-encoding space) w2 (if nullify 1 0) w))))
+
+(define-instruction ble (segment disp space base &key nullify)
+ (:declare (type (or fixup (signed-byte 17)) disp)
+ (type tn base)
+ (type (unsigned-byte 3) space)
+ (type (member t nil) nullify))
+ (:printer branch17 ((op1 #x39) (op2 nil :type 'im3))
+ '(:name n :tab w "(" op2 "," t ")"))
+ (:emitter
+ (multiple-value-bind
+ (w1 w2 w)
+ (decompose-branch-disp segment disp)
+ (emit-branch segment #x39 (reg-tn-encoding base) w1
+ (space-encoding space) w2 (if nullify 1 0) w))))
+
+(defun emit-conditional-branch (segment opcode r2 r1 cond target nullify)
+ (emit-back-patch segment 4
+ #'(lambda (segment posn)
+ (let ((disp (label-relative-displacement target posn)))
+ (assert (<= (- (ash 1 11)) disp (1- (ash 1 11))))
+ (let ((w1 (logior (ash (ldb (byte 10 0) disp) 1)
+ (ldb (byte 1 10) disp)))
+ (w (ldb (byte 1 11) disp)))
+ (emit-branch segment opcode r2 r1 cond w1 (if nullify 1 0) w))))))
+
+(defun im5-encoding (value)
+ (declare (type (signed-byte 5) value)
+ #+nil (values (unsigned-byte 5)))
+ (dpb (ldb (byte 4 0) value)
+ (byte 4 1)
+ (ldb (byte 1 4) value)))
+
+(macrolet ((define-branch-inst (r-name r-opcode i-name i-opcode cond-kind)
+ (let* ((conditional (symbolicate cond-kind "-CONDITION"))
+ (false-conditional (symbolicate conditional "-FALSE")))
+ `(progn
+ (define-instruction ,r-name (segment cond r1 r2 target &key nullify)
+ (:declare (type ,conditional cond)
+ (type tn r1 r2)
+ (type label target)
+ (type (member t nil) nullify))
+ (:printer branch12 ((op1 ,r-opcode) (c nil :type ',conditional))
+ '(:name c n :tab r1 "," r2 "," w))
+ ,@(unless (= r-opcode #x32)
+ `((:printer branch12 ((op1 ,(+ 2 r-opcode))
+ (c nil :type ',false-conditional))
+ '(:name c n :tab r1 "," r2 "," w))))
+ (:emitter
+ (multiple-value-bind
+ (cond-encoding false)
+ (,conditional cond)
+ (emit-conditional-branch
+ segment (if false ,(+ r-opcode 2) ,r-opcode)
+ (reg-tn-encoding r2) (reg-tn-encoding r1)
+ cond-encoding target nullify))))
+ (define-instruction ,i-name (segment cond imm reg target &key nullify)
+ (:declare (type ,conditional cond)
+ (type (signed-byte 5) imm)
+ (type tn reg)
+ (type (member t nil) nullify))
+ (:printer branch12 ((op1 ,i-opcode) (r1 nil :type 'im5)
+ (c nil :type ',conditional))
+ '(:name c n :tab r1 "," r2 "," w))
+ ,@(unless (= r-opcode #x32)
+ `((:printer branch12 ((op1 ,(+ 2 i-opcode)) (r1 nil :type 'im5)
+ (c nil :type ',false-conditional))
+ '(:name c n :tab r1 "," r2 "," w))))
+ (:emitter
+ (multiple-value-bind
+ (cond-encoding false)
+ (,conditional cond)
+ (emit-conditional-branch
+ segment (if false (+ ,i-opcode 2) ,i-opcode)
+ (reg-tn-encoding reg) (im5-encoding imm)
+ cond-encoding target nullify))))))))
+ (define-branch-inst movb #x32 movib #x33 extract/deposit)
+ (define-branch-inst comb #x20 comib #x21 compare)
+ (define-branch-inst addb #x28 addib #x29 add))
+
+(define-instruction bb (segment cond reg posn target &key nullify)
+ (:declare (type (member t nil) cond nullify)
+ (type tn reg)
+ (type (or (member :variable) (unsigned-byte 5)) posn))
+ (:printer branch12 ((op1 30) (c nil :type 'extract/deposit-condition))
+ '('BVB c n :tab r1 "," w))
+ (:emitter
+ (multiple-value-bind
+ (opcode posn-encoding)
+ (if (eq posn :variable)
+ (values #x30 0)
+ (values #x31 posn))
+ (emit-conditional-branch segment opcode posn-encoding
+ (reg-tn-encoding reg)
+ (if cond 2 6) target nullify))))
+
+\f
+;;;; Computation Instructions
+
+(define-bitfield-emitter emit-r3-inst 32
+ (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
+ (byte 1 12) (byte 7 5) (byte 5 0))
+
+(macrolet ((define-r3-inst (name cond-kind opcode)
+ `(define-instruction ,name (segment r1 r2 res &optional cond)
+ (:declare (type tn res r1 r2))
+ (:printer r3-inst ((op ,opcode) (c nil :type ',(symbolicate
+ cond-kind
+ "-CONDITION"))))
+ ,@(when (= opcode #x12)
+ `((:printer r3-inst ((op ,opcode) (r2 0)
+ (c nil :type ',(symbolicate cond-kind
+ "-CONDITION")))
+ `('COPY :tab r1 "," t))))
+ (:emitter
+ (multiple-value-bind
+ (cond false)
+ (,(symbolicate cond-kind "-CONDITION") cond)
+ (emit-r3-inst segment #x02 (reg-tn-encoding r2) (reg-tn-encoding r1)
+ cond (if false 1 0) ,opcode
+ (reg-tn-encoding res)))))))
+ (define-r3-inst add add #x30)
+ (define-r3-inst addl add #x50)
+ (define-r3-inst addo add #x70)
+ (define-r3-inst addc add #x38)
+ (define-r3-inst addco add #x78)
+ (define-r3-inst sh1add add #x32)
+ (define-r3-inst sh1addl add #x52)
+ (define-r3-inst sh1addo add #x72)
+ (define-r3-inst sh2add add #x34)
+ (define-r3-inst sh2addl add #x54)
+ (define-r3-inst sh2addo add #x74)
+ (define-r3-inst sh3add add #x36)
+ (define-r3-inst sh3addl add #x56)
+ (define-r3-inst sh3addo add #x76)
+ (define-r3-inst sub compare #x20)
+ (define-r3-inst subo compare #x60)
+ (define-r3-inst subb compare #x28)
+ (define-r3-inst subbo compare #x68)
+ (define-r3-inst subt compare #x26)
+ (define-r3-inst subto compare #x66)
+ (define-r3-inst ds compare #x22)
+ (define-r3-inst comclr compare #x44)
+ (define-r3-inst or logical #x12)
+ (define-r3-inst xor logical #x14)
+ (define-r3-inst and logical #x10)
+ (define-r3-inst andcm logical #x00)
+ (define-r3-inst uxor unit #x1C)
+ (define-r3-inst uaddcm unit #x4C)
+ (define-r3-inst uaddcmt unit #x4E)
+ (define-r3-inst dcor unit #x5C)
+ (define-r3-inst idcor unit #x5E))
+
+(define-bitfield-emitter emit-imm-inst 32
+ (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
+ (byte 1 12) (byte 1 11) (byte 11 0))
+
+(defun im11-encoding (value)
+ (declare (type (signed-byte 11) value)
+ #+nil (values (unsigned-byte 11)))
+ (dpb (ldb (byte 10 0) value)
+ (byte 10 1)
+ (ldb (byte 1 10) value)))
+
+(macrolet ((define-imm-inst (name cond-kind opcode subcode)
+ `(define-instruction ,name (segment imm src dst &optional cond)
+ (:declare (type tn dst src)
+ (type (signed-byte 11) imm))
+ (:printer imm-inst ((op ,opcode) (o ,subcode)
+ (c nil :type
+ ',(symbolicate cond-kind "-CONDITION"))))
+ (:emitter
+ (multiple-value-bind
+ (cond false)
+ (,(symbolicate cond-kind "-CONDITION") cond)
+ (emit-imm-inst segment ,opcode (reg-tn-encoding src)
+ (reg-tn-encoding dst) cond
+ (if false 1 0) ,subcode
+ (im11-encoding imm)))))))
+ (define-imm-inst addi add #x2D 0)
+ (define-imm-inst addio add #x2D 1)
+ (define-imm-inst addit add #x2C 0)
+ (define-imm-inst addito add #x2C 1)
+ (define-imm-inst subi compare #x25 0)
+ (define-imm-inst subio compare #x25 1)
+ (define-imm-inst comiclr compare #x24 0))
+
+(define-bitfield-emitter emit-extract/deposit-inst 32
+ (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
+ (byte 3 10) (byte 5 5) (byte 5 0))
+
+(define-instruction shd (segment r1 r2 count res &optional cond)
+ (:declare (type tn res r1 r2)
+ (type (or (member :variable) (integer 0 31)) count))
+ (:printer extract/deposit-inst ((op1 #x34) (op2 2) (t/clen nil :type 'reg))
+ '(:name c :tab r1 "," r2 "," cp "," t/clen))
+ (:printer extract/deposit-inst ((op1 #x34) (op2 0) (t/clen nil :type 'reg))
+ '('VSHD c :tab r1 "," r2 "," t/clen))
+ (:emitter
+ (etypecase count
+ ((member :variable)
+ (emit-extract/deposit-inst segment #x34
+ (reg-tn-encoding r2) (reg-tn-encoding r1)
+ (extract/deposit-condition cond)
+ 0 0 (reg-tn-encoding res)))
+ ((integer 0 31)
+ (emit-extract/deposit-inst segment #x34
+ (reg-tn-encoding r2) (reg-tn-encoding r1)
+ (extract/deposit-condition cond)
+ 2 (- 31 count)
+ (reg-tn-encoding res))))))
+
+(macrolet ((define-extract-inst (name opcode)
+ `(define-instruction ,name (segment src posn len res &optional cond)
+ (:declare (type tn res src)
+ (type (or (member :variable) (integer 0 31)) posn)
+ (type (integer 1 32) len))
+ (:printer extract/deposit-inst ((op1 #x34) (cp nil :type 'integer)
+ (op2 ,opcode))
+ '(:name c :tab r2 "," cp "," t/clen "," r1))
+ (:printer extract/deposit-inst ((op1 #x34) (op2 ,(- opcode 2)))
+ '('V :name c :tab r2 "," t/clen "," r1))
+ (:emitter
+ (etypecase posn
+ ((member :variable)
+ (emit-extract/deposit-inst segment #x34 (reg-tn-encoding src)
+ (reg-tn-encoding res)
+ (extract/deposit-condition cond)
+ ,(- opcode 2) 0 (- 32 len)))
+ ((integer 0 31)
+ (emit-extract/deposit-inst segment #x34 (reg-tn-encoding src)
+ (reg-tn-encoding res)
+ (extract/deposit-condition cond)
+ ,opcode posn (- 32 len))))))))
+ (define-extract-inst extru 6)
+ (define-extract-inst extrs 7))
+
+(macrolet ((define-deposit-inst (name opcode)
+ `(define-instruction ,name (segment src posn len res &optional cond)
+ (:declare (type tn res)
+ (type (or tn (signed-byte 5)) src)
+ (type (or (member :variable) (integer 0 31)) posn)
+ (type (integer 1 32) len))
+ (:printer extract/deposit-inst ((op1 #x35) (op2 ,opcode))
+ ',(let ((base '('VDEP c :tab r1 "," t/clen "," r2)))
+ (if (= opcode 0) (cons ''Z base) base)))
+ (:printer extract/deposit-inst ((op1 #x35) (op2 ,(+ 2 opcode)))
+ ',(let ((base '('DEP c :tab r1 "," cp "," t/clen "," r2)))
+ (if (= opcode 0) (cons ''Z base) base)))
+ (:printer extract/deposit-inst ((op1 #x35) (r1 nil :type 'im5)
+ (op2 ,(+ 4 opcode)))
+ ',(let ((base '('VDEPI c :tab r1 "," t/clen "," r2)))
+ (if (= opcode 0) (cons ''Z base) base)))
+ (:printer extract/deposit-inst ((op1 #x35) (r1 nil :type 'im5)
+ (op2 ,(+ 6 opcode)))
+ ',(let ((base '('DEPI c :tab r1 "," cp "," t/clen "," r2)))
+ (if (= opcode 0) (cons ''Z base) base)))
+ (:emitter
+ (multiple-value-bind
+ (opcode src-encoding)
+ (etypecase src
+ (tn
+ (values ,opcode (reg-tn-encoding src)))
+ ((signed-byte 5)
+ (values ,(+ opcode 4) (im5-encoding src))))
+ (multiple-value-bind
+ (opcode posn-encoding)
+ (etypecase posn
+ ((member :variable)
+ (values opcode 0))
+ ((integer 0 31)
+ (values (+ opcode 2) (- 31 posn))))
+ (emit-extract/deposit-inst segment #x35 (reg-tn-encoding res)
+ src-encoding
+ (extract/deposit-condition cond)
+ opcode posn-encoding (- 32 len))))))))
+
+ (define-deposit-inst dep 1)
+ (define-deposit-inst zdep 0))
+
+
+\f
+;;;; System Control Instructions.
+
+(define-bitfield-emitter emit-break 32
+ (byte 6 26) (byte 13 13) (byte 8 5) (byte 5 0))
+
+(define-instruction break (segment &optional (im5 0) (im13 0))
+ (:declare (type (unsigned-byte 13) im13)
+ (type (unsigned-byte 5) im5))
+ (:printer break () :default :control #'break-control)
+ (:emitter
+ (emit-break segment 0 im13 0 im5)))
+
+(define-bitfield-emitter emit-system-inst 32
+ (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) (byte 8 5) (byte 5 0))
+
+(define-instruction ldsid (segment res base &optional (space 0))
+ (:declare (type tn res base)
+ (type (integer 0 3) space))
+ (:printer system-inst ((op2 #x85) (c nil :type 'space)
+ (s nil :printer #(0 0 1 1 2 2 3 3)))
+ `(:name :tab "(" s r1 ")," r3))
+ (:emitter
+ (emit-system-inst segment 0 (reg-tn-encoding base) 0 (ash space 1) #x85
+ (reg-tn-encoding res))))
+
+(define-instruction mtsp (segment reg space)
+ (:declare (type tn reg) (type (integer 0 7) space))
+ (:printer system-inst ((op2 #xC1)) '(:name :tab r2 "," s))
+ (:emitter
+ (emit-system-inst segment 0 0 (reg-tn-encoding reg) (space-encoding space)
+ #xC1 0)))
+
+(define-instruction mfsp (segment space reg)
+ (:declare (type tn reg) (type (integer 0 7) space))
+ (:printer system-inst ((op2 #x25) (c nil :type 'space)) '(:name :tab s r3))
+ (:emitter
+ (emit-system-inst segment 0 0 0 (space-encoding space) #x25
+ (reg-tn-encoding reg))))
+
+(deftype control-reg ()
+ '(or (unsigned-byte 5) (member :sar)))
+
+(defun control-reg (reg)
+ (declare (type control-reg reg)
+ #+nil (values (unsigned-byte 32)))
+ (if (typep reg '(unsigned-byte 5))
+ reg
+ (ecase reg
+ (:sar 11))))
+
+(define-instruction mtctl (segment reg ctrl-reg)
+ (:declare (type tn reg) (type control-reg ctrl-reg))
+ (:printer system-inst ((op2 #xC2)) '(:name :tab r2 "," r1))
+ (:emitter
+ (emit-system-inst segment 0 (control-reg ctrl-reg) (reg-tn-encoding reg)
+ 0 #xC2 0)))
+
+(define-instruction mfctl (segment ctrl-reg reg)
+ (:declare (type tn reg) (type control-reg ctrl-reg))
+ (:printer system-inst ((op2 #x45)) '(:name :tab r1 "," r3))
+ (:emitter
+ (emit-system-inst segment 0 (control-reg ctrl-reg) 0 0 #x45
+ (reg-tn-encoding reg))))
+
+
+\f
+;;;; Floating point instructions.
+
+(define-bitfield-emitter emit-fp-load/store 32
+ (byte 6 26) (byte 5 21) (byte 5 16) (byte 2 14) (byte 1 13) (byte 1 12)
+ (byte 2 10) (byte 1 9) (byte 3 6) (byte 1 5) (byte 5 0))
+
+(define-instruction fldx (segment index base result &key modify scale side)
+ (:declare (type tn index base result)
+ (type (member t nil) modify scale)
+ (type (member nil 0 1) side))
+ (:printer fp-load/store ((op #x0b) (x1 0) (x2 0) (x3 0))
+ `('FLDDX ,@cmplt-index-print :tab x "(" s b ")" "," t))
+ (:printer fp-load/store ((op #x09) (x1 0) (x2 0) (x3 0))
+ `('FLDWX ,@cmplt-index-print :tab x "(" s b ")" "," t))
+ (:emitter
+ (multiple-value-bind
+ (result-encoding double-p)
+ (fp-reg-tn-encoding result)
+ (when side
+ (assert double-p)
+ (setf double-p nil))
+ (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
+ (reg-tn-encoding index) 0 (if scale 1 0) 0 0 0
+ (or side 0) (if modify 1 0) result-encoding))))
+
+(define-instruction fstx (segment value index base &key modify scale side)
+ (:declare (type tn index base value)
+ (type (member t nil) modify scale)
+ (type (member nil 0 1) side))
+ (:printer fp-load/store ((op #x0b) (x1 0) (x2 0) (x3 1))
+ `('FSTDX ,@cmplt-index-print :tab t "," x "(" s b ")"))
+ (:printer fp-load/store ((op #x09) (x1 0) (x2 0) (x3 1))
+ `('FSTWX ,@cmplt-index-print :tab t "," x "(" s b ")"))
+ (:emitter
+ (multiple-value-bind
+ (value-encoding double-p)
+ (fp-reg-tn-encoding value)
+ (when side
+ (assert double-p)
+ (setf double-p nil))
+ (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
+ (reg-tn-encoding index) 0 (if scale 1 0) 0 0 1
+ (or side 0) (if modify 1 0) value-encoding))))
+
+(define-instruction flds (segment disp base result &key modify side)
+ (:declare (type tn base result)
+ (type (signed-byte 5) disp)
+ (type (member :before :after nil) modify)
+ (type (member nil 0 1) side))
+ (:printer fp-load/store ((op #x0b) (x nil :type 'im5) (x1 1) (x2 0) (x3 0))
+ `('FLDDS ,@cmplt-disp-print :tab x "(" s b ")," t))
+ (:printer fp-load/store ((op #x09) (x nil :type 'im5) (x1 1) (x2 0) (x3 0))
+ `('FLDWS ,@cmplt-disp-print :tab x "(" s b ")," t))
+ (:emitter
+ (multiple-value-bind
+ (result-encoding double-p)
+ (fp-reg-tn-encoding result)
+ (when side
+ (assert double-p)
+ (setf double-p nil))
+ (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
+ (short-disp-encoding segment disp) 0
+ (if (eq modify :before) 1 0) 1 0 0
+ (or side 0) (if modify 1 0) result-encoding))))
+
+(define-instruction fsts (segment value disp base &key modify side)
+ (:declare (type tn base value)
+ (type (signed-byte 5) disp)
+ (type (member :before :after nil) modify)
+ (type (member nil 0 1) side))
+ (:printer fp-load/store ((op #x0b) (x nil :type 'im5) (x1 1) (x2 0) (x3 1))
+ `('FSTDS ,@cmplt-disp-print :tab t "," x "(" s b ")"))
+ (:printer fp-load/store ((op #x09) (x nil :type 'im5) (x1 1) (x2 0) (x3 1))
+ `('FSTWS ,@cmplt-disp-print :tab t "," x "(" s b ")"))
+ (:emitter
+ (multiple-value-bind
+ (value-encoding double-p)
+ (fp-reg-tn-encoding value)
+ (when side
+ (assert double-p)
+ (setf double-p nil))
+ (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
+ (short-disp-encoding segment disp) 0
+ (if (eq modify :before) 1 0) 1 0 1
+ (or side 0) (if modify 1 0) value-encoding))))
+
+
+(define-bitfield-emitter emit-fp-class-0-inst 32
+ (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) (byte 2 11) (byte 2 9)
+ (byte 3 6) (byte 1 5) (byte 5 0))
+
+(define-bitfield-emitter emit-fp-class-1-inst 32
+ (byte 6 26) (byte 5 21) (byte 4 17) (byte 2 15) (byte 2 13) (byte 2 11)
+ (byte 2 9) (byte 3 6) (byte 1 5) (byte 5 0))
+
+;;; Note: classes 2 and 3 are similar enough to class 0 that we don't need
+;;; seperate emitters.
+
+(defconstant-eqx funops '(:copy :abs :sqrt :rnd)
+ #'equalp)
+
+(deftype funop ()
+ `(member ,@funops))
+
+(define-instruction funop (segment op from to)
+ (:declare (type funop op)
+ (type tn from to))
+ (:printer fp-class-0-inst ((op1 #x0C) (op2 2) (x2 0))
+ '('FCPY fmt :tab r "," t))
+ (:printer fp-class-0-inst ((op1 #x0C) (op2 3) (x2 0))
+ '('FABS fmt :tab r "," t))
+ (:printer fp-class-0-inst ((op1 #x0C) (op2 4) (x2 0))
+ '('FSQRT fmt :tab r "," t))
+ (:printer fp-class-0-inst ((op1 #x0C) (op2 5) (x2 0))
+ '('FRND fmt :tab r "," t))
+ (:emitter
+ (multiple-value-bind
+ (from-encoding from-double-p)
+ (fp-reg-tn-encoding from)
+ (multiple-value-bind
+ (to-encoding to-double-p)
+ (fp-reg-tn-encoding to)
+ (assert (eq from-double-p to-double-p))
+ (emit-fp-class-0-inst segment #x0C from-encoding 0
+ (+ 2 (or (position op funops)
+ (error "Bogus FUNOP: ~S" op)))
+ (if to-double-p 1 0) 0 0 0 to-encoding)))))
+
+(macrolet ((define-class-1-fp-inst (name subcode)
+ `(define-instruction ,name (segment from to)
+ (:declare (type tn from to))
+ (:printer fp-class-1-inst ((op1 #x0C) (x2 ,subcode))
+ '(:name sf df :tab r "," t))
+ (:emitter
+ (multiple-value-bind
+ (from-encoding from-double-p)
+ (fp-reg-tn-encoding from)
+ (multiple-value-bind
+ (to-encoding to-double-p)
+ (fp-reg-tn-encoding to)
+ (emit-fp-class-1-inst segment #x0C from-encoding 0 ,subcode
+ (if to-double-p 1 0) (if from-double-p 1 0)
+ 1 0 0 to-encoding)))))))
+
+ (define-class-1-fp-inst fcnvff 0)
+ (define-class-1-fp-inst fcnvxf 1)
+ (define-class-1-fp-inst fcnvfx 2)
+ (define-class-1-fp-inst fcnvfxt 3))
+
+(define-instruction fcmp (segment cond r1 r2)
+ (:declare (type (unsigned-byte 5) cond)
+ (type tn r1 r2))
+ (:printer fp-class-0-inst ((op1 #x0C) (op2 0) (x2 2) (t nil :type 'fcmp-cond))
+ '(:name fmt t :tab r "," x1))
+ (:emitter
+ (multiple-value-bind
+ (r1-encoding r1-double-p)
+ (fp-reg-tn-encoding r1)
+ (multiple-value-bind
+ (r2-encoding r2-double-p)
+ (fp-reg-tn-encoding r2)
+ (assert (eq r1-double-p r2-double-p))
+ (emit-fp-class-0-inst segment #x0C r1-encoding r2-encoding 0
+ (if r1-double-p 1 0) 2 0 0 cond)))))
+
+(define-instruction ftest (segment)
+ (:printer fp-class-0-inst ((op1 #x0c) (op2 1) (x2 2)) '(:name))
+ (:emitter
+ (emit-fp-class-0-inst segment #x0C 0 0 1 0 2 0 1 0)))
+
+(defconstant-eqx fbinops '(:add :sub :mpy :div)
+ #'equalp)
+
+(deftype fbinop ()
+ `(member ,@fbinops))
+
+(define-instruction fbinop (segment op r1 r2 result)
+ (:declare (type fbinop op)
+ (type tn r1 r2 result))
+ (:printer fp-class-0-inst ((op1 #x0C) (op2 0) (x2 3))
+ '('FADD fmt :tab r "," x1 "," t))
+ (:printer fp-class-0-inst ((op1 #x0C) (op2 1) (x2 3))
+ '('FSUB fmt :tab r "," x1 "," t))
+ (:printer fp-class-0-inst ((op1 #x0C) (op2 2) (x2 3))
+ '('FMPY fmt :tab r "," x1 "," t))
+ (:printer fp-class-0-inst ((op1 #x0C) (op2 3) (x2 3))
+ '('FDIV fmt :tab r "," x1 "," t))
+ (:emitter
+ (multiple-value-bind
+ (r1-encoding r1-double-p)
+ (fp-reg-tn-encoding r1)
+ (multiple-value-bind
+ (r2-encoding r2-double-p)
+ (fp-reg-tn-encoding r2)
+ (assert (eq r1-double-p r2-double-p))
+ (multiple-value-bind
+ (result-encoding result-double-p)
+ (fp-reg-tn-encoding result)
+ (assert (eq r1-double-p result-double-p))
+ (emit-fp-class-0-inst segment #x0C r1-encoding r2-encoding
+ (or (position op fbinops)
+ (error "Bogus FBINOP: ~S" op))
+ (if r1-double-p 1 0) 3 0 0
+ result-encoding))))))
+
+
+\f
+;;;; Instructions built out of other insts.
+
+(define-instruction-macro move (src dst &optional cond)
+ `(inst or ,src zero-tn ,dst ,cond))
+
+(define-instruction-macro nop (&optional cond)
+ `(inst or zero-tn zero-tn zero-tn ,cond))
+
+(define-instruction li (segment value reg)
+ (:declare (type tn reg)
+ (type (or fixup (signed-byte 32) (unsigned-byte 32)) value))
+ (:vop-var vop)
+ (:emitter
+ (assemble (segment vop)
+ (etypecase value
+ (fixup
+ (inst ldil value reg)
+ (inst ldo value reg reg))
+ ((signed-byte 14)
+ (inst ldo value zero-tn reg))
+ ((or (signed-byte 32) (unsigned-byte 32))
+ (let ((hi (ldb (byte 21 11) value))
+ (lo (ldb (byte 11 0) value)))
+ (inst ldil hi reg)
+ (unless (zerop lo)
+ (inst ldo lo reg reg))))))))
+
+(define-instruction-macro sll (src count result &optional cond)
+ (once-only ((result result) (src src) (count count) (cond cond))
+ `(inst zdep ,src (- 31 ,count) (- 32 ,count) ,result ,cond)))
+
+(define-instruction-macro sra (src count result &optional cond)
+ (once-only ((result result) (src src) (count count) (cond cond))
+ `(inst extrs ,src (- 31 ,count) (- 32 ,count) ,result ,cond)))
+
+(define-instruction-macro srl (src count result &optional cond)
+ (once-only ((result result) (src src) (count count) (cond cond))
+ `(inst extru ,src (- 31 ,count) (- 32 ,count) ,result ,cond)))
+
+(defun maybe-negate-cond (cond negate)
+ (if negate
+ (multiple-value-bind
+ (value negate)
+ (compare-condition cond)
+ (if negate
+ (nth value compare-conditions)
+ (nth (+ value 8) compare-conditions)))
+ cond))
+
+(define-instruction bc (segment cond not-p r1 r2 target)
+ (:declare (type compare-condition cond)
+ (type (member t nil) not-p)
+ (type tn r1 r2)
+ (type label target))
+ (:vop-var vop)
+ (:emitter
+ (emit-chooser segment 8 2
+ #'(lambda (segment posn delta)
+ (let ((disp (label-relative-displacement target posn delta)))
+ (when (<= 0 disp (1- (ash 1 11)))
+ (assemble (segment vop)
+ (inst comb (maybe-negate-cond cond not-p) r1 r2 target
+ :nullify t))
+ t)))
+ #'(lambda (segment posn)
+ (let ((disp (label-relative-displacement target posn)))
+ (assemble (segment vop)
+ (cond ((<= (- (ash 1 11)) disp (1- (ash 1 11)))
+ (inst comb (maybe-negate-cond cond not-p) r1 r2 target)
+ (inst nop))
+ (t
+ (inst comclr r1 r2 zero-tn
+ (maybe-negate-cond cond (not not-p)))
+ (inst b target :nullify t)))))))))
+
+(define-instruction bci (segment cond not-p imm reg target)
+ (:declare (type compare-condition cond)
+ (type (member t nil) not-p)
+ (type (signed-byte 11) imm)
+ (type tn reg)
+ (type label target))
+ (:vop-var vop)
+ (:emitter
+ (emit-chooser segment 8 2
+ #'(lambda (segment posn delta-if-after)
+ (let ((disp (label-relative-displacement target posn delta-if-after)))
+ (when (and (<= 0 disp (1- (ash 1 11)))
+ (<= (- (ash 1 4)) imm (1- (ash 1 4))))
+ (assemble (segment vop)
+ (inst comib (maybe-negate-cond cond not-p) imm reg target
+ :nullify t))
+ t)))
+ #'(lambda (segment posn)
+ (let ((disp (label-relative-displacement target posn)))
+ (assemble (segment vop)
+ (cond ((and (<= (- (ash 1 11)) disp (1- (ash 1 11)))
+ (<= (- (ash 1 4)) imm (1- (ash 1 4))))
+ (inst comib (maybe-negate-cond cond not-p) imm reg target)
+ (inst nop))
+ (t
+ (inst comiclr imm reg zero-tn
+ (maybe-negate-cond cond (not not-p)))
+ (inst b target :nullify t)))))))))
+
+\f
+;;;; Instructions to convert between code ptrs, functions, and lras.
+
+(defun emit-compute-inst (segment vop src label temp dst calc)
+ (emit-chooser
+ ;; We emit either 12 or 4 bytes, so we maintain 3 byte alignments.
+ segment 12 3
+ #'(lambda (segment posn delta-if-after)
+ (let ((delta (funcall calc label posn delta-if-after)))
+ (when (<= (- (ash 1 10)) delta (1- (ash 1 10)))
+ (emit-back-patch segment 4
+ #'(lambda (segment posn)
+ (assemble (segment vop)
+ (inst addi (funcall calc label posn 0) src
+ dst))))
+ t)))
+ #'(lambda (segment posn)
+ (let ((delta (funcall calc label posn 0)))
+ ;; Note: if we used addil/ldo to do this in 2 instructions then the
+ ;; intermediate value would be tagged but pointing into space.
+ (assemble (segment vop)
+ (inst ldil (ldb (byte 21 11) delta) temp)
+ (inst ldo (ldb (byte 11 0) delta) temp temp)
+ (inst add src temp dst))))))
+
+;; code = fn - header - label-offset + other-pointer-tag
+(define-instruction compute-code-from-fn (segment src label temp dst)
+ (:declare (type tn src dst temp)
+ (type label label))
+ (:vop-var vop)
+ (:emitter
+ (emit-compute-inst segment vop src label temp dst
+ #'(lambda (label posn delta-if-after)
+ (- other-pointer-lowtag
+ (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 src label temp dst)
+ (:declare (type tn src dst temp)
+ (type label label))
+ (:vop-var vop)
+ (:emitter
+ (emit-compute-inst segment vop src label temp dst
+ #'(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 src label temp dst)
+ (:declare (type tn src dst temp)
+ (type label label))
+ (:vop-var vop)
+ (:emitter
+ (emit-compute-inst segment vop src label temp dst
+ #'(lambda (label posn delta-if-after)
+ (+ (label-position label posn delta-if-after)
+ (component-header-length))))))
+
+\f
+;;;; Data instructions.
+
+(define-instruction byte (segment byte)
+ (:emitter
+ (emit-byte segment byte)))
+
+(define-bitfield-emitter emit-halfword 16
+ (byte 16 0))
+
+(define-instruction halfword (segment halfword)
+ (:emitter
+ (emit-halfword segment halfword)))
+
+(define-bitfield-emitter emit-word 32
+ (byte 32 0))
+
+(define-instruction word (segment word)
+ (:emitter
+ (emit-word segment word)))
+
+(define-instruction fun-header-word (segment)
+ (:emitter
+ (emit-back-patch
+ segment 4
+ #'(lambda (segment posn)
+ (emit-word segment
+ (logior simple-fun-header-widetag
+ (ash (+ posn (component-header-length))
+ (- n-widetag-bits word-shift))))))))
+
+(define-instruction lra-header-word (segment)
+ (:emitter
+ (emit-back-patch
+ segment 4
+ #'(lambda (segment posn)
+ (emit-word segment
+ (logior return-pc-header-widetag
+ (ash (+ posn (component-header-length))
+ (- n-widetag-bits word-shift))))))))
--- /dev/null
+(in-package "SB!VM")
+
+\f
+;;; Instruction-like macros.
+
+(defmacro move (src dst)
+ "Move SRC into DST unless they are location=."
+ (once-only ((src src) (dst dst))
+ `(unless (location= ,src ,dst)
+ (inst move ,src ,dst))))
+
+(defmacro loadw (result base &optional (offset 0) (lowtag 0))
+ (once-only ((result result) (base base))
+ `(inst ldw (- (ash ,offset word-shift) ,lowtag) ,base ,result)))
+
+(defmacro storew (value base &optional (offset 0) (lowtag 0))
+ (once-only ((value value) (base base) (offset offset) (lowtag lowtag))
+ `(inst stw ,value (- (ash ,offset word-shift) ,lowtag) ,base)))
+
+(defmacro load-symbol (reg symbol)
+ (once-only ((reg reg) (symbol symbol))
+ `(inst addi (static-symbol-offset ,symbol) null-tn ,reg)))
+
+(defmacro load-symbol-value (reg symbol)
+ `(inst ldw
+ (+ (static-symbol-offset ',symbol)
+ (ash symbol-value-slot word-shift)
+ (- other-pointer-lowtag))
+ null-tn
+ ,reg))
+
+(defmacro store-symbol-value (reg symbol)
+ `(inst stw ,reg (+ (static-symbol-offset ',symbol)
+ (ash symbol-value-slot word-shift)
+ (- other-pointer-lowtag))
+ null-tn))
+
+(defmacro load-type (target source &optional (offset 0))
+ "Loads the type bits of a pointer into target independent of
+ byte-ordering issues."
+ (ecase *backend-byte-order*
+ (:little-endian
+ `(inst ldb ,offset ,source ,target))
+ (:big-endian
+ `(inst ldb (+ ,offset 3) ,source ,target))))
+
+;;; Macros to handle the fact that we cannot use the machine native call and
+;;; return instructions.
+
+(defmacro lisp-jump (function)
+ "Jump to the lisp function FUNCTION. LIP is an interior-reg temporary."
+ `(progn
+ (inst addi
+ (- (ash simple-fun-code-offset word-shift) fun-pointer-lowtag)
+ ,function
+ lip-tn)
+ (inst bv lip-tn)
+ (move ,function code-tn)))
+
+(defmacro lisp-return (return-pc &key (offset 0) (frob-code t))
+ "Return to RETURN-PC."
+ `(progn
+ (inst addi (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag)
+ ,return-pc lip-tn)
+ (inst bv lip-tn ,@(unless frob-code '(:nullify t)))
+ ,@(when frob-code
+ `((move ,return-pc code-tn)))))
+
+(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-stack ,n-reg))
+ ((control-stack)
+ (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
+
+\f
+;;;; Storage allocation:
+
+(defmacro with-fixed-allocation ((result-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)
+ (type-code type-code) (size size))
+ `(pseudo-atomic (:extra (pad-data-block ,size))
+ (inst move alloc-tn ,result-tn)
+ (inst dep other-pointer-lowtag 31 3 ,result-tn)
+ (inst li (logior (ash (1- ,size) n-widetag-bits) ,type-code) ,temp-tn)
+ (storew ,temp-tn ,result-tn 0 other-pointer-lowtag)
+ ,@body)))
+
+\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))))
+ (declare (type (vector (unsigned-byte 8) 16) ,var))
+ (setf (fill-pointer ,var) 0)
+ (unwind-protect
+ (progn
+ ,@body)
+ (push ,var *adjustable-vectors*))))
+
+(eval-when (compile load eval)
+ (defun emit-error-break (vop kind code values)
+ (let ((vector (gensym)))
+ `((let ((vop ,vop))
+ (when vop
+ (note-this-location vop :internal-error)))
+ (inst break ,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
+ (inst b ,label)
+ ,@(emit-error-break vop cerror-trap error-code values)))
+
+(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.
+;;;
+(defmacro pseudo-atomic ((&key (extra 0)) &rest forms)
+ (let ((n-extra (gensym)))
+ `(let ((,n-extra ,extra))
+ (inst addi 4 alloc-tn alloc-tn)
+ ,@forms
+ (inst addit (- ,n-extra 4) alloc-tn alloc-tn :od))))
+
+
+\f
+;;;; Indexed references:
+
+(deftype load/store-index (scale lowtag min-offset
+ &optional (max-offset min-offset))
+ `(integer ,(- (truncate (+ (ash 1 14)
+ (* min-offset n-word-bytes)
+ (- lowtag))
+ scale))
+ ,(truncate (- (+ (1- (ash 1 14)) lowtag)
+ (* max-offset n-word-bytes))
+ scale)))
+
+(defmacro define-full-reffer (name type offset lowtag scs el-type
+ &optional translate)
+ `(progn
+ (define-vop (,name)
+ ,@(when translate
+ `((:translate ,translate)))
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg) :to (:eval 0))
+ (index :scs (any-reg) :target temp))
+ (:arg-types ,type tagged-num)
+ (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp)
+ (:results (value :scs ,scs))
+ (:result-types ,el-type)
+ (:generator 5
+ (inst addi (- (* ,offset n-word-bytes) ,lowtag) index temp)
+ (inst ldwx temp object value)))
+ (define-vop (,(symbolicate name "-C"))
+ ,@(when translate
+ `((:translate ,translate)))
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg)))
+ (:info index)
+ (:arg-types ,type
+ (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
+ ,(eval offset))))
+ (:results (value :scs ,scs))
+ (:result-types ,el-type)
+ (:generator 4
+ (inst ldw (- (* (+ ,offset index) n-word-bytes) ,lowtag)
+ object value)))))
+
+(defmacro define-full-setter (name type offset lowtag scs el-type
+ &optional translate)
+ `(progn
+ (define-vop (,name)
+ ,@(when translate
+ `((:translate ,translate)))
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (any-reg))
+ (value :scs ,scs :target result))
+ (:arg-types ,type tagged-num ,el-type)
+ (:temporary (:scs (interior-reg)) lip)
+ (:results (result :scs ,scs))
+ (:result-types ,el-type)
+ (:generator 2
+ (inst add object index lip)
+ (inst stw value (- (* ,offset n-word-bytes) ,lowtag) lip)
+ (move value result)))
+ (define-vop (,(symbolicate name "-C"))
+ ,@(when translate
+ `((:translate ,translate)))
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (value :scs ,scs))
+ (:info index)
+ (:arg-types ,type
+ (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
+ ,(eval offset)))
+ ,el-type)
+ (:results (result :scs ,scs))
+ (:result-types ,el-type)
+ (:generator 1
+ (inst stw value (- (* (+ ,offset index) n-word-bytes) ,lowtag) object)
+ (move value result)))))
+
+
+(defmacro define-partial-reffer (name type size signed offset lowtag scs
+ el-type &optional translate)
+ (let ((scale (ecase size (:byte 1) (:short 2))))
+ `(progn
+ (define-vop (,name)
+ ,@(when translate
+ `((:translate ,translate)))
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg) :to (:eval 0))
+ (index :scs (unsigned-reg)))
+ (:arg-types ,type positive-fixnum)
+ (:results (value :scs ,scs))
+ (:result-types ,el-type)
+ (:temporary (:scs (interior-reg)) lip)
+ (:generator 5
+ (inst ,(ecase size (:byte 'add) (:short 'sh1add))
+ index object lip)
+ (inst ,(ecase size (:byte 'ldb) (:short 'ldh))
+ (- (* ,offset n-word-bytes) ,lowtag) lip value)
+ ,@(when signed
+ `((inst extrs value 31 ,(* scale n-byte-bits) value)))))
+ (define-vop (,(symbolicate name "-C"))
+ ,@(when translate
+ `((:translate ,translate)))
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg)))
+ (:info index)
+ (:arg-types ,type
+ (:constant (load/store-index ,scale
+ ,(eval lowtag)
+ ,(eval offset))))
+ (:results (value :scs ,scs))
+ (:result-types ,el-type)
+ (:generator 5
+ (inst ,(ecase size (:byte 'ldb) (:short 'ldh))
+ (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag)
+ object value)
+ ,@(when signed
+ `((inst extrs value 31 ,(* scale n-byte-bits) value))))))))
+
+(defmacro define-partial-setter (name type size offset lowtag scs el-type
+ &optional translate)
+ (let ((scale (ecase size (:byte 1) (:short 2))))
+ `(progn
+ (define-vop (,name)
+ ,@(when translate
+ `((:translate ,translate)))
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (unsigned-reg))
+ (value :scs ,scs :target result))
+ (:arg-types ,type positive-fixnum ,el-type)
+ (:temporary (:scs (interior-reg)) lip)
+ (:results (result :scs ,scs))
+ (:result-types ,el-type)
+ (:generator 5
+ (inst ,(ecase size (:byte 'add) (:short 'sh1add))
+ index object lip)
+ (inst ,(ecase size (:byte 'stb) (:short 'sth))
+ value (- (* ,offset n-word-bytes) ,lowtag) lip)
+ (move value result)))
+ (define-vop (,(symbolicate name "-C"))
+ ,@(when translate
+ `((:translate ,translate)))
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (value :scs ,scs :target result))
+ (:info index)
+ (:arg-types ,type
+ (:constant (load/store-index ,scale
+ ,(eval lowtag)
+ ,(eval offset)))
+ ,el-type)
+ (:results (result :scs ,scs))
+ (:result-types ,el-type)
+ (:generator 5
+ (inst ,(ecase size (:byte 'stb) (:short 'sth))
+ value
+ (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag)
+ object)
+ (move value result))))))
+
--- /dev/null
+(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. Cell-Setf is similar to
+;;; Cell-Set, but delivers the new value as the result. Cell-Setf-Function
+;;; takes its arguments as if it were a setf function (new value first, as
+;;; apposed to a setf macro, which takes the new value last).
+;;;
+(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 1
+ (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 stardard 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 1
+ (storew value object (+ base offset) lowtag)))
+
--- /dev/null
+(in-package "SB!VM")
+
+(define-move-fun (load-immediate 1) (vop x y)
+ ((null zero immediate)
+ (any-reg descriptor-reg))
+ (let ((val (tn-value x)))
+ (etypecase val
+ (integer
+ (inst li (fixnumize val) y))
+ (null
+ (move null-tn y))
+ (symbol
+ (load-symbol y val))
+ (character
+ (inst li (logior (ash (char-code val) n-widetag-bits)
+ base-char-widetag)
+ y)))))
+
+(define-move-fun (load-number 1) (vop x y)
+ ((immediate zero)
+ (signed-reg unsigned-reg))
+ (let ((x (tn-value x)))
+ (inst li (if (>= x (ash 1 31)) (logior (ash -1 32) x) x) y)))
+
+(define-move-fun (load-base-char 1) (vop x y)
+ ((immediate) (base-char-reg))
+ (inst li (char-code (tn-value x)) y))
+
+(define-move-fun (load-system-area-pointer 1) (vop x y)
+ ((immediate) (sap-reg))
+ (inst li (sap-int (tn-value x)) y))
+
+(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)
+ :load-if (not (location= x y))))
+ (:results (y :scs (any-reg descriptor-reg)
+ :load-if (not (location= x y))))
+ (:effects)
+ (:affected)
+ (:generator 0
+ (move x y)))
+
+(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-argument)
+ (:args (x :target y
+ :scs (any-reg descriptor-reg))
+ (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 x y))
+ (control-stack
+ (storew x fp (tn-offset y))))))
+;;;
+(define-move-vop move-argument :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 sra x 2 y)))
+;;;
+(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 li (tn-value x) y)))
+;;;
+(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")
+ (:generator 3
+ (inst extru x 31 2 zero-tn :<>)
+ (inst sra x 2 y :tr)
+ (loadw y x bignum-digits-offset other-pointer-lowtag)))
+;;;
+(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 sll x 2 y)))
+;;;
+(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 (x :scs (signed-reg unsigned-reg) :to (:eval 1)))
+ (:results (y :scs (any-reg descriptor-reg) :from (:eval 0)))
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:note "signed word to integer coercion")
+ (:generator 18
+ ;; Extract the top three bits.
+ (inst extrs x 2 3 temp :=)
+ ;; Invert them (unless they are already zero).
+ (inst uaddcm zero-tn temp temp)
+ ;; If we are left with zero, it will fit in a fixnum. So branch around
+ ;; the bignum-construction, doing the shift in the delay slot.
+ (inst comb := temp zero-tn done)
+ (inst sll x 2 y)
+ ;; Make a single-digit bignum.
+ (with-fixed-allocation (y temp bignum-widetag (1+ bignum-digits-offset))
+ (storew x y bignum-digits-offset other-pointer-lowtag))
+ 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 (x :scs (signed-reg unsigned-reg) :to (:eval 1)))
+ (:results (y :scs (any-reg descriptor-reg) :from (:eval 0)))
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:note "unsigned word to integer coercion")
+ (:generator 20
+ ;; Grab the top three bits.
+ (inst extrs x 2 3 temp)
+ ;; If zero, it will fit as a fixnum.
+ (inst comib := 0 temp done)
+ (inst sll x 2 y)
+ ;; Make a bignum.
+ (pseudo-atomic (:extra (pad-data-block (1+ bignum-digits-offset)))
+ ;; Create the result pointer.
+ (inst move alloc-tn y)
+ (inst dep other-pointer-lowtag 31 3 y)
+ ;; Check the high bit, and skip the next instruction it it's 0.
+ (inst comclr x zero-tn zero-tn :>=)
+ ;; The high bit is set, so allocate enough space for a two-word bignum.
+ ;; We always skip the following instruction, so it is only executed
+ ;; when we want one word.
+ (inst addi (pad-data-block 1) alloc-tn alloc-tn :tr)
+ ;; Set up the header for one word. Use addi instead of li so we can
+ ;; skip the next instruction.
+ (inst addi (logior (ash 1 n-widetag-bits) bignum-widetag) zero-tn temp :tr)
+ ;; Set up the header for two words.
+ (inst li (logior (ash 2 n-widetag-bits) bignum-widetag) temp)
+ ;; Store the header and the data.
+ (storew temp y 0 other-pointer-lowtag)
+ (storew x y bignum-digits-offset other-pointer-lowtag))
+ 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 x y)))
+;;;
+(define-move-vop word-move :move
+ (signed-reg unsigned-reg) (signed-reg unsigned-reg))
+
+
+;;; Move untagged number arguments/return-values.
+;;;
+(define-vop (move-word-argument)
+ (: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 x y))
+ ((signed-stack unsigned-stack)
+ (storew x fp (tn-offset y))))))
+;;;
+(define-move-vop move-word-argument :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-argument :move-arg
+ (signed-reg unsigned-reg) (any-reg descriptor-reg))
--- /dev/null
+(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-Argument-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)))
+ (:vop-var vop)
+ (:generator 13
+ (load-symbol-value catch *current-catch-block*)
+ (let ((cur-nfp (current-nfp-tn vop)))
+ (when cur-nfp
+ (move cur-nfp nfp)))
+ (move nsp-tn nsp)))
+
+(define-vop (restore-dynamic-state)
+ (:args (catch :scs (descriptor-reg))
+ (nfp :scs (descriptor-reg))
+ (nsp :scs (descriptor-reg)))
+ (:vop-var vop)
+ (:generator 10
+ (store-symbol-value catch *current-catch-block*)
+ (let ((cur-nfp (current-nfp-tn vop)))
+ (when cur-nfp
+ (move nfp cur-nfp)))
+ (move nsp nsp-tn)))
+
+(define-vop (current-stack-pointer)
+ (:results (res :scs (any-reg descriptor-reg)))
+ (:generator 1
+ (move csp-tn res)))
+
+(define-vop (current-binding-pointer)
+ (:results (res :scs (any-reg descriptor-reg)))
+ (:generator 1
+ (move bsp-tn res)))
+
+\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 (* (tn-offset tn) n-word-bytes) cfp-tn block)
+ (load-symbol-value temp *current-unwind-protect-block*)
+ (storew temp block unwind-block-current-uwp-slot)
+ (storew cfp-tn block unwind-block-current-cont-slot)
+ (storew code-tn block unwind-block-current-code-slot)
+ (inst compute-lra-from-code code-tn entry-label ndescr temp)
+ (storew temp block 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 (descriptor-reg)))
+ (:info entry-label)
+ (:results (block :scs (any-reg) :from (:argument 0)))
+ (:temporary (:scs (descriptor-reg)) temp)
+ (:temporary (:scs (non-descriptor-reg)) ndescr)
+ (:generator 44
+ (inst addi (* (tn-offset tn) n-word-bytes) cfp-tn block)
+ (load-symbol-value temp *current-unwind-protect-block*)
+ (storew temp block catch-block-current-uwp-slot)
+ (storew cfp-tn block catch-block-current-cont-slot)
+ (storew code-tn block catch-block-current-code-slot)
+ (inst compute-lra-from-code code-tn entry-label ndescr temp)
+ (storew temp block catch-block-entry-pc-slot)
+
+ (storew tag block catch-block-tag-slot)
+ (load-symbol-value temp *current-catch-block*)
+ (storew temp block catch-block-previous-catch-slot)
+ (store-symbol-value block *current-catch-block*)))
+
+
+;;; 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 (* (tn-offset tn) n-word-bytes) cfp-tn new-uwp)
+ (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 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 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)
+ (inst comclr count zero-tn zero-tn :<>)
+ (inst move null-tn (tn-ref-tn values) :tr)
+ (loadw (tn-ref-tn values) start))
+ (t
+ (collect ((defaults))
+ (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 bci := nil (fixnumize i) count 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)))))
+
+ (let ((defaulting-done (gen-label)))
+ (emit-label defaulting-done)
+
+ (assemble (*elsewhere*)
+ (do ((defs (defaults) (cdr defs)))
+ ((null defs))
+ (let ((def (car defs)))
+ (emit-label (car def))
+ (unless (cdr defs)
+ (inst b defaulting-done))
+ (let ((tn (cdr def)))
+ (sc-case tn
+ ((descriptor-reg any-reg)
+ (move null-tn tn))
+ (control-stack
+ (store-stack-tn tn null-tn)))))))))))
+ (load-stack-tn csp-tn sp)))
+
+
+(define-vop (nlx-entry-multiple)
+ (:args (top :target dst) (start :target src) (count :target num))
+ ;; Again, no SC restrictions for the args, 'cause the loading would
+ ;; happen before the entry label.
+ (:info label)
+ (:temporary (:scs (any-reg) :from (:argument 0)) dst)
+ (:temporary (:scs (any-reg) :from (:argument 1)) src)
+ (:temporary (:scs (any-reg) :from (:argument 2)) num)
+ (:temporary (:scs (descriptor-reg)) temp)
+ (:results (new-start) (new-count))
+ (:save-p :force-to-stack)
+ (:vop-var vop)
+ (:generator 30
+ (emit-return-pc label)
+ (note-this-location vop :non-local-entry)
+
+ ;; Copy args.
+ (load-stack-tn dst top)
+ (move start src)
+ (move count num)
+
+ ;; Establish results.
+ (sc-case new-start
+ (any-reg (move dst new-start))
+ (control-stack (store-stack-tn new-start dst)))
+ (inst comb := num zero-tn done)
+ (sc-case new-count
+ (any-reg (inst move num new-count))
+ (control-stack (store-stack-tn new-count num)))
+ ;; Load the first word.
+ (inst ldwm n-word-bytes src temp)
+
+ ;; Copy stuff on stack.
+ LOOP
+ (inst stwm temp n-word-bytes dst)
+ (inst addib :<> (fixnumize -1) num loop :nullify t)
+ (inst ldwm n-word-bytes src temp)
+
+ DONE
+ (inst move dst csp-tn)))
+
+
+;;; 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
+(in-package "SB!VM")
+
+\f
+;;;; Machine Architecture parameters:
+
+(def!constant n-word-bits 32
+ "Number of bits per word where a word holds one lisp descriptor.")
+
+(def!constant n-byte-bits 8
+ "Number of bits per byte where a byte is the smallest addressable object.")
+
+(def!constant word-shift (1- (integer-length (/ n-word-bits n-byte-bits)))
+ "Number of bits to shift between word addresses and byte addresses.")
+
+(def!constant n-word-bytes (/ n-word-bits n-byte-bits)
+ "Number of bytes in a word.")
+
+(def!constant float-sign-shift 31)
+
+(def!constant single-float-bias 126)
+(defconstant-eqx single-float-exponent-byte (byte 8 23) #'equal)
+(defconstant-eqx single-float-significand-byte (byte 23 0) #'equal)
+(def!constant single-float-normal-exponent-min 1)
+(def!constant single-float-normal-exponent-max 254)
+(def!constant single-float-hidden-bit (ash 1 23))
+(def!constant single-float-trapping-nan-bit (ash 1 22))
+
+(def!constant double-float-bias 1022)
+(defconstant-eqx double-float-exponent-byte (byte 11 20) #'equal)
+(defconstant-eqx double-float-significand-byte (byte 20 0) #'equal)
+(def!constant double-float-normal-exponent-min 1)
+(def!constant double-float-normal-exponent-max #x7FE)
+(def!constant double-float-hidden-bit (ash 1 20))
+(def!constant double-float-trapping-nan-bit (ash 1 19))
+
+(def!constant single-float-digits
+ (+ (byte-size single-float-significand-byte) 1))
+
+(def!constant double-float-digits
+ (+ (byte-size double-float-significand-byte) n-word-bits 1))
+
+(def!constant float-inexact-trap-bit (ash 1 0))
+(def!constant float-underflow-trap-bit (ash 1 1))
+(def!constant float-overflow-trap-bit (ash 1 2))
+(def!constant float-divide-by-zero-trap-bit (ash 1 3))
+(def!constant float-invalid-trap-bit (ash 1 4))
+
+(def!constant float-round-to-nearest 0)
+(def!constant float-round-to-zero 1)
+(def!constant float-round-to-positive 2)
+(def!constant float-round-to-negative 3)
+
+(defconstant-eqx float-rounding-mode (byte 2 7) #'equal)
+(defconstant-eqx float-sticky-bits (byte 5 27) #'equal)
+(defconstant-eqx float-traps-byte (byte 5 0) #'equal)
+(defconstant-eqx float-exceptions-byte (byte 5 27) #'equal)
+(def!constant float-condition-bit (ash 1 26))
+(def!constant float-fast-bit 0) ; No fast mode on HPPA.
+
+
+\f
+;;;; Description of the target address space.
+
+;;; Where to put the different spaces.
+;;;
+(def!constant read-only-space-start #x20000000)
+(def!constant read-only-space-end #x24000000)
+
+(def!constant binding-stack-start #x24000000)
+(def!constant binding-stack-end #x24ff0000)
+
+(def!constant control-stack-start #x25000000)
+(def!constant control-stack-end #x25ff0000)
+
+(def!constant static-space-start #x28000000)
+(def!constant static-space-end #x2a000000)
+
+(def!constant dynamic-space-start #x30000000)
+(def!constant dynamic-space-end #x37fff000)
+
+(def!constant dynamic-0-space-start #x30000000)
+(def!constant dynamic-0-space-end #x37fff000)
+(def!constant dynamic-1-space-start #x38000000)
+(def!constant dynamic-1-space-end #x3ffff000)
+
+;;; FIXME: WTF are these for?
+
+;; The space-register holding the lisp heap.
+(def!constant lisp-heap-space 5)
+
+;; The space-register holding the C text segment.
+(def!constant c-text-space 4)
+
+\f
+;;;; Other random constants.
+
+(defenum (:suffix -trap :start 8)
+ halt
+ pending-interrupt
+ error
+ cerror
+ breakpoint
+ fun-end-breakpoint
+ single-step-breakpoint)
+
+(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*
+
+ ;; Functions that the C code needs to call
+ sb!impl::maybe-gc
+ sb!kernel::internal-error
+ sb!kernel::control-stack-exhausted-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*
+
+ ;; Interrupt Handling
+ *free-interrupt-context-index*
+ sb!unix::*interrupts-enabled*
+ sb!unix::*interrupt-pending*
+ ))
+
+(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-=
+ 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
+ ))
--- /dev/null
+(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 :nullify t)))
+
+\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 bc := not-p x y target)))
--- /dev/null
+;;;; Do whatever is necessary to make the given code component
+;;;; executable.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This 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)
+
+(defun sanctify-for-execution (component)
+ (without-gcing
+ (alien-funcall (extern-alien "sanctify_for_execution"
+ (function void
+ system-area-pointer
+ unsigned-long))
+ (code-instructions component)
+ (* (code-header-ref component code-code-size-slot)
+ n-word-bytes)))
+ nil)
--- /dev/null
+(in-package "SB!VM")
+
+\f
+;;;; Moves and coercions:
+
+;;; Move a tagged SAP to an untagged representation.
+;;;
+(define-vop (move-to-sap)
+ (:args (x :scs (descriptor-reg)))
+ (:results (y :scs (sap-reg)))
+ (:note "system area pointer indirection")
+ (: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 (x :scs (sap-reg) :to (:eval 1)))
+ (:temporary (:scs (non-descriptor-reg)) ndescr)
+ (:results (y :scs (descriptor-reg) :from (:eval 0)))
+ (:note "system area pointer allocation")
+ (:generator 20
+ (with-fixed-allocation (y ndescr sap-widetag sap-size)
+ (storew x y 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))))
+ (:effects)
+ (:affected)
+ (:generator 0
+ (move x y)))
+;;;
+(define-move-vop sap-move :move
+ (sap-reg) (sap-reg))
+
+
+;;; Move untagged sap arguments/return-values.
+;;;
+(define-vop (move-sap-argument)
+ (:args (x :target y
+ :scs (sap-reg))
+ (fp :scs (any-reg)
+ :load-if (not (sc-is y sap-reg))))
+ (:results (y))
+ (:generator 0
+ (sc-case y
+ (sap-reg
+ (move x y))
+ (sap-stack
+ (storew x fp (tn-offset y))))))
+;;;
+(define-move-vop move-sap-argument :move-arg
+ (descriptor-reg sap-reg) (sap-reg))
+
+
+;;; Use standard MOVE-ARGUMENT + coercion to move an untagged sap to a
+;;; descriptor passing location.
+;;;
+(define-move-vop move-argument :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 sap int)))
+
+(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 int sap)))
+
+
+\f
+;;;; POINTER+ and POINTER-
+
+(define-vop (pointer+)
+ (:translate sap+)
+ (:args (ptr :scs (sap-reg) :target res)
+ (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 1
+ (inst add ptr offset res)))
+
+(define-vop (pointer+-c)
+ (:translate sap+)
+ (:args (ptr :scs (sap-reg)))
+ (:info offset)
+ (:arg-types system-area-pointer (:constant (signed-byte 11)))
+ (:results (res :scs (sap-reg)))
+ (:result-types system-area-pointer)
+ (:policy :fast-safe)
+ (:generator 1
+ (inst addi offset ptr res)))
+
+(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 ptr1 ptr2 res)))
+
+
+\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 (object :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 'ldbx)
+ (:short 'ldhx)
+ (:long 'ldwx)
+ (:float 'fldx))
+ offset object result)
+ ,@(when (and signed (not (eq size :long)))
+ `((inst extrs result 31 ,(ecase size
+ (:byte 8)
+ (:short 16))
+ result)))))
+ (define-vop (,ref-name-c)
+ (:translate ,ref-name)
+ (:policy :fast-safe)
+ (:args (object :scs (sap-reg)))
+ (:arg-types system-area-pointer
+ (:constant ,(if (eq size :float)
+ '(signed-byte 5)
+ '(signed-byte 14))))
+ (:info offset)
+ (:results (result :scs (,sc)))
+ (:result-types ,type)
+ (:generator 4
+ (inst ,(ecase size
+ (:byte 'ldb)
+ (:short 'ldh)
+ (:long 'ldw)
+ (:float 'flds))
+ offset object result)
+ ,@(when (and signed (not (eq size :long)))
+ `((inst extrs result 31 ,(ecase size
+ (:byte 8)
+ (:short 16))
+ result)))))
+ (define-vop (,set-name)
+ (:translate ,set-name)
+ (:policy :fast-safe)
+ (:args (object :scs (sap-reg)
+ ,@(unless (eq size :float) '(:target sap)))
+ (offset :scs (signed-reg))
+ (value :scs (,sc) :target result))
+ (:arg-types system-area-pointer signed-num ,type)
+ (:results (result :scs (,sc)))
+ (:result-types ,type)
+ ,@(unless (eq size :float)
+ '((:temporary (:scs (sap-reg) :from (:argument 0)) sap)))
+ (:generator 5
+ ,@(if (eq size :float)
+ `((inst fstx value offset object)
+ (unless (location= value result)
+ (inst funop :copy value result)))
+ `((inst add object offset sap)
+ (inst ,(ecase size (:byte 'stb) (:short 'sth) (:long 'stw))
+ value 0 sap)
+ (move value result)))))
+ (define-vop (,set-name-c)
+ (:translate ,set-name)
+ (:policy :fast-safe)
+ (:args (object :scs (sap-reg))
+ (value :scs (,sc) :target result))
+ (:arg-types system-area-pointer
+ (:constant ,(if (eq size :float)
+ '(signed-byte 5)
+ '(signed-byte 14)))
+ ,type)
+ (:info offset)
+ (:results (result :scs (,sc)))
+ (:result-types ,type)
+ (:generator 5
+ ,@(if (eq size :float)
+ `((inst fsts value offset object)
+ (unless (location= value result)
+ (inst funop :copy value result)))
+ `((inst ,(ecase size (:byte 'stb) (:short 'sth) (:long 'stw))
+ value offset object)
+ (move value result)))))))))
+ (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 :float)
+ (def-system-ref-and-set sap-ref-double %set-sap-ref-double
+ double-reg double-float :float))
+
+\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
+ (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
+ vector
+ sap)))
+
+\f
+;;; Transforms for 64-bit SAP accessors.
+
+;;; FIXME: So these are now commented out on the SPARC, PPC and HPPA
+;;; backends. Did they ever serve a purpose? Could they in future? --
+;;; CSR, 2002-08-10
+#|
+(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))))
+|#
--- /dev/null
+(in-package "SB!VM")
+
+
+(define-vop (print)
+ (:args (object :scs (descriptor-reg) :target arg))
+ (:results (result :scs (descriptor-reg)))
+ (:save-p t)
+ (:temporary (:sc non-descriptor-reg :offset cfunc-offset) cfunc)
+ (:temporary (:sc non-descriptor-reg :offset nl0-offset :from (:argument 0))
+ arg)
+ (:temporary (:sc non-descriptor-reg :offset nl4-offset :to (:result 0))
+ res)
+ (: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)))
+ (move object arg)
+ (when cur-nfp
+ (store-stack-tn nfp-save cur-nfp))
+ ;; Allocate 64 bytes, the minimum stack size.
+ (inst addi 64 nsp-tn nsp-tn)
+ (inst li (make-fixup "debug_print" :foreign) cfunc)
+ (let ((fixup (make-fixup "call_into_c" :foreign)))
+ (inst ldil fixup temp)
+ (inst ble fixup c-text-space temp :nullify t)
+ (inst nop))
+ (inst addi -64 nsp-tn nsp-tn)
+ (when cur-nfp
+ (load-stack-tn cur-nfp nfp-save))
+ (move res result))))
--- /dev/null
+(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 (:scs (interior-reg)) lip)
+ (: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 (src dst)
+ (collect ((moves))
+ (do ((src src (cdr src))
+ (dst dst (cdr dst)))
+ ((or (null src) (null dst)))
+ (moves `(move ,(car src) ,(car dst))))
+ (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 (~D) or too many results (~D). Max = ~D"
+ 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 (arg-names) (temp-names))
+ (inst li (fixnumize ,num-args) nargs)
+ (inst ldw (static-fun-offset symbol) null-tn lip)
+ (when cur-nfp
+ (store-stack-tn nfp-save cur-nfp))
+ (inst move cfp-tn old-fp)
+ (inst compute-lra-from-code code-tn lra-label temp lra)
+ (note-this-location vop :call-site)
+ (inst bv lip)
+ (inst move csp-tn cfp-tn)
+ (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 (temp-names) (result-names))))))))
+
+) ; eval-when (compile load eval)
+
+(macrolet
+ ((foo ()
+ (collect ((templates (list 'progn)))
+ (dotimes (i register-arg-count)
+ (templates (static-fun-template-vop i 1)))
+ (templates))))
+ (foo))
+
+(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
+(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) :type random) 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
+ (move object ptr)
+ (inst comb := ptr null-tn done)
+ (inst li 0 count)
+
+ (inst extru ptr 31 3 temp)
+ (inst comib :<> list-pointer-lowtag temp loose :nullify t)
+ (loadw ptr ptr cons-cdr-slot list-pointer-lowtag)
+
+ LOOP
+ (inst addi (fixnumize 1) count count)
+ (inst comb := ptr null-tn done :nullify t)
+ (inst extru ptr 31 3 temp)
+ (inst comib := list-pointer-lowtag temp loop :nullify t)
+ (loadw ptr ptr cons-cdr-slot list-pointer-lowtag)
+
+ LOOSE
+ (cerror-call vop done object-not-list-error ptr)
+
+ DONE
+ (move count result)))
+
+(define-static-fun length (object) :translate length)
--- /dev/null
+(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) :target result))
+ (:results (result :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:generator 1
+ (inst extru object 31 3 result)))
+
+(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
+ (inst extru object 31 3 result)
+ (inst comib := other-pointer-lowtag result other-ptr :nullify t)
+ (inst comib := fun-pointer-lowtag result function-ptr :nullify t)
+ (inst bb t object 31 done :nullify t)
+ (inst extru object 31 2 result :=)
+ (inst extru object 31 8 result)
+ (inst nop :tr)
+
+ FUNCTION-PTR
+ (load-type result object (- fun-pointer-lowtag))
+ (inst nop :tr)
+
+ OTHER-PTR
+ (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 (- 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 (- 3 fun-pointer-lowtag) function)
+ (move type result)))
+
+(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 other-pointer-lowtag)
+ (inst srl res 8 res)))
+
+(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 fun-pointer-lowtag)
+ (inst srl res 8 res)))
+
+(define-vop (set-header-data)
+ (:translate set-header-data)
+ (:policy :fast-safe)
+ (:args (x :scs (descriptor-reg) :target res)
+ (data :scs (unsigned-reg)))
+ (:arg-types * positive-fixnum)
+ (:results (res :scs (descriptor-reg)))
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:generator 6
+ (loadw temp x 0 other-pointer-lowtag)
+ (inst dep data 23 24 temp)
+ (storew temp x 0 other-pointer-lowtag)
+ (move x res)))
+
+(define-vop (set-header-data-c)
+ (:translate set-header-data)
+ (:policy :fast-safe)
+ (:args (x :scs (descriptor-reg) :target res))
+ (:arg-types * (:constant (signed-byte 5)))
+ (:info data)
+ (:results (res :scs (descriptor-reg)))
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:generator 5
+ (loadw temp x 0 other-pointer-lowtag)
+ (inst dep data 23 24 temp)
+ (storew temp x 0 other-pointer-lowtag)
+ (move x res)))
+
+(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 zdep ptr 29 29 res)))
+
+(define-vop (make-other-immediate-type)
+ (:args (val :scs (any-reg descriptor-reg))
+ (type :scs (any-reg descriptor-reg) :target temp))
+ (:results (res :scs (any-reg descriptor-reg) :from (:argument 0)))
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:generator 2
+ (inst sll val (- n-widetag-bits 2) res)
+ (inst sra type 2 temp)
+ (inst or res temp res)))
+
+\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 alloc-tn int)))
+
+(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 bsp-tn int)))
+
+(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 csp-tn int)))
+
+\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 other-pointer-lowtag)
+ (inst srl ndescr 8 ndescr)
+ (inst sll ndescr 2 ndescr)
+ (inst addi (- other-pointer-lowtag) ndescr ndescr)
+ (inst add code ndescr sap)))
+
+(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 other-pointer-lowtag)
+ (inst srl ndescr 8 ndescr)
+ (inst sll ndescr 2 ndescr)
+ (inst add ndescr offset ndescr)
+ (inst addi (- fun-pointer-lowtag other-pointer-lowtag) ndescr ndescr)
+ (inst add ndescr code func)))
+
+\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 break pending-interrupt-trap)))
+
+
+(define-vop (halt)
+ (:generator 1
+ (inst break 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)))
+ (inst ldw offset count-vector count)
+ (inst addi 1 count count)
+ (inst stw count offset count-vector))))
--- /dev/null
+;;;; This file is for stuff which was in CMU CL's insts.lisp
+;;;; file, but which in the SBCL build process can't be compiled
+;;;; into code for the cross-compilation host.
+
+;;;; 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")
+
--- /dev/null
+(in-package "SB!VM")
+
+
+\f
+;;;; Test generation utilities.
+
+(eval-when (:compile-toplevel :execute)
+
+(defparameter *immediate-types*
+ (list unbound-marker-widetag base-char-widetag))
+
+(defparameter *fun-header-widetags*
+ (list funcallable-instance-header-widetag
+ simple-fun-header-widetag
+ closure-fun-header-widetag
+ closure-header-widetag))
+
+(defun canonicalize-headers (headers)
+ (collect ((results))
+ (let ((start nil)
+ (prev nil)
+ (delta (- other-immediate-1-lowtag other-immediate-0-lowtag)))
+ (flet ((emit-test ()
+ (results (if (= start prev)
+ start
+ (cons start prev)))))
+ (dolist (header (sort headers #'<))
+ (cond ((null start)
+ (setf start header)
+ (setf prev header))
+ ((= header (+ prev delta))
+ (setf prev header))
+ (t
+ (emit-test)
+ (setf start header)
+ (setf prev header))))
+ (emit-test)))
+ (results)))
+
+); eval-when (compile eval)
+
+(macrolet ((test-type (value temp target not-p &rest type-codes)
+ ;; Determine what interesting combinations we need to test for.
+ (let* ((type-codes (mapcar #'eval type-codes))
+ (fixnump (and (member even-fixnum-lowtag type-codes)
+ (member odd-fixnum-lowtag type-codes)
+ t))
+ (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 (if (intersection headers *fun-header-widetags*)
+ (if (subsetp headers *fun-header-widetags*)
+ t
+ (error "Can't test for mix of function subtypes ~
+ and normal header types."))
+ nil)))
+ (unless type-codes
+ (error "Must supply at least on type for test-type."))
+ (cond
+ (fixnump
+ (when (remove-if #'(lambda (x)
+ (or (= x even-fixnum-lowtag)
+ (= x odd-fixnum-lowtag)))
+ lowtags)
+ (error "Can't mix fixnum testing with other lowtags."))
+ (when function-p
+ (error "Can't mix fixnum testing with function subtype testing."))
+ (when immediates
+ (error "Can't mix fixnum testing with other immediates."))
+ (if headers
+ `(%test-fixnum-and-headers ,value ,temp ,target ,not-p
+ ',(canonicalize-headers headers))
+ `(%test-fixnum ,value ,temp ,target ,not-p)))
+ (immediates
+ (when headers
+ (error "Can't mix testing of immediates with testing of headers."))
+ (when lowtags
+ (error "Can't mix testing of immediates with testing of lowtags."))
+ (when (cdr immediates)
+ (error "Can't test multiple immediates at the same time."))
+ `(%test-immediate ,value ,temp ,target ,not-p ,(car immediates)))
+ (lowtags
+ (when (cdr lowtags)
+ (error "Can't test multiple lowtags at the same time."))
+ (if headers
+ `(%test-lowtag-and-headers
+ ,value ,temp ,target ,not-p ,(car lowtags)
+ ,function-p ',(canonicalize-headers headers))
+ `(%test-lowtag ,value ,temp ,target ,not-p ,(car lowtags))))
+ (headers
+ `(%test-headers ,value ,temp ,target ,not-p ,function-p
+ ',(canonicalize-headers headers)))
+ (t
+ (error "Nothing to test?"))))))
+
+
+(defun %test-fixnum (value temp target not-p)
+ (declare (ignore temp))
+ (assemble ()
+ (inst extru value 31 2 zero-tn (if not-p := :<>))
+ (inst b target :nullify t)))
+
+(defun %test-fixnum-and-headers (value temp target not-p headers)
+ (let ((drop-through (gen-label)))
+ (assemble ()
+ (inst extru value 31 2 zero-tn :<>)
+ (inst b (if not-p drop-through target) :nullify t))
+ (%test-headers value temp target not-p nil headers drop-through)))
+
+(defun %test-immediate (value temp target not-p immediate)
+ (assemble ()
+ (inst extru value 31 8 temp)
+ (inst bci := not-p immediate temp target)))
+
+(defun %test-lowtag (value temp target not-p lowtag &optional temp-loaded)
+ (assemble ()
+ (unless temp-loaded
+ (inst extru value 31 3 temp))
+ (inst bci := not-p lowtag temp target)))
+
+(defun %test-lowtag-and-headers (value temp target not-p lowtag
+ function-p headers)
+ (let ((drop-through (gen-label)))
+ (%test-lowtag value temp (if not-p drop-through target) nil lowtag)
+ (%test-headers value temp target not-p function-p headers drop-through t)))
+
+(defun %test-headers (value temp target not-p function-p headers
+ &optional (drop-through (gen-label)) temp-loaded)
+ (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
+ (multiple-value-bind
+ (equal greater-or-equal when-true when-false)
+ ;; EQUAL and GREATER-OR-EQUAL are the conditions for branching to
+ ;; TARGET. WHEN-TRUE and WHEN-FALSE are the labels to branch to when
+ ;; we know it's true and when we know it's false respectively.
+ (if not-p
+ (values :<> :< drop-through target)
+ (values := :>= target drop-through))
+ (assemble ()
+ (%test-lowtag value temp when-false t lowtag temp-loaded)
+ (inst ldb (- 3 lowtag) value temp)
+ (do ((remaining headers (cdr remaining)))
+ ((null remaining))
+ (let ((header (car remaining))
+ (last (null (cdr remaining))))
+ (cond
+ ((atom header)
+ (if last
+ (inst bci equal nil header temp target)
+ (inst bci := nil header temp when-true)))
+ (t
+ (let ((start (car header))
+ (end (cdr header)))
+ (unless (= start bignum-widetag)
+ (inst bci :> nil start temp when-false))
+ (if last
+ (inst bci greater-or-equal nil end temp target)
+ (inst bci :>= nil end temp when-true)))))))
+ (emit-label drop-through)))))
+
+\f
+;;;; Type checking and testing:
+
+(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) :to (:result 0)) temp)
+ (:vop-var vop)
+ (:save-p :compute-only))
+
+(define-vop (type-predicate)
+ (:args (value :scs (any-reg descriptor-reg)))
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:conditional)
+ (:info target not-p)
+ (:policy :fast-safe))
+
+(eval-when (:compile-toplevel :execute)
+
+(defun cost-to-test-types (type-codes)
+ (+ (* 2 (length type-codes))
+ (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
+
+) ; EVAL-WHEN
+
+(defmacro 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 value result))))))
+ ,@(when ptype
+ `((primitive-type-vop ,check-name (:check) ,ptype))))))
+
+(def-type-vops fixnump check-fixnum fixnum object-not-fixnum-error
+ even-fixnum-lowtag odd-fixnum-lowtag)
+
+(def-type-vops functionp check-function function
+ object-not-fun-error fun-pointer-lowtag)
+
+(def-type-vops listp check-list list object-not-list-error
+ list-pointer-lowtag)
+
+(def-type-vops %instancep check-instance instance object-not-instance-error
+ instance-pointer-lowtag)
+
+(def-type-vops bignump check-bignum bignum
+ object-not-bignum-error bignum-widetag)
+
+(def-type-vops ratiop check-ratio ratio
+ object-not-ratio-error ratio-widetag)
+
+(def-type-vops complexp check-complex complex object-not-complex-error
+ 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 single-float-widetag)
+
+(def-type-vops double-float-p check-double-float double-float
+ object-not-double-float-error double-float-widetag)
+
+(def-type-vops simple-string-p check-simple-string simple-string
+ object-not-simple-string-error 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 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
+ 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
+ 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
+ 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
+ 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
+ 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
+ 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
+ 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 base-char-widetag)
+
+(def-type-vops system-area-pointer-p check-system-area-pointer
+ system-area-pointer object-not-sap-error sap-widetag)
+
+(def-type-vops weak-pointer-p check-weak-pointer weak-pointer
+ object-not-weak-pointer-error weak-pointer-widetag)
+
+#|
+(def-type-vops scavenger-hook-p nil nil nil
+ 0)
+|#
+
+(def-type-vops code-component-p nil nil nil
+ code-header-widetag)
+
+(def-type-vops lra-p nil nil nil
+ return-pc-header-widetag)
+
+(def-type-vops fdefn-p nil nil nil
+ fdefn-widetag)
+
+(def-type-vops funcallable-instance-p nil nil nil
+ funcallable-instance-header-widetag)
+
+(def-type-vops array-header-p nil nil nil
+ simple-array-widetag complex-string-widetag complex-bit-vector-widetag
+ complex-vector-widetag complex-array-widetag)
+
+#+nil
+(def-type-vops nil check-function-or-symbol nil
+ object-not-function-or-symbol-error
+ fun-pointer-lowtag symbol-header-widetag)
+
+(def-type-vops stringp check-string nil object-not-string-error
+ simple-string-widetag complex-string-widetag)
+
+(def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error
+ simple-bit-vector-widetag 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 complex-vector-p check-complex-vector nil object-not-complex-vector-error
+ 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
+ even-fixnum-lowtag odd-fixnum-lowtag ratio-widetag bignum-widetag)
+
+(def-type-vops integerp check-integer nil object-not-integer-error
+ even-fixnum-lowtag odd-fixnum-lowtag bignum-widetag)
+
+(def-type-vops floatp check-float nil object-not-float-error
+ single-float-widetag double-float-widetag)
+
+(def-type-vops realp check-real nil object-not-real-error
+ even-fixnum-lowtag odd-fixnum-lowtag ratio-widetag bignum-widetag
+ single-float-widetag double-float-widetag)
+
+\f
+;;;; Other integer ranges.
+
+;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
+;;; exactly one digit.
+
+(defun signed-byte-32-test (value temp not-p target not-target)
+ (multiple-value-bind
+ (yep nope)
+ (if not-p
+ (values not-target target)
+ (values target not-target))
+ (assemble ()
+ (inst extru value 31 2 zero-tn :<>)
+ (inst b yep :nullify t)
+ (inst extru value 31 3 temp)
+ (inst bci :<> nil other-pointer-lowtag temp nope)
+ (loadw temp value 0 other-pointer-lowtag)
+ (inst bci := not-p (+ (ash 1 n-widetag-bits) bignum-widetag) temp target)))
+ (values))
+
+(define-vop (signed-byte-32-p type-predicate)
+ (:translate signed-byte-32-p)
+ (:generator 45
+ (signed-byte-32-test value temp not-p target not-target)
+ NOT-TARGET))
+
+(define-vop (check-signed-byte-32 check-type)
+ (:generator 45
+ (let ((loose (generate-error-code vop object-not-signed-byte-32-error
+ value)))
+ (signed-byte-32-test value temp t loose okay))
+ OKAY
+ (move value result)))
+
+;;; 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.
+
+(defun unsigned-byte-32-test (value temp not-p target not-target)
+ (let ((nope (if not-p target not-target)))
+ (assemble ()
+ ;; Is it a fixnum?
+ (inst extru value 31 2 zero-tn :<>)
+ (inst b fixnum)
+ (inst move value temp)
+
+ ;; If not, is it an other pointer?
+ (inst extru value 31 3 temp)
+ (inst bci :<> nil other-pointer-lowtag temp nope)
+ ;; Get the header.
+ (loadw temp value 0 other-pointer-lowtag)
+ ;; Is it one?
+ (inst bci := nil (+ (ash 1 n-widetag-bits) bignum-widetag) temp single-word)
+ ;; If it's other than two, we can't be an (unsigned-byte 32)
+ (inst bci :<> nil (+ (ash 2 n-widetag-bits) bignum-widetag) temp nope)
+ ;; Get the second digit.
+ (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
+ ;; All zeros, its an (unsigned-byte 32).
+ (inst comb (if not-p := :<>) temp zero-tn not-target :nullify t)
+ (inst b target :nullify t)
+
+ SINGLE-WORD
+ ;; Get the single digit.
+ (loadw temp value bignum-digits-offset other-pointer-lowtag)
+
+ ;; positive implies (unsigned-byte 32).
+ FIXNUM
+ (inst bc :>= not-p temp zero-tn target)))
+ (values))
+
+(define-vop (unsigned-byte-32-p type-predicate)
+ (:translate unsigned-byte-32-p)
+ (:generator 45
+ (unsigned-byte-32-test value temp not-p target not-target)
+ NOT-TARGET))
+
+(define-vop (check-unsigned-byte-32 check-type)
+ (:generator 45
+ (let ((loose (generate-error-code vop object-not-unsigned-byte-32-error
+ value)))
+ (unsigned-byte-32-test value temp t loose okay))
+ OKAY
+ (move value result)))
+
+\f
+;;;; List/symbol types:
+;;;
+;;; symbolp (or symbol (eq nil))
+;;; consp (and list (not (eq nil)))
+
+(define-vop (symbolp type-predicate)
+ (:translate symbolp)
+ (:generator 12
+ (inst bc := nil value null-tn (if not-p drop-thru target))
+ (test-type value temp target not-p symbol-header-widetag)
+ DROP-THRU))
+
+(define-vop (check-symbol check-type)
+ (:generator 12
+ (inst comb := value null-tn drop-thru)
+ (let ((error (generate-error-code vop object-not-symbol-error value)))
+ (test-type value temp error t symbol-header-widetag))
+ DROP-THRU
+ (move value result)))
+
+(define-vop (consp type-predicate)
+ (:translate consp)
+ (:generator 8
+ (inst bc := nil value null-tn (if not-p target drop-thru))
+ (test-type value temp target not-p list-pointer-lowtag)
+ DROP-THRU))
+
+(define-vop (check-cons check-type)
+ (:generator 8
+ (let ((error (generate-error-code vop object-not-cons-error value)))
+ (inst bc := nil value null-tn error)
+ (test-type value temp error t list-pointer-lowtag))
+ (move value result)))
+
+) ; MACROLET
\ No newline at end of file
--- /dev/null
+(in-package "SB!VM")
+
+(define-vop (reset-stack-pointer)
+ (:args (ptr :scs (any-reg)))
+ (:generator 1
+ (move ptr csp-tn)))
+
+
+;;; 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
+ (move csp-tn start)
+ (inst addi (* nvals n-word-bytes) csp-tn csp-tn)
+ (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 li (fixnumize nvals) count)))
+
+
+;;; 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) :type random) ndescr)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 0
+ (move arg list)
+ (inst comb := list null-tn done)
+ (move csp-tn start)
+
+ LOOP
+ (loadw temp list cons-car-slot list-pointer-lowtag)
+ (loadw list list cons-cdr-slot list-pointer-lowtag)
+ (inst addi n-word-bytes csp-tn csp-tn)
+ (storew temp csp-tn -1)
+ (inst extru list 31 n-lowtag-bits ndescr)
+ (inst comib := list-pointer-lowtag ndescr loop)
+ (inst comb := list null-tn done :nullify t)
+ (error-call vop bogus-arg-to-values-list-error list)
+
+ DONE
+ (inst sub csp-tn start count)))
+
+
+;;; 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))
+ (:temporary (:sc any-reg :from (:argument 0)) src)
+ (:temporary (:sc any-reg :from (:argument 1)) dst end)
+ (:temporary (:sc descriptor-reg :from (:argument 1)) temp)
+ (:results (start :scs (any-reg))
+ (count :scs (any-reg)))
+ (:generator 20
+ (sc-case skip
+ (zero
+ (move context src))
+ (immediate
+ (inst addi (* (tn-value skip) n-word-bytes) context src))
+ (any-reg
+ (inst add skip context src)))
+ (move num count)
+ (inst comb := num zero-tn done)
+ (inst move csp-tn start)
+ (inst move csp-tn dst)
+ (inst add csp-tn count csp-tn)
+ (inst addi (- n-word-bytes) csp-tn end)
+ LOOP
+ (inst ldwm 4 src temp)
+ (inst comb :< dst end loop)
+ (inst stwm temp 4 dst)
+ 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)))
+
+;;; FIXME: These want to turn into macrolets.
+(macrolet ((defreg (name offset)
+ (let ((offset-sym (symbolicate name "-OFFSET")))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (def!constant ,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))))))
+
+ ;; Wired-zero
+ (defreg zero 0)
+ ;; This gets trashed by the C call convention.
+ (defreg nfp 1)
+ (defreg cfunc 2)
+ ;; These are the callee saves, so these registers are stay live over
+ ;; call-out.
+ (defreg csp 3)
+ (defreg cfp 4)
+ (defreg bsp 5)
+ (defreg null 6)
+ (defreg alloc 7)
+ (defreg code 8)
+ (defreg fdefn 9)
+ (defreg lexenv 10)
+ (defreg nargs 11)
+ (defreg ocfp 12)
+ (defreg lra 13)
+ (defreg a0 14)
+ (defreg a1 15)
+ (defreg a2 16)
+ (defreg a3 17)
+ (defreg a4 18)
+ ;; This is where the caller-saves registers start, but we don't
+ ;; really care because we need to clear the above after call-out to
+ ;; make sure no pointers into oldspace are kept around.
+ (defreg a5 19)
+ (defreg l0 20)
+ (defreg l1 21)
+ (defreg l2 22)
+ ;; These are the 4 C argument registers.
+ (defreg nl3 23)
+ (defreg nl2 24)
+ (defreg nl1 25)
+ (defreg nl0 26)
+ ;; The global Data Pointer. We just leave it alone, because we
+ ;; don't need it.
+ (defreg dp 27)
+ ;; These two are use for C return values.
+ (defreg nl4 28)
+ (defreg nl5 29)
+ (defreg nsp 30)
+ (defreg lip 31)
+
+ (defregset non-descriptor-regs
+ nl0 nl1 nl2 nl3 nl4 nl5 nfp cfunc)
+
+ (defregset descriptor-regs
+ fdefn lexenv nargs ocfp lra a0 a1 a2 a3 a4 a5 l0 l1 l2)
+
+ (defregset *register-arg-offsets*
+ a0 a1 a2 a3 a4 a5))
+
+
+(define-storage-base registers :finite :size 32)
+(define-storage-base float-registers :finite :size 64)
+(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)
+ `(export ',constant-name)
+ forms)))
+ (index 0 (1+ index))
+ (classes classes (cdr classes)))
+ ((null classes)
+ (nreverse forms))))
+
+(def!constant 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)
+ (fp-single-zero immediate-constant)
+ (fp-double-zero 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 an 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 4 to 31 collect i)
+ :constant-scs (fp-single-zero)
+ :save-p t
+ :alternate-scs (single-stack))
+
+ ;; Non-Descriptor double-floats.
+ (double-reg float-registers
+ :locations #.(loop for i from 4 to 31 collect i)
+ :constant-scs (fp-double-zero)
+ :save-p t
+ :alternate-scs (double-stack))
+
+ (complex-single-reg float-registers
+ :locations #.(loop for i from 4 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 4 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)))))
+
+ ;; These, we access by foo-TN only
+
+ (defregtn zero any-reg)
+ (defregtn null descriptor-reg)
+ (defregtn code descriptor-reg)
+ (defregtn alloc any-reg)
+ (defregtn bsp any-reg)
+ (defregtn csp any-reg)
+ (defregtn cfp any-reg)
+ (defregtn nsp any-reg)
+
+ ;; These alias regular locations, so we have to make sure we don't bypass
+ ;; the register allocator when using them.
+ (defregtn nargs any-reg)
+ (defregtn ocfp any-reg)
+ (defregtn lip interior-reg))
+
+;; And some floating point values.
+(defparameter fp-single-zero-tn
+ (make-random-tn :kind :normal
+ :sc (sc-or-lose 'single-reg)
+ :offset 0))
+(defparameter fp-double-zero-tn
+ (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset 0))
+
+\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))
+ (single-float
+ (if (zerop value)
+ (sc-number-or-lose 'fp-single-zero)
+ nil))
+ (double-float
+ (if (zerop value)
+ (sc-number-or-lose 'fp-double-zero)
+ 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 6)
+
+;;; Names to use for the argument registers.
+;;;
+(defconstant-eqx register-arg-names '(a0 a1 a2 a3 a4 a5) #'equal)
+
+); 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*))
+
+;;; SINGLE-VALUE-RETURN-BYTE-OFFSET
+;;;
+;;; This is used by the debugger.
+;;;
+(defconstant single-value-return-byte-offset 4)
+
+\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"))))
+
+;;; The loader uses this to convert alien names to the form they
+;;; occure in the symbol table (for example, prepending an
+;;; underscore). On the HPPA we just leave it alone.
+(defun extern-alien-name (name)
+ (declare (type simple-base-string name))
+ name)
(seg-virtual-location seg)
(seg-code seg)))))
\f
-;;; All state during disassembly. We store some seemingly redundant
-;;; information so that we can allow garbage collect during disassembly and
-;;; not get tripped up by a code block being moved...
-(defstruct (disassem-state (:conc-name dstate-)
- (:constructor %make-dstate)
- (:copier nil))
- ;; offset of current pos in segment
- (cur-offs 0 :type offset)
- ;; offset of next position
- (next-offs 0 :type offset)
- ;; a sap pointing to our segment
- (segment-sap (missing-arg) :type sb!sys:system-area-pointer)
- ;; the current segment
- (segment nil :type (or null segment))
- ;; what to align to in most cases
- (alignment sb!vm:n-word-bytes :type alignment)
- (byte-order :little-endian
- :type (member :big-endian :little-endian))
- ;; for user code to hang stuff off of
- (properties nil :type list)
- (filtered-values (make-array max-filtered-value-index)
- :type filtered-value-vector)
- ;; used for prettifying printing
- (addr-print-len nil :type (or null (integer 0 20)))
- (argument-column 0 :type column)
- ;; to make output look nicer
- (output-state :beginning
- :type (member :beginning
- :block-boundary
- nil))
-
- ;; alist of (address . label-number)
- (labels nil :type list)
- ;; same as LABELS slot data, but in a different form
- (label-hash (make-hash-table) :type hash-table)
- ;; list of function
- (fun-hooks nil :type list)
-
- ;; alist of (address . label-number), popped as it's used
- (cur-labels nil :type list)
- ;; OFFS-HOOKs, popped as they're used
- (cur-offs-hooks nil :type list)
-
- ;; for the current location
- (notes nil :type list)
-
- ;; currently active source variables
- (current-valid-locations nil :type (or null (vector bit))))
-(def!method print-object ((dstate disassem-state) stream)
- (print-unreadable-object (dstate stream :type t)
- (format stream
- "+~W~@[ in ~S~]"
- (dstate-cur-offs dstate)
- (dstate-segment dstate))))
-
-;;; Return the absolute address of the current instruction in DSTATE.
-(defun dstate-cur-addr (dstate)
- (the address (+ (seg-virtual-location (dstate-segment dstate))
- (dstate-cur-offs dstate))))
-
-;;; Return the absolute address of the next instruction in DSTATE.
-(defun dstate-next-addr (dstate)
- (the address (+ (seg-virtual-location (dstate-segment dstate))
- (dstate-next-offs dstate))))
-\f
;;;; function ops
(defun fun-self (fun)
--- /dev/null
+# 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.
+
+CFLAGS += -g -Dhppa
+LD = ld
+LINKFLAGS = -v -g
+NM = nm -p
+
+ASSEM_SRC = hppa-assem.S #hppa-linux-stubs.S
+ARCH_SRC = hppa-arch.c undefineds.c
+
+OS_SRC = linux-os.c hppa-linux-os.c os-common.c
+LINKFLAGS+=-static
+OS_LIBS= -ldl
+
+GC_SRC= cheneygc.c
--- /dev/null
+/*
+ * 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.
+ */
+#include <stdio.h>
+
+/* Copied from sparc-arch.c. Not all of these are necessary, probably */
+#include "runtime.h"
+#include "arch.h"
+#include "sbcl.h"
+#include "globals.h"
+#include "validate.h"
+#include "os.h"
+#include "lispregs.h"
+#include "signal.h"
+#include "alloc.h"
+#include "interrupt.h"
+#include "interr.h"
+#include "breakpoint.h"
+#include "monitor.h"
+
+void arch_init(void)
+{
+ return;
+}
+
+os_vm_address_t arch_get_bad_addr(int signal, siginfo_t *siginfo, os_context_t *context)
+{
+ return siginfo->si_addr;
+#if 0
+#ifdef hpux
+ struct save_state *state;
+ os_vm_address_t addr;
+
+ state = (struct save_state *)(&(scp->sc_sl.sl_ss));
+
+ if (state == NULL)
+ return NULL;
+
+ /* Check the instruction address first. */
+ addr = (os_vm_address_t)((unsigned long)scp->sc_pcoq_head & ~3);
+ if (addr < (os_vm_address_t)0x1000)
+ return addr;
+
+ /* Otherwise, it must have been a data fault. */
+ return (os_vm_address_t)state->ss_cr21;
+#else
+ struct hp800_thread_state *state;
+ os_vm_address_t addr;
+
+ state = (struct hp800_thread_state *)(scp->sc_ap);
+
+ if (state == NULL)
+ return NULL;
+
+ /* Check the instruction address first. */
+ addr = scp->sc_pcoqh & ~3;
+ if (addr < 0x1000)
+ return addr;
+
+ /* Otherwise, it must have been a data fault. */
+ return state->cr21;
+#endif
+#endif
+}
+
+unsigned char *arch_internal_error_arguments(os_context_t *context)
+{
+ return (unsigned char *)((*os_context_pc_addr(context) & ~3) + 4);
+}
+
+boolean arch_pseudo_atomic_atomic(os_context_t *context)
+{
+ return ((*os_context_register_addr(context,reg_ALLOC)) & 4);
+}
+
+void arch_set_pseudo_atomic_interrupted(os_context_t *context)
+{
+ *os_context_register_addr(context,reg_ALLOC) |= 1;
+}
+
+void arch_skip_instruction(os_context_t *context)
+{
+ ((char *) *os_context_pc_addr(context)) = ((char *) *os_context_npc_addr(context));
+ ((char *) *os_context_npc_addr(context)) += 4;
+}
+
+unsigned long arch_install_breakpoint(void *pc)
+{
+ unsigned long *ulpc = (unsigned long *)pc;
+ unsigned long orig_inst = *ulpc;
+
+ *ulpc = trap_Breakpoint;
+ os_flush_icache((os_vm_address_t)pc, sizeof(*ulpc));
+ return orig_inst;
+}
+
+void arch_remove_breakpoint(void *pc, unsigned long orig_inst)
+{
+ unsigned long *ulpc = (unsigned long *)pc;
+
+ *ulpc = orig_inst;
+ os_flush_icache((os_vm_address_t)pc, sizeof(*ulpc));
+}
+
+void arch_do_displaced_inst(os_context_t *context, unsigned int orig_inst)
+{
+ /* FIXME: Fill this in */
+#if 0
+#ifdef hpux
+ /* We change the next-pc to point to a breakpoint instruction, restore */
+ /* the original instruction, and exit. We would like to be able to */
+ /* sigreturn, but we can't, because this is hpux. */
+ unsigned long *pc = (unsigned long *)(SC_PC(scp) & ~3);
+
+ NextPc = SC_NPC(scp);
+ SC_NPC(scp) = (unsigned)SingleStepTraps | (SC_NPC(scp)&3);
+
+ BreakpointAddr = pc;
+ *pc = orig_inst;
+ os_flush_icache((os_vm_address_t)pc, sizeof(unsigned long));
+#else
+ /* We set the recovery counter to cover one instruction, put the */
+ /* original instruction back in, and then resume. We will then trap */
+ /* after executing that one instruction, at which time we can put */
+ /* the breakpoint back in. */
+
+ ((struct hp800_thread_state *)scp->sc_ap)->cr0 = 1;
+ scp->sc_ps |= 0x10;
+ *(unsigned long *)SC_PC(scp) = orig_inst;
+
+ sigreturn(scp);
+#endif
+#endif
+}
+
+#ifdef hpux
+static void restore_breakpoint(struct sigcontext *scp)
+{
+ /* We just single-stepped over an instruction that we want to replace */
+ /* with a breakpoint. So we put the breakpoint back in, and tweek the */
+ /* state so that we will continue as if nothing happened. */
+
+ if (NextPc == NULL)
+ lose("SingleStepBreakpoint trap at strange time.");
+
+ if ((SC_PC(scp)&~3) == (unsigned long)SingleStepTraps) {
+ /* The next instruction was not nullified. */
+ SC_PC(scp) = NextPc;
+ if ((SC_NPC(scp)&~3) == (unsigned long)SingleStepTraps + 4) {
+ /* The instruction we just stepped over was not a branch, so */
+ /* we need to fix it up. If it was a branch, it will point to */
+ /* the correct place. */
+ SC_NPC(scp) = NextPc + 4;
+ }
+ }
+ else {
+ /* The next instruction was nullified, so we want to skip it. */
+ SC_PC(scp) = NextPc + 4;
+ SC_NPC(scp) = NextPc + 8;
+ }
+ NextPc = NULL;
+
+ if (BreakpointAddr) {
+ *BreakpointAddr = trap_Breakpoint;
+ os_flush_icache((os_vm_address_t)BreakpointAddr,
+ sizeof(unsigned long));
+ BreakpointAddr = NULL;
+ }
+}
+#endif
+
+static void sigtrap_handler(int signal, siginfo_t *siginfo, void *void_context)
+{
+ os_context_t *context = arch_os_get_context(&void_context);
+ unsigned long bad_inst;
+
+ sigprocmask(SIG_SETMASK, os_context_sigmask_addr(context), 0);
+#if 0
+ printf("sigtrap_handler, pc=0x%08x, alloc=0x%08x\n", scp->sc_pcoqh,
+ SC_REG(scp,reg_ALLOC));
+#endif
+
+ bad_inst = *(unsigned long *)(*os_context_pc_addr(context) & ~3);
+ if (bad_inst & 0xfc001fe0)
+ interrupt_handle_now(signal, siginfo, context);
+ else {
+ int im5 = bad_inst & 0x1f;
+
+ switch (im5) {
+ case trap_Halt:
+ fake_foreign_function_call(context);
+ lose("%%primitive halt called; the party is over.\n");
+
+ case trap_PendingInterrupt:
+ arch_skip_instruction(context);
+ interrupt_handle_pending(context);
+ break;
+
+ case trap_Error:
+ case trap_Cerror:
+ interrupt_internal_error(signal, siginfo, context, im5==trap_Cerror);
+ break;
+
+ case trap_Breakpoint:
+ /*sigsetmask(scp->sc_mask); */
+ handle_breakpoint(signal, siginfo, context);
+ break;
+
+ case trap_FunEndBreakpoint:
+ /*sigsetmask(scp->sc_mask); */
+ {
+ unsigned long pc;
+ pc = (unsigned long)
+ handle_fun_end_breakpoint(signal, siginfo, context);
+ *os_context_pc_addr(context) = pc;
+ *os_context_npc_addr(context) = pc + 4;
+ }
+ break;
+
+ case trap_SingleStepBreakpoint:
+ /* Uh, FIXME */
+#ifdef hpux
+ restore_breakpoint(context);
+#endif
+ break;
+
+ default:
+ interrupt_handle_now(signal, siginfo, context);
+ break;
+ }
+ }
+}
+
+static void sigfpe_handler(int signal, siginfo_t *siginfo, void *void_context)
+{
+ os_context_t *context = arch_os_get_context(&void_context);
+ unsigned long badinst;
+ int opcode, r1, r2, t;
+ long op1, op2, res;
+
+#if 0
+ printf("sigfpe_handler, pc=0x%08x, alloc=0x%08x\n", scp->sc_pcoqh,
+ SC_REG(scp,reg_ALLOC));
+#endif
+
+ switch (siginfo->si_code) {
+ case FPE_INTOVF: /*I_OVFLO: */
+ badinst = *(unsigned long *)(*os_context_pc_addr(context) & ~3);
+ opcode = badinst >> 26;
+
+ if (opcode == 2) {
+ /* reg/reg inst. */
+ r1 = (badinst >> 16) & 0x1f;
+ op1 = fixnum_value(*os_context_register_addr(context, r1));
+ r2 = (badinst >> 21) & 0x1f;
+ op2 = fixnum_value(*os_context_register_addr(context, r2));
+ t = badinst & 0x1f;
+
+ switch ((badinst >> 5) & 0x7f) {
+ case 0x70:
+ /* Add and trap on overflow. */
+ res = op1 + op2;
+ break;
+
+ case 0x60:
+ /* Subtract and trap on overflow. */
+ res = op1 - op2;
+ break;
+
+ default:
+ goto not_interesting;
+ }
+ }
+ else if ((opcode & 0x37) == 0x25 && (badinst & (1<<11))) {
+ /* Add or subtract immediate. */
+ op1 = ((badinst >> 3) & 0xff) | ((-badinst&1)<<8);
+ r2 = (badinst >> 16) & 0x1f;
+ op2 = fixnum_value(*os_context_register_addr(context, r1));
+ t = (badinst >> 21) & 0x1f;
+ if (opcode == 0x2d)
+ res = op1 + op2;
+ else
+ res = op1 - op2;
+ }
+ else
+ goto not_interesting;
+
+ /* ?? What happens here if we hit the end of dynamic space? */
+ dynamic_space_free_pointer = (lispobj *) *os_context_register_addr(context, reg_ALLOC);
+ *os_context_register_addr(context, t) = alloc_number(res);
+ *os_context_register_addr(context, reg_ALLOC)
+ = (unsigned long) dynamic_space_free_pointer;
+ arch_skip_instruction(context);
+
+ break;
+
+ case 0: /* I_COND: ?? Maybe tagged add?? FIXME */
+ badinst = *(unsigned long *)(*os_context_pc_addr(context) & ~3);
+ if ((badinst&0xfffff800) == (0xb000e000|reg_ALLOC<<21|reg_ALLOC<<16)) {
+ /* It is an ADDIT,OD i,ALLOC,ALLOC instruction that trapped. */
+ /* That means that it is the end of a pseudo-atomic. So do the */
+ /* add stripping off the pseudo-atomic-interrupted bit, and then */
+ /* tell the machine-independent code to process the pseudo- */
+ /* atomic. */
+ int immed = (badinst>>1)&0x3ff;
+ if (badinst & 1)
+ immed |= -1<<10;
+ *os_context_register_addr(context, reg_ALLOC) += (immed-1);
+ arch_skip_instruction(context);
+ interrupt_handle_pending(context);
+ break;
+ }
+ /* else drop-through. */
+ default:
+ not_interesting:
+ interrupt_handle_now(signal, siginfo, context);
+ }
+}
+
+/* Merrily cut'n'pasted from sigfpe_handler. On Linux, until
+ 2.4.19-pa4 (hopefully), the overflow_trap wasn't implemented,
+ resulting in a SIGBUS instead. We adapt the sigfpe_handler here, in
+ the hope that it will do as a replacement until the new kernel sees
+ the light of day. Since the instructions that we need to fix up
+ tend not to be doing unaligned memory access, this should be a safe
+ workaround. -- CSR, 2002-08-17 */
+static void sigbus_handler(int signal, siginfo_t *siginfo, void *void_context)
+{
+ os_context_t *context = arch_os_get_context(&void_context);
+ unsigned long badinst;
+ int opcode, r1, r2, t;
+ long op1, op2, res;
+
+ badinst = *(unsigned long *)(*os_context_pc_addr(context) & ~3);
+ /* First, test for the pseudo-atomic instruction */
+ if ((badinst & 0xfffff800) == (0xb000e000 |
+ reg_ALLOC<<21 |
+ reg_ALLOC<<16)) {
+ /* It is an ADDIT,OD i,ALLOC,ALLOC instruction that trapped.
+ That means that it is the end of a pseudo-atomic. So do
+ the add stripping off the pseudo-atomic-interrupted bit,
+ and then tell the machine-independent code to process the
+ pseudo-atomic. */
+ int immed = (badinst>>1) & 0x3ff;
+ if (badinst & 1)
+ immed |= -1<<10;
+ *os_context_register_addr(context, reg_ALLOC) += (immed-1);
+ arch_skip_instruction(context);
+ interrupt_handle_pending(context);
+ return;
+ } else {
+ opcode = badinst >> 26;
+ if (opcode == 2) {
+ /* reg/reg inst. */
+ r1 = (badinst >> 16) & 0x1f;
+ op1 = fixnum_value(*os_context_register_addr(context, r1));
+ r2 = (badinst >> 21) & 0x1f;
+ op2 = fixnum_value(*os_context_register_addr(context, r2));
+ t = badinst & 0x1f;
+
+ switch ((badinst >> 5) & 0x7f) {
+ case 0x70:
+ /* Add and trap on overflow. */
+ res = op1 + op2;
+ break;
+
+ case 0x60:
+ /* Subtract and trap on overflow. */
+ res = op1 - op2;
+ break;
+
+ default:
+ goto not_interesting;
+ }
+ } else if ((opcode & 0x37) == 0x25 && (badinst & (1<<11))) {
+ /* Add or subtract immediate. */
+ op1 = ((badinst >> 3) & 0xff) | ((-badinst&1)<<8);
+ r2 = (badinst >> 16) & 0x1f;
+ op2 = fixnum_value(*os_context_register_addr(context, r1));
+ t = (badinst >> 21) & 0x1f;
+ if (opcode == 0x2d)
+ res = op1 + op2;
+ else
+ res = op1 - op2;
+ }
+ else
+ goto not_interesting;
+
+ /* ?? What happens here if we hit the end of dynamic space? */
+ dynamic_space_free_pointer = (lispobj *) *os_context_register_addr(context, reg_ALLOC);
+ *os_context_register_addr(context, t) = alloc_number(res);
+ *os_context_register_addr(context, reg_ALLOC)
+ = (unsigned long) dynamic_space_free_pointer;
+ arch_skip_instruction(context);
+
+ return;
+
+ not_interesting:
+ interrupt_handle_now(signal, siginfo, context);
+ }
+}
+
+
+void arch_install_interrupt_handlers(void)
+{
+ undoably_install_low_level_interrupt_handler(SIGTRAP,sigtrap_handler);
+ undoably_install_low_level_interrupt_handler(SIGFPE,sigfpe_handler);
+ /* FIXME: beyond 2.4.19-pa4 this shouldn't be necessary. */
+ undoably_install_low_level_interrupt_handler(SIGBUS,sigbus_handler);
+}
+
+lispobj funcall0(lispobj function)
+{
+ lispobj *args = current_control_stack_pointer;
+
+ return call_into_lisp(function, args, 0);
+}
+
+lispobj funcall1(lispobj function, lispobj arg0)
+{
+ lispobj *args = current_control_stack_pointer;
+
+ current_control_stack_pointer += 1;
+ args[0] = arg0;
+
+ return call_into_lisp(function, args, 1);
+}
+
+lispobj funcall2(lispobj function, lispobj arg0, lispobj arg1)
+{
+ lispobj *args = current_control_stack_pointer;
+
+ current_control_stack_pointer += 2;
+ args[0] = arg0;
+ args[1] = arg1;
+
+ return call_into_lisp(function, args, 2);
+}
+
+lispobj funcall3(lispobj function, lispobj arg0, lispobj arg1, lispobj arg2)
+{
+ lispobj *args = current_control_stack_pointer;
+
+ current_control_stack_pointer += 3;
+ args[0] = arg0;
+ args[1] = arg1;
+ args[2] = arg2;
+
+ return call_into_lisp(function, args, 3);
+}
--- /dev/null
+#ifndef _HPPA_ARCH_H
+#define _HPPA_ARCH_H
+
+#define ARCH_HAS_NPC_REGISTER
+
+#endif /* _HPPA_ARCH_H */
--- /dev/null
+#define LANGUAGE_ASSEMBLY
+
+#include "sbcl.h"
+#include "lispregs.h"
+
+ .import $global$,data
+ .import foreign_function_call_active,data
+ .import current_control_stack_pointer,data
+ .import current_control_frame_pointer,data
+ .import current_binding_stack_pointer,data
+ .import dynamic_space_free_pointer,data
+
+/* .space $TEXT$
+ .subspace $CODE$
+ .import $$dyncall,MILLICODE
+*/
+\f
+/*
+ * Call-into-lisp
+ */
+
+ .export call_into_lisp
+call_into_lisp:
+ .proc
+ .callinfo entry_gr=18,save_rp
+ .entry
+ /* %arg0=function, %arg1=cfp, %arg2=nargs */
+
+ stw %rp,-0x14(%sr0,%sp)
+ stwm %r3,0x40(%sr0,%sp)
+ stw %r4,-0x3c(%sr0,%sp)
+ stw %r5,-0x38(%sr0,%sp)
+ stw %r6,-0x34(%sr0,%sp)
+ stw %r7,-0x30(%sr0,%sp)
+ stw %r8,-0x2c(%sr0,%sp)
+ stw %r9,-0x28(%sr0,%sp)
+ stw %r10,-0x24(%sr0,%sp)
+ stw %r11,-0x20(%sr0,%sp)
+ stw %r12,-0x1c(%sr0,%sp)
+ stw %r13,-0x18(%sr0,%sp)
+ stw %r14,-0x14(%sr0,%sp)
+ stw %r15,-0x10(%sr0,%sp)
+ stw %r16,-0xc(%sr0,%sp)
+ stw %r17,-0x8(%sr0,%sp)
+ stw %r18,-0x4(%sr0,%sp)
+
+ /* Clear the descriptor regs, moving in args as approporate. */
+ copy %r0,reg_CODE
+ copy %r0,reg_FDEFN
+ copy %arg0,reg_LEXENV
+ zdep %arg2,29,30,reg_NARGS
+ copy %r0,reg_OCFP
+ copy %r0,reg_LRA
+ copy %r0,reg_A0
+ copy %r0,reg_A1
+ copy %r0,reg_A2
+ copy %r0,reg_A3
+ copy %r0,reg_A4
+ copy %r0,reg_A5
+ copy %r0,reg_L0
+ copy %r0,reg_L1
+ copy %r0,reg_L2
+
+ /* Establish NIL. */
+ ldil L%NIL,reg_NULL
+ ldo R%NIL(reg_NULL),reg_NULL
+
+ /* Turn on pseudo-atomic. */
+ ldo 4(%r0),reg_ALLOC
+
+ /* No longer in foreign function call land. */
+ addil L%foreign_function_call_active-$global$,%dp
+ stw %r0,R%foreign_function_call_active-$global$(0,%r1)
+
+ /* Load lisp state. */
+ addil L%dynamic_space_free_pointer-$global$,%dp
+ ldw R%dynamic_space_free_pointer-$global$(0,%r1),%r1
+ add reg_ALLOC,%r1,reg_ALLOC
+ addil L%current_binding_stack_pointer-$global$,%dp
+ ldw R%current_binding_stack_pointer-$global$(0,%r1),reg_BSP
+ addil L%current_control_stack_pointer-$global$,%dp
+ ldw R%current_control_stack_pointer-$global$(0,%r1),reg_CSP
+ addil L%current_control_frame_pointer-$global$,%dp
+ ldw R%current_control_frame_pointer-$global$(0,%r1),reg_OCFP
+ copy %arg1,reg_CFP
+
+ /* End of pseudo-atomic. */
+ addit,od -4,reg_ALLOC,reg_ALLOC
+
+ /* Establish lisp arguments. */
+ ldw 0(reg_CFP),reg_A0
+ ldw 4(reg_CFP),reg_A1
+ ldw 8(reg_CFP),reg_A2
+ ldw 12(reg_CFP),reg_A3
+ ldw 16(reg_CFP),reg_A4
+ ldw 20(reg_CFP),reg_A5
+
+ /* Calculate the LRA. */
+ ldil L%lra+OTHER_POINTER_LOWTAG,reg_LRA
+ ldo R%lra+OTHER_POINTER_LOWTAG(reg_LRA),reg_LRA
+
+ /* Indirect the closure */
+ ldw CLOSURE_FUN_OFFSET(0,reg_LEXENV),reg_CODE
+ addi 6*4-FUN_POINTER_LOWTAG,reg_CODE,reg_LIP
+
+ /* And into lisp we go. */
+ .export break_here
+break_here:
+ be,n 0(%sr5,reg_LIP)
+
+ break 0,0
+
+ .align 8
+lra:
+ .word RETURN_PC_HEADER_WIDETAG
+ copy reg_OCFP,reg_CSP
+
+ /* Copy CFP (%r4) into someplace else and restore r4. */
+ copy reg_CFP,reg_NL1
+ ldw -64(0,%sp),%r4
+
+ /* Copy the return value. */
+ copy reg_A0,%ret0
+
+ /* Turn on pseudo-atomic. */
+ addi 4,reg_ALLOC,reg_ALLOC
+
+ /* Store the lisp state. */
+ copy reg_ALLOC,reg_NL0
+ depi 0,31,3,reg_NL0
+ addil L%dynamic_space_free_pointer-$global$,%dp
+ stw reg_NL0,R%dynamic_space_free_pointer-$global$(0,%r1)
+ addil L%current_binding_stack_pointer-$global$,%dp
+ stw reg_BSP,R%current_binding_stack_pointer-$global$(0,%r1)
+ addil L%current_control_stack_pointer-$global$,%dp
+ stw reg_CSP,R%current_control_stack_pointer-$global$(0,%r1)
+ addil L%current_control_frame_pointer-$global$,%dp
+ stw reg_NL1,R%current_control_frame_pointer-$global$(0,%r1)
+
+ /* Back in C land. [CSP is just a handy non-zero value.] */
+ addil L%foreign_function_call_active-$global$,%dp
+ stw reg_CSP,R%foreign_function_call_active-$global$(0,%r1)
+
+ /* Turn off pseudo-atomic and check for traps. */
+ addit,od -4,reg_ALLOC,reg_ALLOC
+
+
+ ldw -0x54(%sr0,%sp),%rp
+ ldw -0x4(%sr0,%sp),%r18
+ ldw -0x8(%sr0,%sp),%r17
+ ldw -0xc(%sr0,%sp),%r16
+ ldw -0x10(%sr0,%sp),%r15
+ ldw -0x14(%sr0,%sp),%r14
+ ldw -0x18(%sr0,%sp),%r13
+ ldw -0x1c(%sr0,%sp),%r12
+ ldw -0x20(%sr0,%sp),%r11
+ ldw -0x24(%sr0,%sp),%r10
+ ldw -0x28(%sr0,%sp),%r9
+ ldw -0x2c(%sr0,%sp),%r8
+ ldw -0x30(%sr0,%sp),%r7
+ ldw -0x34(%sr0,%sp),%r6
+ ldw -0x38(%sr0,%sp),%r5
+ ldw -0x3c(%sr0,%sp),%r4
+ bv %r0(%rp)
+ ldwm -0x40(%sr0,%sp),%r3
+
+
+ /* And thats all. */
+ .exit
+ .procend
+
+\f
+/*
+ * Call-into-C
+ */
+
+
+ .export call_into_c
+call_into_c:
+ /* Set up a lisp stack frame. Note: we convert the raw return pc into
+ * a fixnum pc-offset because we don't have ahold of an lra object.
+ */
+ copy reg_CFP, reg_OCFP
+ copy reg_CSP, reg_CFP
+ addi 32, reg_CSP, reg_CSP
+ stw reg_OCFP, 0(0,reg_CFP)
+ sub reg_LIP, reg_CODE, reg_NL5
+ addi 3-OTHER_POINTER_LOWTAG, reg_NL5, reg_NL5
+ stw reg_NL5, 4(0,reg_CFP)
+ stw reg_CODE, 8(0,reg_CFP)
+
+ /* Turn on pseudo-atomic. */
+ addi 4, reg_ALLOC, reg_ALLOC
+
+ /* Store the lisp state. */
+ copy reg_ALLOC,reg_NL5
+ depi 0,31,3,reg_NL5
+ addil L%dynamic_space_free_pointer-$global$,%dp
+ stw reg_NL5,R%dynamic_space_free_pointer-$global$(0,%r1)
+ addil L%current_binding_stack_pointer-$global$,%dp
+ stw reg_BSP,R%current_binding_stack_pointer-$global$(0,%r1)
+ addil L%current_control_stack_pointer-$global$,%dp
+ stw reg_CSP,R%current_control_stack_pointer-$global$(0,%r1)
+ addil L%current_control_frame_pointer-$global$,%dp
+ stw reg_CFP,R%current_control_frame_pointer-$global$(0,%r1)
+
+ /* Back in C land. [CSP is just a handy non-zero value.] */
+ addil L%foreign_function_call_active-$global$,%dp
+ stw reg_CSP,R%foreign_function_call_active-$global$(0,%r1)
+
+ /* Turn off pseudo-atomic and check for traps. */
+ addit,od -4,reg_ALLOC,reg_ALLOC
+
+ /* in order to be able to call incrementally linked (ld -A) functions,
+ we have to do some mild trickery here */
+ copy reg_CFUNC,%r22
+ bl $$dyncall,%r31
+ copy %r31, %r2
+
+ /* Clear the callee saves descriptor regs. */
+ copy %r0, reg_A5
+ copy %r0, reg_L0
+ copy %r0, reg_L1
+ copy %r0, reg_L2
+
+ /* Turn on pseudo-atomic. */
+ ldi 4, reg_ALLOC
+
+ /* Turn off foreign function call. */
+ addil L%foreign_function_call_active-$global$,%dp
+ stw %r0,R%foreign_function_call_active-$global$(0,%r1)
+
+ /* Load ALLOC. */
+ addil L%dynamic_space_free_pointer-$global$,%dp
+ ldw R%dynamic_space_free_pointer-$global$(0,%r1),%r1
+ add reg_ALLOC,%r1,reg_ALLOC
+
+ /* We don't need to load OCFP, CFP, CSP, or BSP because they are
+ * in caller saves registers.
+ */
+
+ /* End of pseudo-atomic. */
+ addit,od -4,reg_ALLOC,reg_ALLOC
+
+ /* Restore CODE. Even though it is in a callee saves register
+ * it might have been GC'ed.
+ */
+ ldw 8(0,reg_CFP), reg_CODE
+
+ /* Restore the return pc. */
+ ldw 4(0,reg_CFP), reg_NL0
+ addi OTHER_POINTER_LOWTAG-3, reg_NL0, reg_NL0
+ add reg_CODE, reg_NL0, reg_LIP
+
+ /* Pop the lisp stack frame, and back we go. */
+ copy reg_CFP, reg_CSP
+ be 0(4,reg_LIP)
+ copy reg_OCFP, reg_CFP
+
+
+\f
+/*
+ * Stuff to sanctify a block of memory for execution.
+ */
+
+ .EXPORT sanctify_for_execution
+sanctify_for_execution:
+ .proc
+ .callinfo
+ .entry
+ /* %arg0=start addr, %arg1=length in bytes */
+ add %arg0,%arg1,%arg1
+ ldo -1(%arg1),%arg1
+ depi 0,31,5,%arg0
+ depi 0,31,5,%arg1
+ ldsid (%arg0),%r1
+ mtsp %r1,%sr1
+ ldi 32,%r1 ; bytes per cache line
+sanctify_loop:
+ fdc 0(%sr1,%arg0)
+ comb,< %arg0,%arg1,sanctify_loop
+ fic,m %r1(%sr1,%arg0)
+
+ bv %r0(%rp)
+ nop
+
+ .exit
+ .procend
+
+\f
+/*
+ * Trampolines.
+ */
+
+ .EXPORT closure_tramp
+closure_tramp:
+ /* reg_FDEFN holds the fdefn object. */
+ ldw FDEFN_FUN_OFFSET(0,reg_FDEFN),reg_LEXENV
+ ldw CLOSURE_FUN_OFFSET(0,reg_LEXENV),reg_L0
+ addi SIMPLE_FUN_CODE_OFFSET, reg_L0, reg_LIP
+ bv,n 0(reg_LIP)
+
+ .EXPORT undefined_tramp
+undefined_tramp:
+ break trap_Error,0
+ .byte 4
+ .byte UNDEFINED_FUN_ERROR
+ .byte 254
+ .byte (0x40 + sc_DescriptorReg)
+ .byte 1
+ .align 4
+
+\f
+/*
+ * Core saving/restoring support
+ */
+
+ .export call_on_stack
+call_on_stack:
+ /* %arg0 = fn to invoke, %arg1 = new stack base */
+
+ /* Compute the new stack pointer. */
+ addi 64,%arg1,%sp
+
+ /* Zero out the previous stack pointer. */
+ stw %r0,-4(0,%sp)
+
+ /* Invoke the function. */
+ ble 0(4,%arg0)
+ copy %r31, %r2
+
+ /* Flame out. */
+ break 0,0
+
+ .export save_state
+save_state:
+ .proc
+ .callinfo entry_gr=18,entry_fr=21,save_rp,calls
+ .entry
+
+ stw %rp,-0x14(%sr0,%sp)
+ fstds,ma %fr12,8(%sr0,%sp)
+ fstds,ma %fr13,8(%sr0,%sp)
+ fstds,ma %fr14,8(%sr0,%sp)
+ fstds,ma %fr15,8(%sr0,%sp)
+ fstds,ma %fr16,8(%sr0,%sp)
+ fstds,ma %fr17,8(%sr0,%sp)
+ fstds,ma %fr18,8(%sr0,%sp)
+ fstds,ma %fr19,8(%sr0,%sp)
+ fstds,ma %fr20,8(%sr0,%sp)
+ fstds,ma %fr21,8(%sr0,%sp)
+ stwm %r3,0x70(%sr0,%sp)
+ stw %r4,-0x6c(%sr0,%sp)
+ stw %r5,-0x68(%sr0,%sp)
+ stw %r6,-0x64(%sr0,%sp)
+ stw %r7,-0x60(%sr0,%sp)
+ stw %r8,-0x5c(%sr0,%sp)
+ stw %r9,-0x58(%sr0,%sp)
+ stw %r10,-0x54(%sr0,%sp)
+ stw %r11,-0x50(%sr0,%sp)
+ stw %r12,-0x4c(%sr0,%sp)
+ stw %r13,-0x48(%sr0,%sp)
+ stw %r14,-0x44(%sr0,%sp)
+ stw %r15,-0x40(%sr0,%sp)
+ stw %r16,-0x3c(%sr0,%sp)
+ stw %r17,-0x38(%sr0,%sp)
+ stw %r18,-0x34(%sr0,%sp)
+
+
+ /* Remember the function we want to invoke */
+ copy %arg0,%r19
+
+ /* Pass the new stack pointer in as %arg0 */
+ copy %sp,%arg0
+
+ /* Leave %arg1 as %arg1. */
+
+ /* do the call. */
+ ble 0(4,%r19)
+ copy %r31, %r2
+
+ .export _restore_state
+_restore_state:
+
+ ldw -0xd4(%sr0,%sp),%rp
+ ldw -0x34(%sr0,%sp),%r18
+ ldw -0x38(%sr0,%sp),%r17
+ ldw -0x3c(%sr0,%sp),%r16
+ ldw -0x40(%sr0,%sp),%r15
+ ldw -0x44(%sr0,%sp),%r14
+ ldw -0x48(%sr0,%sp),%r13
+ ldw -0x4c(%sr0,%sp),%r12
+ ldw -0x50(%sr0,%sp),%r11
+ ldw -0x54(%sr0,%sp),%r10
+ ldw -0x58(%sr0,%sp),%r9
+ ldw -0x5c(%sr0,%sp),%r8
+ ldw -0x60(%sr0,%sp),%r7
+ ldw -0x64(%sr0,%sp),%r6
+ ldw -0x68(%sr0,%sp),%r5
+ ldw -0x6c(%sr0,%sp),%r4
+ ldwm -0x70(%sr0,%sp),%r3
+ fldds,mb -8(%sr0,%sp),%fr21
+ fldds,mb -8(%sr0,%sp),%fr20
+ fldds,mb -8(%sr0,%sp),%fr19
+ fldds,mb -8(%sr0,%sp),%fr18
+ fldds,mb -8(%sr0,%sp),%fr17
+ fldds,mb -8(%sr0,%sp),%fr16
+ fldds,mb -8(%sr0,%sp),%fr15
+ fldds,mb -8(%sr0,%sp),%fr14
+ fldds,mb -8(%sr0,%sp),%fr13
+ bv %r0(%rp)
+ fldds,mb -8(%sr0,%sp),%fr12
+
+
+ .exit
+ .procend
+
+ .export restore_state
+restore_state:
+ .proc
+ .callinfo
+ copy %arg0,%sp
+ b _restore_state
+ copy %arg1,%ret0
+ .procend
+
+
+
+ .export SingleStepTraps
+SingleStepTraps:
+ break trap_SingleStepBreakpoint,0
+ break trap_SingleStepBreakpoint,0
+/* Missing !! NOT
+ there's a break 0,0 in the new version here!!!
+*/
+
+ .align 8
+ .export fun_end_breakpoint_guts
+fun_end_breakpoint_guts:
+ .word RETURN_PC_HEADER_WIDETAG
+ /* multiple value return point -- just jump to trap. */
+ b,n fun_end_breakpoint_trap
+ /* single value return point -- convert to multiple w/ n=1 */
+ copy reg_CSP, reg_OCFP
+ addi 4, reg_CSP, reg_CSP
+ addi 4, %r0, reg_NARGS
+ copy reg_NULL, reg_A1
+ copy reg_NULL, reg_A2
+ copy reg_NULL, reg_A3
+ copy reg_NULL, reg_A4
+ copy reg_NULL, reg_A5
+
+ .export fun_end_breakpoint_trap
+fun_end_breakpoint_trap:
+ break trap_FunEndBreakpoint,0
+ b,n fun_end_breakpoint_trap
+
+ .export fun_end_breakpoint_end
+fun_end_breakpoint_end:
--- /dev/null
+/*
+ * This is the HPPA Linux incarnation of arch-dependent OS-dependent
+ * routines. See also "linux-os.c".
+ */
+
+/*
+ * 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.
+ */
+
+#include <stdio.h>
+#include <sys/param.h>
+#include <sys/file.h>
+#include "./signal.h"
+#include "os.h"
+#include "arch.h"
+#include "globals.h"
+#include "interrupt.h"
+#include "interr.h"
+#include "lispregs.h"
+#include "sbcl.h"
+#include <sys/socket.h>
+#include <sys/utsname.h>
+
+#include <sys/types.h>
+#include <signal.h>
+#include <sys/time.h>
+#include <sys/stat.h>
+#include <unistd.h>
+
+#include "validate.h"
+size_t os_vm_page_size;
+
+
+os_context_register_t *
+os_context_register_addr(os_context_t *context, int offset)
+{
+ if (offset == 0) {
+ /* KLUDGE: I'm not sure, but it's possible that Linux puts the
+ contents of the Processor Status Word in the (wired-zero)
+ slot in the mcontext. In any case, the following is
+ unlikely to do any harm: */
+ static int zero;
+ zero = 0;
+ return &zero;
+ } else {
+ return &(((struct sigcontext *) &(context->uc_mcontext))->sc_gr[offset]);
+ }
+}
+
+os_context_register_t *
+os_context_pc_addr(os_context_t *context)
+{
+ /* Why do I get all the silly ports? -- CSR, 2002-08-11 */
+ return &(((struct sigcontext *) &(context->uc_mcontext))->sc_iaoq[0]);
+}
+
+os_context_register_t *
+os_context_npc_addr(os_context_t *context)
+{
+ return &(((struct sigcontext *) &(context->uc_mcontext))->sc_iaoq[1]);
+}
+
+sigset_t *
+os_context_sigmask_addr(os_context_t *context)
+{
+ return &(context->uc_sigmask);
+}
+
+void
+os_restore_fp_control(os_context_t *context)
+{
+ /* FIXME: Probably do something. */
+}
+
+void
+os_flush_icache(os_vm_address_t address, os_vm_size_t length)
+{
+ /* FIXME: Maybe this is OK. */
+ sanctify_for_execution(address,length);
+}
--- /dev/null
+#ifndef _HPPA_LINUX_OS_H
+#define _HPPA_LINUX_OS_H
+
+typedef struct ucontext os_context_t;
+
+static inline os_context_t *arch_os_get_context(void **void_context) {
+ return (os_context_t *) *void_context;
+}
+
+unsigned long os_context_fp_control(os_context_t *context);
+void os_restore_fp_control(os_context_t *context);
+
+#endif /* _HPPA_LINUX_OS_H */
--- /dev/null
+#define NREGS (32)
+
+#ifdef LANGUAGE_ASSEMBLY
+#define REG(num) num
+#else
+#define REG(num) num
+#endif
+
+#define reg_ZERO REG(0)
+#define reg_NFP REG(1)
+#define reg_CFUNC REG(2)
+#define reg_CSP REG(3)
+#define reg_CFP REG(4)
+#define reg_BSP REG(5)
+#define reg_NULL REG(6)
+#define reg_ALLOC REG(7)
+#define reg_CODE REG(8)
+#define reg_FDEFN REG(9)
+#define reg_LEXENV REG(10)
+#define reg_NARGS REG(11)
+#define reg_OCFP REG(12)
+#define reg_LRA REG(13)
+#define reg_A0 REG(14)
+#define reg_A1 REG(15)
+#define reg_A2 REG(16)
+#define reg_A3 REG(17)
+#define reg_A4 REG(18)
+#define reg_A5 REG(19)
+#define reg_L0 REG(20)
+#define reg_L1 REG(21)
+#define reg_L2 REG(22)
+#define reg_NL3 REG(23)
+#define reg_NL2 REG(24)
+#define reg_NL1 REG(25)
+#define reg_NL0 REG(26)
+#define reg_DP REG(27)
+#define reg_NL4 REG(28)
+#define reg_NL5 REG(29)
+#define reg_NSP REG(30)
+#define reg_LIP REG(31)
+
+
+#define REGNAMES \
+ "ZERO", "NFP", "CFUNC", "CSP", "CFP", "BSP", "NULL", "ALLOC", \
+ "CODE", "FDEFN", "LEXENV", "NARGS", "OCFP", "LRA", "A0", "A1", \
+ "A2", "A3", "A4", "A5", "L0", "L1", "L2", "NL3", \
+ "NL2", "NL1", "NL0", "DP", "NL4", "NL5", "NSP", "LIP"
+
+#define BOXED_REGISTERS { \
+ reg_CODE, reg_FDEFN, reg_LEXENV, reg_NARGS, reg_OCFP, reg_LRA, \
+ reg_A0, reg_A1, reg_A2, reg_A3, reg_A4, reg_A5, \
+ reg_L0, reg_L1, reg_L2 \
+}
+
+#ifdef hpux
+#define SC_REG(sc, n) (((unsigned long *)(&(sc)->sc_sl.sl_ss.ss_flags))[n])
+#define SC_PC(sc) ((sc)->sc_sl.sl_ss.ss_pcoq_head)
+#define SC_NPC(sc) ((sc)->sc_sl.sl_ss.ss_pcoq_tail)
+#else
+#define SC_REG(sc, n) (((unsigned long *)((sc)->sc_ap))[n])
+#define SC_PC(sc) ((sc)->sc_pcoqh)
+#define SC_NPC(sc) ((sc)->sc_pcoqt)
+#endif
-/*
-
- $Header$
-
- This code was written as part of the CMU Common Lisp project at
- Carnegie Mellon University, and has been placed in the public domain.
-
-*/
-
#include <stdio.h>
#include "arch.h"
/*
-
- $Header$
-
- This code was written as part of the CMU Common Lisp project at
- Carnegie Mellon University, and has been placed in the public domain.
-
-*/
-
+ * 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.
+ */
#include <stdio.h>
#include "runtime.h"
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.7.6.26"
+"0.7.6.27"
projects / sbcl.git / commitdiff