* Based on a mix of the old hppa-code and the mips backend.
* Patch by Larry Valkama.
(inst xor res sign res)
(inst add res sign res))
-
-#+sb-assembling
(define-assembly-routine
(truncate)
((:arg dividend signed-reg nl0-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)
(inst move dividend zero-tn :>=)
(inst sub zero-tn rem rem))
-
\f
;;;; Generic arithmetic.
(: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 temp non-descriptor-reg nl0-offset)
+ (:temp temp1 non-descriptor-reg nl1-offset)
+ (:temp temp2 non-descriptor-reg nl2-offset)
(:temp lra descriptor-reg lra-offset)
+ (:temp lip interior-reg lip-offset)
(:temp nargs any-reg nargs-offset)
(:temp ocfp any-reg ocfp-offset))
- (inst 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)
+ ;; If either arg is not fixnum, use two-arg-+ to summarize
+ (inst or x y temp)
+ (inst extru temp 31 3 zero-tn :=)
+ (inst b DO-STATIC-FUN :nullify t)
+ ;; check for overflow
+ (inst add x y temp)
+ (inst xor temp x temp1)
+ (inst xor temp y temp2)
+ (inst and temp1 temp2 temp1)
+ (inst bc :< nil temp1 zero-tn DO-OVERFLOW)
+ (inst move temp res)
+ (lisp-return lra :offset 1)
+
+ DO-OVERFLOW
+ ;; We did overflow, so do the bignum version
+ (inst sra x n-fixnum-tag-bits temp1)
+ (inst sra y n-fixnum-tag-bits temp2)
+ (inst add temp1 temp2 temp)
+ (with-fixed-allocation (res nil temp2 bignum-widetag
+ (1+ bignum-digits-offset) nil)
+ (storew temp res bignum-digits-offset other-pointer-lowtag))
(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)
+ (move cfp-tn ocfp)
(inst bv lip)
- (inst move csp-tn cfp-tn))
+ (move csp-tn cfp-tn t))
(define-assembly-routine (generic--
(:cost 10)
(:res res (descriptor-reg any-reg) a0-offset)
- (:temp lip interior-reg lip-offset)
+ (:temp temp non-descriptor-reg nl0-offset)
+ (:temp temp1 non-descriptor-reg nl1-offset)
+ (:temp temp2 non-descriptor-reg nl2-offset)
(:temp lra descriptor-reg lra-offset)
+ (:temp lip interior-reg lip-offset)
(:temp nargs any-reg nargs-offset)
(:temp ocfp any-reg ocfp-offset))
- (inst 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)
+ ;; If either arg is not fixnum, use two-arg-+ to summarize
+ (inst or x y temp)
+ (inst extru temp 31 3 zero-tn :=)
+ (inst b DO-STATIC-FUN :nullify t)
+ (inst sub x y temp)
+ ;; check for overflow
+ (inst xor x y temp1)
+ (inst xor x temp temp2)
+ (inst and temp2 temp1 temp1)
+ (inst bc :< nil temp1 zero-tn DO-OVERFLOW)
+ (inst move temp res)
+ (lisp-return lra :offset 1)
+
+ DO-OVERFLOW
+ ;; We did overflow, so do the bignum version
+ (inst sra x n-fixnum-tag-bits temp1)
+ (inst sra y n-fixnum-tag-bits temp2)
+ (inst sub temp1 temp2 temp)
+ (with-fixed-allocation (res nil temp2 bignum-widetag
+ (1+ bignum-digits-offset) nil)
+ (storew temp res bignum-digits-offset other-pointer-lowtag))
(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)
+ (move cfp-tn ocfp)
(inst bv lip)
- (inst move csp-tn cfp-tn))
-
+ (move csp-tn cfp-tn t))
\f
;;;; Comparison routines.
(in-package "SB!VM")
-
-;;;; 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))
(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 ocfp 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 dst 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 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)
-
+ ;; Note, because of the way the return-multiple vop is written, we can
+ ;; assume that we are never called with nvals == 1 and that a0 has already
+ ;; been loaded. ;FIX-lav: look at old hppa , replace comb+addi with addib
+ (inst comb :<= nvals zero-tn DEFAULT-A0-AND-ON)
+ (inst addi (- (fixnumize 2)) nvals count)
+ (inst comb :<= count zero-tn DEFAULT-A2-AND-ON)
+ (inst ldw (* 1 n-word-bytes) vals a1)
+ (inst addib :<= (- (fixnumize 1)) count DEFAULT-A3-AND-ON)
+ (inst ldw (* 2 n-word-bytes) vals a2)
+ (inst addib :<= (- (fixnumize 1)) count DEFAULT-A4-AND-ON)
+ (inst ldw (* 3 n-word-bytes) vals a3)
+ (inst addib :<= (- (fixnumize 1)) count DEFAULT-A5-AND-ON)
+ (inst ldw (* 4 n-word-bytes) vals a4)
+ (inst addib :<= (- (fixnumize 1)) count done)
+ (inst ldw (* 5 n-word-bytes) vals a5)
;; 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)
-
+ (inst addi (fixnumize register-arg-count) vals vals)
+ (inst addi (fixnumize register-arg-count) 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)
+ (inst ldwm n-word-bytes vals temp)
+ (inst addib :<> (- (fixnumize 1)) count LOOP)
+ (inst stwm temp n-word-bytes dst)
+ (inst b DONE :nullify t)
DEFAULT-A0-AND-ON
- (inst move null-tn a0)
- DEFAULT-A1-AND-ON
- (inst move null-tn a1)
+ (move null-tn a0)
+ (move null-tn a1)
DEFAULT-A2-AND-ON
- (inst move null-tn a2)
+ (move null-tn a2)
DEFAULT-A3-AND-ON
- (inst move null-tn a3)
+ (move null-tn a3)
DEFAULT-A4-AND-ON
- (inst move null-tn a4)
+ (move null-tn a4)
DEFAULT-A5-AND-ON
- (inst move null-tn a5)
-
+ (move null-tn a5)
DONE
;; Clear the stack.
(move cfp-tn ocfp-tn)
- (move old-fp cfp-tn)
+ (move ocfp cfp-tn)
(inst add ocfp-tn nvals csp-tn)
-
- ;; Return.
(lisp-return lra))
-
\f
;;;; tail-call-variable.
(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 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 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)
-
+ (inst addi (- (fixnumize register-arg-count)) nargs count)
+ (inst comb :<= count zero-tn done)
+ (inst addi (fixnumize register-arg-count) args src)
+ (inst addi (fixnumize 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)
-
+ ;; Copy one arg and increase src
+ (inst ldwm n-word-bytes src temp)
+ (inst addib :<> (- (fixnumize 1)) count LOOP)
+ (inst stwm temp n-word-bytes 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)
+ (:return-style :none)
(:policy :fast-safe))
((:arg block (any-reg descriptor-reg) a0-offset)
(:arg start (any-reg descriptor-reg) ocfp-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)
+ (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)
+ (inst b DO-EXIT)
(store-symbol-value next-uwp *current-unwind-protect-block*))
-
(define-assembly-routine
- throw
+ (throw
+ (:return-style :none))
((:arg target descriptor-reg a0-offset)
(:arg start any-reg ocfp-offset)
(:arg count any-reg nargs-offset)
(:temp catch any-reg a1-offset)
- (:temp tag descriptor-reg a2-offset))
+ (:temp tag descriptor-reg a2-offset)
+ (:temp fix descriptor-reg nl0-offset))
(declare (ignore start count)) ; We just need them in the registers.
(load-symbol-value catch *current-catch-block*)
(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)
+ (inst comb := tag target EXIT :nullify t)
+ (inst b LOOP)
(loadw catch catch catch-block-previous-catch-slot)
+ EXIT
+ (let ((fixup (make-fixup 'unwind :assembly-routine)))
+ (inst ldil fixup fix)
+ (inst ble fixup lisp-heap-space fix))
+ (move catch target t))
+
+; we need closure-tramp and funcallable-instance-tramp in
+; same space as other lisp-code, because caller is doing
+; normal lisp-calls where we doesnt specify space.
+; if we doesnt have the lisp-function (code from defun, closure, lambda etc..)
+; machine-address, resolve it here and jump to it.
+(define-assembly-routine
+ (closure-tramp (:return-style :none))
+ ((:temp lip interior-reg lip-offset)
+ (:temp nl0 descriptor-reg nl0-offset))
+ (inst ldw (- (* fdefn-fun-slot n-word-bytes)
+ other-pointer-lowtag)
+ fdefn-tn lexenv-tn)
+ (inst ldw (- (* closure-fun-slot n-word-bytes)
+ fun-pointer-lowtag)
+ lexenv-tn nl0)
+ (inst addi (- (* simple-fun-code-offset n-word-bytes)
+ fun-pointer-lowtag)
+ nl0 lip)
+ (inst bv lip :nullify t))
- (inst b *unwind-entry-point*)
- (inst move catch target))
+(define-assembly-routine
+ (funcallable-instance-tramp (:return-style :none))
+ nil
+ (inst nop)
+ (inst nop)
+ (inst nop)
+ (inst nop)
+ (inst nop)
+ (inst ldw 3 lexenv-tn lexenv-tn)
+ (inst ldw (- (* closure-fun-slot n-word-bytes)
+ fun-pointer-lowtag)
+ lexenv-tn code-tn)
+ (inst addi (- (* simple-fun-code-offset n-word-bytes)
+ fun-pointer-lowtag) code-tn lip-tn)
+ (inst bv lip-tn :nullify t))
#!+hpux
(define-assembly-routine
(!def-vm-support-routine generate-call-sequence (name style vop)
(ecase style
- (:raw
+ ((:raw :none)
(with-unique-names (fixup)
(values
`((let ((fixup (make-fixup ',name :assembly-routine)))
(inst ldil fixup ,fixup)
- (inst ble fixup lisp-heap-space ,fixup :nullify t))
- (inst nop))
+ (inst ble fixup lisp-heap-space ,fixup :nullify t)))
`((:temporary (:scs (any-reg) :from (:eval 0) :to (:eval 1))
,fixup)))))
(:full-call
(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)
+ (note-next-instruction ,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)
+ (without-scheduling ()
+ (emit-return-pc lra-label)
+ (note-this-location ,vop :single-value-return)
+ (inst move ocfp-tn csp-tn)
+ (inst nop)) ; this nop is here because of emit-return-pc align
(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))
+ :from (:eval 0) :to (:eval 1))
,lra)
(:temporary (:scs (control-stack) :offset nfp-save-offset)
,nfp-save)
- (:save-p :compute-only)))))
- (:none
- (with-unique-names (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)))))))
+ (:save-p t)))))))
(!def-vm-support-routine generate-return-sequence (style)
(ecase style
;;;; files for more information.
(in-package "SB!VM")
-
\f
;;;; LIST and LIST*
-
(define-vop (list-or-list*)
(:args (things :more t))
(:temporary (:scs (descriptor-reg) :type list) ptr)
(:results (result :scs (descriptor-reg)))
(:variant-vars star)
(:policy :safe)
+ (:node-var node)
(: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)))))))
-
+ (cond ((zerop num)
+ (move null-tn result))
+ ((and star (= num 1))
+ (move (tn-ref-tn things) result))
+ (t
+ (macrolet
+ ((store-car (tn list &optional (slot cons-car-slot))
+ `(let ((reg (sc-case ,tn
+ ((any-reg descriptor-reg zero null) ,tn)
+ (control-stack
+ (load-stack-tn temp ,tn)
+ temp))))
+ (storew reg ,list ,slot list-pointer-lowtag))))
+ (let* ((dx-p (node-stack-allocate-p node))
+ (cons-cells (if star (1- num) num))
+ (alloc (* (pad-data-block cons-size) cons-cells)))
+ (pseudo-atomic (:extra (if dx-p 0 alloc))
+ (when dx-p
+ (align-csp res))
+ (set-lowtag list-pointer-lowtag (if dx-p csp-tn alloc-tn) res)
+ (when dx-p
+ (inst addi alloc csp-tn csp-tn))
+ (move res ptr)
+ (dotimes (i (1- cons-cells))
+ (store-car (tn-ref-tn things) ptr)
+ (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))
+ (store-car (tn-ref-tn things) ptr)
+ (cond (star
+ (setf things (tn-ref-across things))
+ (store-car (tn-ref-tn things) ptr cons-cdr-slot))
+ (t
+ (storew null-tn ptr
+ cons-cdr-slot list-pointer-lowtag)))
+ (aver (null (tn-ref-across things)))
+ (move res result))))))))
(define-vop (list list-or-list*)
(:variant nil))
(: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 dep 0 31 n-lowtag-bits boxed)
(inst srl unboxed-arg word-shift unboxed)
(inst addi lowtag-mask unboxed unboxed)
- (inst dep 0 31 3 unboxed)
+ (inst dep 0 31 n-lowtag-bits unboxed)
+ (inst sll boxed (- n-widetag-bits word-shift) ndescr)
+ (inst addi code-header-widetag ndescr ndescr)
(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)
+ (set-lowtag other-pointer-lowtag alloc-tn 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)
+ (:translate make-fdefn)
+ (:policy :fast-safe)
(: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)
+ (with-fixed-allocation (result nil temp fdefn-widetag fdefn-size nil)
(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)
(define-vop (make-closure)
(:args (function :to :save :scs (descriptor-reg)))
(:info length stack-allocate-p)
- (:ignore stack-allocate-p)
(: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)))))
+ (with-fixed-allocation
+ (result nil temp closure-header-widetag
+ (+ length closure-info-offset)
+ stack-allocate-p :lowtag 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)
(:temporary (:scs (non-descriptor-reg)) temp)
(:results (result :scs (descriptor-reg)))
(:info stack-allocate-p)
- (:ignore stack-allocate-p)
(:generator 10
(with-fixed-allocation
- (result temp value-cell-header-widetag value-cell-size))
- (storew value result value-cell-value-slot other-pointer-lowtag)))
-
-
+ (result nil temp value-cell-header-widetag value-cell-size stack-allocate-p)
+ (storew value result value-cell-value-slot other-pointer-lowtag))))
\f
;;;; Automatic allocators for primitive objects.
(:args)
(:results (result :scs (any-reg)))
(:generator 1
- (inst li (make-fixup "funcallable_instance_tramp" :foreign) result)))
+ (inst li (make-fixup 'funcallable-instance-tramp :assembly-routine)
+ result)))
(define-vop (fixed-alloc)
(:args)
(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)
+ (inst dep 0 31 n-lowtag-bits bytes)
(pseudo-atomic ()
- (inst move alloc-tn result)
- (inst dep lowtag 31 3 result)
+ (set-lowtag lowtag alloc-tn result)
(storew header result 0 lowtag)
(inst add alloc-tn bytes alloc-tn))))
+
\f
;;;; Unary operations.
-(define-vop (fixnum-unop)
+(define-vop (fast-safe-arith-op)
+ (:policy :fast-safe)
+ (:effects)
+ (:affected))
+
+(define-vop (fixnum-unop fast-safe-arith-op)
(:args (x :scs (any-reg)))
(:results (res :scs (any-reg)))
(:note "inline fixnum arithmetic")
(:arg-types tagged-num)
- (:result-types tagged-num)
- (:policy :fast-safe))
+ (:result-types tagged-num))
-(define-vop (signed-unop)
+(define-vop (signed-unop fast-safe-arith-op)
(:args (x :scs (signed-reg)))
(:results (res :scs (signed-reg)))
(:note "inline (signed-byte 32) arithmetic")
(:arg-types signed-num)
- (:result-types signed-num)
- (:policy :fast-safe))
+ (:result-types signed-num))
(define-vop (fast-negate/fixnum fixnum-unop)
(:translate %negate)
(inst sub zero-tn x res)))
(define-vop (fast-lognot/fixnum fixnum-unop)
+ (:translate lognot)
(:temporary (:scs (any-reg) :type fixnum :to (:result 0))
temp)
- (:translate lognot)
(:generator 1
(inst li (fixnumize -1) temp)
(inst xor x temp res)))
;;; 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)))
+(define-vop (fast-fixnum-binop fast-safe-arith-op)
+ (:args (x :target r :scs (any-reg zero))
+ (y :target r :scs (any-reg zero)))
(:arg-types tagged-num tagged-num)
(:results (r :scs (any-reg)))
(:result-types tagged-num)
- (:note "inline fixnum arithmetic")
- (:effects)
- (:affected)
- (:policy :fast-safe))
+ (:note "inline fixnum arithmetic"))
-(define-vop (fast-unsigned-binop)
- (:args (x :target r :scs (unsigned-reg))
- (y :target r :scs (unsigned-reg)))
+(define-vop (fast-unsigned-binop fast-safe-arith-op)
+ (:args (x :target r :scs (unsigned-reg zero))
+ (y :target r :scs (unsigned-reg zero)))
(:arg-types unsigned-num unsigned-num)
(:results (r :scs (unsigned-reg)))
(:result-types unsigned-num)
- (:note "inline (unsigned-byte 32) arithmetic")
- (:effects)
- (:affected)
- (:policy :fast-safe))
+ (:note "inline (unsigned-byte 32) arithmetic"))
-(define-vop (fast-signed-binop)
- (:args (x :target r :scs (signed-reg))
- (y :target r :scs (signed-reg)))
+(define-vop (fast-signed-binop fast-safe-arith-op)
+ (:args (x :target r :scs (signed-reg zero))
+ (y :target r :scs (signed-reg zero)))
(:arg-types signed-num signed-num)
(:results (r :scs (signed-reg)))
(:result-types signed-num)
- (:note "inline (signed-byte 32) arithmetic")
- (:effects)
- (:affected)
- (:policy :fast-safe))
-
-(defmacro define-binop (translate cost untagged-cost op &optional arg-swap)
- `(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
- ,(if arg-swap
- `(inst ,op y x r)
- `(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
- ,(if arg-swap
- `(inst ,op y x r)
- `(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
- ,(if arg-swap
- `(inst ,op y x r)
- `(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 logandc1 1 2 andcm t)
-(define-binop logandc2 1 2 andcm)
-(define-binop logxor 1 2 xor)
+ (:note "inline (signed-byte 32) arithmetic"))
(define-vop (fast-fixnum-c-binop fast-fixnum-binop)
(:args (x :target r :scs (any-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)))
+(macrolet
+ ((define-binop (translate cost untagged-cost op arg-swap)
+ `(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 ,(1+ cost)
+ ,(if arg-swap
+ `(inst ,op y x r)
+ `(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 ,(1+ untagged-cost)
+ ,(if arg-swap
+ `(inst ,op y x r)
+ `(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 ,(1+ untagged-cost)
+ ,(if arg-swap
+ `(inst ,op y x r)
+ `(inst ,op x y r)))))))
+ (define-binop + 1 5 add nil)
+ (define-binop - 1 5 sub nil)
+ (define-binop logior 1 2 or nil)
+ (define-binop logand 1 2 and nil)
+ (define-binop logandc1 1 2 andcm t)
+ (define-binop logandc2 1 2 andcm nil)
+ (define-binop logxor 1 2 xor nil))
-(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)))
+(macrolet
+ ((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 8)) #.(ash 1 8))
+ (integer #.(- 1 (ash 1 10)) #.(ash 1 10))
+ (inst addi (- y) x r)))
+
+(define-vop (fast-lognor/fixnum=>fixnum fast-fixnum-binop)
+ (:translate lognor)
+ (:args (x :target r :scs (any-reg))
+ (y :target r :scs (any-reg)))
+ (:temporary (:sc non-descriptor-reg) temp)
+ (:generator 4
+ (inst or x y temp)
+ (inst uaddcm zero-tn temp temp)
+ (inst addi (- fixnum-tag-mask) temp r)))
-(define-vop (fast--/fixnum fast--/fixnum=>fixnum)
- (:results (r :scs (any-reg descriptor-reg)))
- (:result-types (:or signed-num unsigned-num))
- (:note nil)
+(define-vop (fast-lognor/signed=>signed fast-signed-binop)
+ (:translate lognor)
+ (:args (x :target r :scs (signed-reg))
+ (y :target r :scs (signed-reg)))
(:generator 4
- (inst subo x y r)))
+ (inst or x y r)
+ (inst uaddcm zero-tn r 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-lognor/unsigned=>unsigned fast-unsigned-binop)
+ (:translate lognor)
+ (:args (x :target r :scs (unsigned-reg))
+ (y :target r :scs (unsigned-reg)))
+ (:generator 4
+ (inst or x y r)
+ (inst uaddcm zero-tn r 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))
+(macrolet
+ ((fast-ash (name reg num tag save)
+ `(define-vop (,name)
+ (:translate ash)
+ (:note "inline ASH")
+ (:policy :fast-safe)
+ (:args (number :scs (,reg) :to :save)
+ (count :scs (signed-reg)
+ ,@(if save
+ '(:to :save))))
+ (:arg-types ,num ,tag)
+ (:results (result :scs (,reg)))
+ (:result-types ,num)
+ (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
+ (: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))))
+ (fast-ash fast-ash/unsigned=>unsigned unsigned-reg unsigned-num
+ tagged-num t)
+ (fast-ash fast-ash/signed=>signed signed-reg signed-num signed-num nil))
(define-vop (fast-ash-c/unsigned=>unsigned)
- (:policy :fast-safe)
(:translate ash)
- (:note nil)
+ (:note "inline ASH")
+ (:policy :fast-safe)
(: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)))))
+ (cond
+ ((< count -31) (move zero-tn result))
+ ((< count 0) (inst srl number (min (- count) 31) result))
+ ((> count 0) (inst sll number (min count 31) result))
+ (t (bug "identity ASH not transformed away")))))
(define-vop (fast-ash-c/signed=>signed)
- (:policy :fast-safe)
(:translate ash)
- (:note nil)
+ (:note "inline ASH")
+ (:policy :fast-safe)
(: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)))))
-
-;;; FIXME: implement FAST-ASH-LEFT/UNSIGNED=>UNSIGNED and friends, for
-;;; use in modular ASH (and because they're useful anyway). -- CSR,
-;;; 2004-08-16
+ (cond
+ ((< count 0) (inst sra number (min (- count) 31) result))
+ ((> count 0) (inst sll number (min count 31) result))
+ (t (bug "identity ASH not transformed away")))))
+
+(macrolet ((def (name sc-type type result-type cost)
+ `(define-vop (,name)
+ (:translate ash)
+ (:note "inline ASH")
+ (:policy :fast-safe)
+ (:args (number :scs (,sc-type))
+ (amount :scs (signed-reg unsigned-reg immediate)))
+ (:arg-types ,type positive-fixnum)
+ (:results (result :scs (,result-type)))
+ (:result-types ,type)
+ (:temporary (:scs (,sc-type) :to (:result 0)) temp)
+ (:generator ,cost
+ (sc-case amount
+ ((signed-reg unsigned-reg)
+ (inst subi 31 amount temp)
+ (inst mtctl temp :sar)
+ (inst zdep number :variable 32 result))
+ (immediate
+ (let ((amount (tn-value amount)))
+ (aver (> amount 0))
+ (inst sll number amount result))))))))
+ (def fast-ash-left/fixnum=>fixnum any-reg tagged-num any-reg 2)
+ (def fast-ash-left/signed=>signed signed-reg signed-num signed-reg 3)
+ (def fast-ash-left/unsigned=>unsigned unsigned-reg unsigned-num unsigned-reg 3))
(define-vop (signed-byte-32-len)
(:translate integer-length)
;;; 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))
+ (:translate *)
+ (:args (x :scs (any-reg zero) :target x-pass)
+ (y :scs (any-reg zero) :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
(: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 *)
+ (:ignore lip sign) ; fix-lav: why dont we ignore tmp ?
(:generator 30
+ ; looking at the register setup above, not sure if both can clash
+ ; maybe it is ok that x and x-pass share register ? like it was
(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))
+ (inst sra x 2 x-pass)
+ (inst move y y-pass))
(move res-pass r)))
(define-vop (fast-*/signed=>signed fast-signed-binop)
:from (:argument 1) :to (:result 0)) sign)
(:temporary (:sc interior-reg :offset lip-offset) lip)
(:ignore lip sign)
+ (: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)
+ (inst nop)
+ (move res-pass r))))
+
+(define-vop (fast-*/unsigned=>unsigned fast-unsigned-binop)
(:translate *)
+ (:args (x :scs (unsigned-reg) :target x-pass)
+ (y :scs (unsigned-reg) :target y-pass))
+ (:temporary (:sc unsigned-reg :offset nl0-offset
+ :from (:argument 0) :to (:result 0)) x-pass)
+ (:temporary (:sc unsigned-reg :offset nl1-offset
+ :from (:argument 1) :to (:result 0)) y-pass)
+ (:temporary (:sc unsigned-reg :offset nl2-offset :target r
+ :from (:argument 1) :to (:result 0)) res-pass)
+ (:temporary (:sc unsigned-reg :offset nl3-offset :to (:result 0)) tmp)
+ (:temporary (:sc unsigned-reg :offset nl4-offset
+ :from (:argument 1) :to (:result 0)) sign)
+ (:temporary (:sc interior-reg :offset lip-offset) lip)
+ (:ignore lip sign)
(: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 ble fixup lisp-heap-space tmp)
(inst nop)
(move res-pass r))))
: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))
+ (:results (q :scs (any-reg))
(r :scs (any-reg)))
(:result-types tagged-num tagged-num)
(:vop-var vop)
(inst ldil fixup q-pass)
(inst ble fixup lisp-heap-space q-pass :nullify t))
(inst nop)
+ (inst sll q-pass n-fixnum-tag-bits q)
+ ;(move q-pass q)
+ (move r-pass r)))
+
+(define-vop (fast-truncate/unsigned fast-unsigned-binop)
+ (:translate truncate)
+ (:args (x :scs (unsigned-reg) :target x-pass)
+ (y :scs (unsigned-reg) :target y-pass))
+ (:temporary (:sc unsigned-reg :offset nl0-offset
+ :from (:argument 0) :to (:result 0)) x-pass)
+ (:temporary (:sc unsigned-reg :offset nl1-offset
+ :from (:argument 1) :to (:result 0)) y-pass)
+ (:temporary (:sc unsigned-reg :offset nl2-offset :target q
+ :from (:argument 1) :to (:result 0)) q-pass)
+ (:temporary (:sc unsigned-reg :offset nl3-offset :target r
+ :from (:argument 1) :to (:result 1)) r-pass)
+ (:results (q :scs (unsigned-reg))
+ (r :scs (unsigned-reg)))
+ (:result-types unsigned-num unsigned-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)
+ ; really dirty trick to avoid the bug truncate/unsigned vop
+ ; followed by move-from/word->fixnum where the result from
+ ; the truncate is 0xe39516a7 and move-from-word will treat
+ ; the unsigned high number as an negative number.
+ ; instead we clear the high bit in the input to truncate.
+ (inst li #x1fffffff q)
+ (inst comb :<> q y skip :nullify t)
+ (inst addi -1 zero-tn q)
+ (inst srl q 1 q) ; this should result in #7fffffff
+ (inst and x-pass q x-pass)
+ (inst and y-pass q y-pass)
+ SKIP
+ ; fix bug#2 (truncate #xe39516a7 #x3) => #0xf687078d,#x0
+ (inst li #x7fffffff q)
+ (inst and x-pass q x-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)))
;;; consing the argument.
;;;
(define-vop (fast-eql/fixnum fast-conditional)
- (:args (x :scs (any-reg descriptor-reg))
+ (:args (x :scs (any-reg))
(y :scs (any-reg)))
(:arg-types tagged-num tagged-num)
(:note "inline fixnum comparison")
(inst bc := not-p x y target)))
;;;
(define-vop (generic-eql/fixnum fast-eql/fixnum)
+ (:args (x :scs (any-reg descriptor-reg))
+ (y :scs (any-reg)))
(:arg-types * tagged-num)
(:variant-cost 7))
(define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
- (:args (x :scs (any-reg descriptor-reg)))
+ (:args (x :scs (any-reg)))
(:arg-types tagged-num (:constant (signed-byte 9)))
(:info target not-p y)
(:translate eql)
(inst bci := not-p (fixnumize y) x target)))
;;;
(define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
+ (:args (x :scs (any-reg descriptor-reg)))
(:arg-types * (:constant (signed-byte 9)))
(:variant-cost 6))
+;;;; 32-bit logical operations
+
+(define-vop (merge-bits) ; not implemented, even used ?
+ (:translate merge-bits)
+ (:args (shift :scs (signed-reg unsigned-reg))
+ (prev :scs (unsigned-reg))
+ (next :scs (unsigned-reg)))
+ (:arg-types tagged-num unsigned-num unsigned-num)
+ (:results (result :scs (unsigned-reg)))
+ (:result-types unsigned-num)
+ (:policy :fast-safe)
+ (:ignore shift prev next)
+ (:generator 4
+ (inst li 0 result)
+ (inst break 0)))
+
\f
;;;; modular functions
-(define-modular-fun +-mod32 (x y) + :unsigned 32)
+(define-modular-fun +-mod32 (x y) + :untagged nil 32)
(define-vop (fast-+-mod32/unsigned=>unsigned fast-+/unsigned=>unsigned)
(:translate +-mod32))
(define-vop (fast-+-mod32-c/unsigned=>unsigned fast-+-c/unsigned=>unsigned)
(:translate +-mod32))
-(define-modular-fun --mod32 (x y) - :unsigned 32)
+(define-modular-fun --mod32 (x y) - :untagged nil 32)
(define-vop (fast---mod32/unsigned=>unsigned fast--/unsigned=>unsigned)
(:translate --mod32))
(define-vop (fast---mod32-c/unsigned=>unsigned fast---c/unsigned=>unsigned)
(define-vop (fast-ash-left-mod32-c/unsigned=>unsigned
fast-ash-c/unsigned=>unsigned)
(:translate ash-left-mod32))
+
(define-vop (fast-ash-left-mod32/unsigned=>unsigned
- ;; FIXME: when FAST-ASH-LEFT/UNSIGNED=>UNSIGNED is
- ;; implemented, use it here. -- CSR, 2004-08-16
- fast-ash/unsigned=>unsigned))
+ fast-ash-left/unsigned=>unsigned))
(deftransform ash-left-mod32 ((integer count)
((unsigned-byte 32) (unsigned-byte 5)))
(when (sb!c::constant-lvar-p count)
(sb!c::give-up-ir1-transform))
'(%primitive fast-ash-left-mod32/unsigned=>unsigned integer count))
-(define-modular-fun lognot-mod32 (x) lognot :unsigned 32)
+;;; logical operations
+(define-modular-fun lognot-mod32 (x) lognot :untagged nil 32)
(define-vop (lognot-mod32/unsigned=>unsigned)
(:translate lognot-mod32)
(:args (x :scs (unsigned-reg)))
(:generator 1
(inst uaddcm zero-tn x res)))
-(macrolet
- ((define-modular-backend (fun)
- (let ((mfun-name (symbolicate fun '-mod32))
- ;; FIXME: if anyone cares, add constant-arg vops. --
- ;; CSR, 2003-09-16
- (modvop (symbolicate 'fast- fun '-mod32/unsigned=>unsigned))
- (vop (symbolicate 'fast- fun '/unsigned=>unsigned)))
- `(progn
- (define-modular-fun ,mfun-name (x y) ,fun :unsigned 32)
- (define-vop (,modvop ,vop)
- (:translate ,mfun-name))))))
- (define-modular-backend logxor)
- (define-modular-backend logandc1)
- (define-modular-backend logandc2))
+(define-modular-fun lognor-mod32 (x y) lognor :untagged nil 32)
+(define-vop (fast-lognor-mod32/unsigned=>unsigned
+ fast-lognor/unsigned=>unsigned)
+ (:translate lognor-mod32))
(define-source-transform logeqv (&rest args)
(if (oddp (length args))
(define-source-transform lognand (x y)
`(lognot (logand ,x ,y)))
(define-source-transform lognor (x y)
- `(lognot (logior ,x y)))
+ `(lognot (logior ,x ,y)))
(define-vop (shift-towards-someplace)
(:policy :fast-safe)
(:arg-types unsigned-num)
(:conditional)
(:info target not-p)
- (:effects)
- (:affected)
- (:generator 1
+ (:generator 2
(inst bc :>= not-p digit zero-tn target)))
(define-vop (add-w/carry)
(:policy :fast-safe)
(:args (a :scs (unsigned-reg))
(b :scs (unsigned-reg))
- (c :scs (unsigned-reg)))
+ (c :scs (any-reg)))
(:arg-types unsigned-num unsigned-num positive-fixnum)
(:results (result :scs (unsigned-reg))
(carry :scs (unsigned-reg)))
(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 (bignum-lognot lognot-mod32/unsigned=>unsigned)
+ (:translate sb!bignum:%lognot))
(define-vop (fixnum-to-digit)
(:translate sb!bignum:%fixnum-to-digit)
(:policy :fast-safe)
- (:args (fixnum :scs (signed-reg)))
+ (:args (fixnum :scs (any-reg)))
(:arg-types tagged-num)
(:results (digit :scs (unsigned-reg)))
(:result-types unsigned-num)
(:generator 1
- (move fixnum digit)))
+ (inst sra fixnum n-fixnum-tag-bits digit)))
(define-vop (bignum-floor)
(:translate sb!bignum:%floor)
(:policy :fast-safe)
(:args (digit :scs (unsigned-reg) :target res))
(:arg-types unsigned-num)
- (:results (res :scs (signed-reg)))
+ (:results (res :scs (any-reg signed-reg)))
(:result-types signed-num)
(:generator 1
- (move digit res)))
+ (sc-case res
+ (any-reg
+ (inst sll digit n-fixnum-tag-bits res))
+ (signed-reg
+ (move digit res)))))
(define-vop (digit-lshr)
(:translate sb!bignum:%digit-logical-shift-right)
(define-static-fun two-arg-gcd (x y) :translate gcd)
(define-static-fun two-arg-lcm (x y) :translate lcm)
+(define-static-fun two-arg-+ (x y) :translate +)
+(define-static-fun two-arg-- (x y) :translate -)
(define-static-fun two-arg-* (x y) :translate *)
(define-static-fun two-arg-/ (x y) :translate /)
+(define-static-fun two-arg-< (x y) :translate <)
+(define-static-fun two-arg-<= (x y) :translate <=)
+(define-static-fun two-arg-> (x y) :translate >)
+(define-static-fun two-arg->= (x y) :translate >=)
+(define-static-fun two-arg-= (x y) :translate =)
+(define-static-fun two-arg-/= (x y) :translate /=)
+
(define-static-fun %negate (x) :translate %negate)
(define-static-fun two-arg-and (x y) :translate logand)
(define-static-fun two-arg-ior (x y) :translate logior)
(define-static-fun two-arg-xor (x y) :translate logxor)
+
(: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)
+ (:arg-types positive-fixnum positive-fixnum)
+ (:temporary (:scs (any-reg)) bytes)
+ (:temporary (:scs (non-descriptor-reg)) header)
(:results (result :scs (descriptor-reg)))
- (:generator 0
+ (:generator 13
+ ; Note: Cant use addi, the immediate is too large
+ (inst li (+ (* (1+ array-dimensions-offset) n-word-bytes)
+ lowtag-mask) header)
+ (inst add header rank bytes)
+ (inst li (lognot lowtag-mask) header)
+ (inst and bytes header bytes)
+ (inst addi (fixnumize (1- array-dimensions-offset)) rank header)
+ (inst sll header n-widetag-bits header)
+ (inst or header type header)
+ (inst srl header n-fixnum-tag-bits header)
(pseudo-atomic ()
- (inst move alloc-tn header)
- (inst dep other-pointer-lowtag 31 3 header)
- (inst addi (+ (* (1+ array-dimensions-offset) n-word-bytes) lowtag-mask)
- 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)))
+ (set-lowtag other-pointer-lowtag alloc-tn result)
+ (storew header result 0 other-pointer-lowtag)
+ (inst add bytes alloc-tn alloc-tn))))
\f
;;;; Additional accessors and setters for the array header.
(:translate sb!kernel:%array-rank)
(:policy :fast-safe)
(:args (x :scs (descriptor-reg)))
- (:results (res :scs (unsigned-reg)))
- (:result-types positive-fixnum)
+ (:results (res :scs (any-reg descriptor-reg)))
(:generator 6
(loadw res x 0 other-pointer-lowtag)
- (inst srl res n-widetag-bits res)
- (inst addi (- (1- array-dimensions-offset)) res res)))
+ (inst sra res n-widetag-bits res)
+ (inst addi (- (1- array-dimensions-offset)) res res)
+ (inst sll res n-fixnum-tag-bits res)))
\f
;;;; Bounds checking routine.
(define-vop (check-bound)
(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
+ vector-data-offset other-pointer-lowtag
+ ,(remove-if (lambda (x) (member x '(null zero))) 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)
+ (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
,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-full-data-vector-frobs simple-vector *
+ descriptor-reg any-reg null zero)
- (def-partial-data-vector-frobs simple-base-string character :byte nil character-reg)
+ (def-partial-data-vector-frobs simple-base-string character
+ :byte nil character-reg)
#!+sb-unicode
(def-full-data-vector-frobs simple-character-string character character-reg)
(def-partial-data-vector-frobs simple-array-signed-byte-16 tagged-num
:short t signed-reg)
- (def-full-data-vector-frobs simple-array-unsigned-byte-29 positive-fixnum any-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))
+ (def-full-data-vector-frobs simple-array-unsigned-byte-29 positive-fixnum
+ any-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,
+;;; Integer vectors whose 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)
+ (:note "inline array access")
(: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)))
+ (:results (result :scs (any-reg)))
(:result-types positive-fixnum)
- (:temporary (:scs (non-descriptor-reg)) temp)
(:temporary (:scs (interior-reg)) lip)
+ (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp)
(: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)))
+ (loadw result lip vector-data-offset other-pointer-lowtag)
+ (inst extru result :variable ,bits result)
+ (inst sll result n-fixnum-tag-bits result)))
(define-vop (,(symbolicate 'data-vector-ref-c/ type))
(:translate data-vector-ref)
(:policy :fast-safe)
(:info index)
(:results (result :scs (unsigned-reg)))
(:result-types positive-fixnum)
- (:temporary (:scs (non-descriptor-reg)) temp)
+ (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp)
(:generator 15
(multiple-value-bind (word extra) (floor index ,elements-per-word)
(let ((offset (- (* (+ word vector-data-offset) n-word-bytes)
(cond ((typep offset '(signed-byte 14))
(inst ldw offset object result))
(t
- (inst ldil (ldb (byte 21 11) offset) temp)
+ (inst ldil 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))
(: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 (non-descriptor-reg) :to (:result 0)) temp)
+ (:temporary (:scs (non-descriptor-reg)) 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)
+ (loadw old lip vector-data-offset other-pointer-lowtag)
(inst dep (sc-case value (immediate (tn-value value)) (t value))
:variable ,bits old)
(storew old lip vector-data-offset 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 li offset lip)
+ (inst add object lip lip)
+ (inst ldw 0 lip old)))
(inst dep (sc-case value
(immediate (tn-value value))
(t value))
(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)
+(macrolet
+ ((data-vector ((type set cost) &body body)
+ (let* ((typen (case type (single 'single-float)
+ (double 'double-float)
+ (t type)))
+ (name (symbolicate "DATA-VECTOR-" (if set "SET" "REF")
+ "/SIMPLE-ARRAY-" typen))
+ (reg-type (symbolicate type "-REG")))
+ `(define-vop (,name)
+ (:translate ,(symbolicate "DATA-VECTOR-" (if set "SET" "REF")))
+ (:note ,(concatenate 'string "inline array "
+ (if set "store" "access")))
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg) :to (:argument 1))
+ (index :scs (any-reg) :to (:argument 0) :target offset)
+ ,@(if set `((value :scs (,reg-type) :target result))))
+ (:arg-types ,(symbolicate "SIMPLE-ARRAY-" typen) positive-fixnum
+ ,@(if set `(,typen)))
+ (:results (,(if set 'result 'value) :scs (,reg-type)))
+ (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) offset)
+ (:result-types ,typen)
+ (:generator ,cost
+ ,@body)))))
+ (data-vector (single nil 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 fldx offset object value))
+ (data-vector (single t 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 funop :copy value result)))
+ (data-vector (double nil 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 fldx offset object value))
+ (data-vector (double t 7)
(inst sll index 1 offset)
(inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
offset offset)
(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
+(macrolet
+ ((data-vector ((type set cost) &body body)
+ (let* ((typen (case type (complex-single 'complex-single-float)
+ (complex-double 'complex-double-float)
+ (t type)))
+ (name (symbolicate "DATA-VECTOR-" (if set "SET" "REF")
+ "/SIMPLE-ARRAY-" typen))
+ (reg-type (symbolicate type "-REG")))
+ `(define-vop (,name)
+ (:translate ,(symbolicate "DATA-VECTOR-" (if set "SET" "REF")))
+ (:note ,(concatenate 'string "inline array "
+ (if set "store" "access")))
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg) :to :result)
+ (index :scs (any-reg))
+ ,@(if set `((value :scs (,reg-type) :target result))))
+ (:arg-types ,(symbolicate "SIMPLE-ARRAY-" typen) positive-fixnum
+ ,@(if set `(,typen)))
+ (:results (,(if set 'result 'value) :scs (,reg-type)))
+ (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
+ (:result-types ,typen)
+ (:generator ,cost
+ ,@body)))))
+ (data-vector (complex-single nil 5)
(inst sll index 1 offset)
(inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
offset offset)
(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 fldx offset object imag-tn)))
+ (data-vector (complex-single t 5)
(inst sll index 1 offset)
(inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
offset offset)
(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 funop :copy value-imag result-imag))))
+ (data-vector (complex-double nil 7)
(inst sll index 2 offset)
(inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
offset offset)
(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 fldx offset object imag-tn)))
+ (data-vector (complex-double t 20)
(inst sll index 2 offset)
(inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
offset offset)
(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 sb!c::raw-vector positive-fixnum))
-(define-vop (raw-set-single data-vector-set/simple-array-single-float)
- (:translate %raw-set-single)
- (:arg-types sb!c::raw-vector positive-fixnum single-float))
-(define-vop (raw-ref-double data-vector-ref/simple-array-double-float)
- (:translate %raw-ref-double)
- (:arg-types sb!c::raw-vector positive-fixnum))
-(define-vop (raw-set-double data-vector-set/simple-array-double-float)
- (:translate %raw-set-double)
- (:arg-types sb!c::raw-vector 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 sb!c::raw-vector positive-fixnum))
-(define-vop (raw-set-complex-single
- data-vector-set/simple-array-complex-single-float)
- (:translate %raw-set-complex-single)
- (:arg-types sb!c::raw-vector 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 sb!c::raw-vector positive-fixnum))
-(define-vop (raw-set-complex-double
- data-vector-set/simple-array-complex-double-float)
- (:translate %raw-set-complex-double)
- (:arg-types sb!c::raw-vector 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
(in-package "SB!VM")
-(defun my-make-wired-tn (prim-type-name sc-name offset)
+; beware that we deal alot here with register-offsets directly
+; instead of their symbol-name in vm.lisp
+; offset works differently depending on sc-type
+(defun my-make-wired-tn (prim-type-name sc-name offset state)
(make-wired-tn (primitive-type-or-lose prim-type-name)
(sc-number-or-lose sc-name)
- offset))
+ ; try to utilize vm.lisp definitions of registers:
+ (ecase sc-name
+ ((any-reg sap-reg signed-reg unsigned-reg)
+ (ecase offset ; FIX: port to other arch ???
+ ;(:nfp-offset offset)
+ (0 nl0-offset) ; On other arch we can
+ (1 nl1-offset) ; just add an offset to
+ (2 nl2-offset) ; beginning of args, but on
+ (3 nl3-offset) ; hppa c-args are spread.
+ (4 nl4-offset) ; These two are for
+ (5 nl5-offset))) ; c-return values
+ ((single-int-carg-reg double-int-carg-reg)
+ (ecase offset ; FIX: port to other arch ???
+ (0 nl0-offset)
+ (1 nl1-offset)
+ (2 nl2-offset)
+ (3 nl3-offset)))
+ ((single-reg double-reg) ; only for return
+ (+ 4 offset))
+ ; A tn of stack type tells us that we have data on
+ ; stack. This offset is current argument number so
+ ; -1 points to the correct place to write that data
+ ((sap-stack signed-stack unsigned-stack)
+ (- (arg-state-nargs state) offset 8 1)))))
(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)
+ (stack-frame-size 0)
+ (float-args 0)
+ nargs)
(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))))
+ (let ((stack-frame-size (arg-state-stack-frame-size state)))
+ (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
+ (multiple-value-bind
+ (ptype reg-sc stack-sc)
+ (if (alien-integer-type-signed type)
+ (values 'signed-byte-32 'signed-reg 'signed-stack)
+ (values 'unsigned-byte-32 'unsigned-reg 'unsigned-stack))
+ (if (< stack-frame-size 4)
+ (my-make-wired-tn ptype reg-sc stack-frame-size state)
+ (my-make-wired-tn ptype stack-sc stack-frame-size state)))))
(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)))
+ (let ((stack-frame-size (arg-state-stack-frame-size state)))
+ (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
+ (if (< stack-frame-size 4)
+ (my-make-wired-tn 'system-area-pointer
+ 'sap-reg
+ stack-frame-size state)
+ (my-make-wired-tn 'system-area-pointer
+ 'sap-stack
+ stack-frame-size state))))
-(define-alien-type-method (single-float :arg-tn) (type state)
+(define-alien-type-method (double-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)))
+ (let ((stack-frame-size (logandc2 (1+ (arg-state-stack-frame-size state)) 1))
+ (float-args (arg-state-float-args state)))
+ (setf (arg-state-stack-frame-size state) (+ stack-frame-size 2))
+ (setf (arg-state-float-args state) (1+ float-args))
+ (cond ((>= stack-frame-size 4)
+ (my-make-wired-tn 'double-float
+ 'double-stack
+ stack-frame-size state))
+ (t
+ (my-make-wired-tn 'double-float
+ 'double-int-carg-reg
+ (1+ (* float-args 2)) state)))))
-(define-alien-type-method (double-float :arg-tn) (type state)
+(define-alien-type-method (single-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)))
+ (let ((stack-frame-size (arg-state-stack-frame-size state))
+ (float-args (arg-state-float-args state)))
+ (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
+ (setf (arg-state-float-args state) (1+ float-args))
+ (cond ((>= stack-frame-size 4)
+ (my-make-wired-tn 'single-float
+ 'single-stack
+ stack-frame-size state))
+ (t
+ (my-make-wired-tn 'double-float
+ 'single-int-carg-reg
+ (* float-args 2) state)))))
+
+(defstruct result-state
+ (num-results 0))
-(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 (integer :result-tn) (type state)
+ (let ((num-results (result-state-num-results state)))
+ (setf (result-state-num-results state) (1+ num-results))
+ (multiple-value-bind (ptype reg-sc)
+ (if (alien-integer-type-signed type)
+ (values 'signed-byte-32 'signed-reg)
+ (values 'unsigned-byte-32 'unsigned-reg))
+ (if (> num-results 1) (error "Too many result values from c-call."))
+ (my-make-wired-tn ptype reg-sc (+ num-results 4) state))))
-(define-alien-type-method (system-area-pointer :result-tn) (type)
+(define-alien-type-method (system-area-pointer :result-tn) (type state)
(declare (ignore type))
- (my-make-wired-tn 'system-area-pointer 'sap-reg nl4-offset))
+ (let ((num-results (result-state-num-results state)))
+ (setf (result-state-num-results state) (1+ num-results))
+ (if (> num-results 1) (error "Too many result values from c-call."))
+ (my-make-wired-tn 'system-area-pointer 'sap-reg (+ num-results 4) state)))
-(define-alien-type-method (single-float :result-tn) (type)
+(define-alien-type-method (double-float :result-tn) (type state)
(declare (ignore type))
- (my-make-wired-tn 'single-float 'single-reg 4))
+ (let ((num-results (result-state-num-results state)))
+ (setf (result-state-num-results state) (1+ num-results))
+ (my-make-wired-tn 'double-float 'double-reg (* num-results 2) state)))
-(define-alien-type-method (double-float :result-tn) (type)
+(define-alien-type-method (single-float :result-tn) (type state)
(declare (ignore type))
- (my-make-wired-tn 'double-float 'double-reg 4))
+ (let ((num-results (result-state-num-results state)))
+ (setf (result-state-num-results state) (1+ num-results))
+ (my-make-wired-tn 'single-float 'single-reg (* num-results 2) state)))
-(define-alien-type-method (values :result-tn) (type)
+(define-alien-type-method (values :result-tn) (type state)
(let ((values (alien-values-type-values type)))
- (when values
- (aver (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))))
+ (when (> (length values) 2)
+ (error "Too many result values from c-call."))
+ (mapcar (lambda (type)
+ (invoke-alien-type-method :result-tn type state))
+ values)))
(!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)))))
+ (let ((arg-state (make-arg-state))
+ (nargs 0))
+ (dolist (arg-type (alien-fun-type-arg-types type))
+ (cond
+ ((alien-double-float-type-p arg-type)
+ (incf nargs (logior (1+ nargs) 1)))
+ (t (incf nargs))))
+ (setf (arg-state-nargs arg-state) (logandc2 (+ nargs 8 15) 15))
+ (collect ((arg-tns))
+ (dolist (arg-type (alien-fun-type-arg-types type))
+ (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
+ (values (make-normal-tn *fixnum-primitive-type*)
+ (* n-word-bytes (logandc2 (+ nargs 8 15) 15))
+ (arg-tns)
+ (invoke-alien-type-method :result-tn
+ (alien-fun-type-result-type type)
+ (make-result-state))))))
+
+(deftransform %alien-funcall ((function type &rest args))
+ (aver (sb!c::constant-lvar-p type))
+ (let* ((type (sb!c::lvar-value type))
+ (env (sb!kernel:make-null-lexenv))
+ (arg-types (alien-fun-type-arg-types type))
+ (result-type (alien-fun-type-result-type type)))
+ (aver (= (length arg-types) (length args)))
+ ;; We need to do something special for 64-bit integer arguments
+ ;; and results.
+ (if (or (some (lambda (type)
+ (and (alien-integer-type-p type)
+ (> (sb!alien::alien-integer-type-bits type) 32)))
+ arg-types)
+ (and (alien-integer-type-p result-type)
+ (> (sb!alien::alien-integer-type-bits result-type) 32)))
+ (collect ((new-args) (lambda-vars) (new-arg-types))
+ (dolist (type arg-types)
+ (let ((arg (gensym)))
+ (lambda-vars arg)
+ (cond ((and (alien-integer-type-p type)
+ (> (sb!alien::alien-integer-type-bits type) 32))
+ ;; 64-bit long long types are stored in
+ ;; consecutive locations, endian word order,
+ ;; aligned to 8 bytes.
+ (when (oddp (length (new-args)))
+ (new-args nil))
+ (progn (new-args `(ash ,arg -32))
+ (new-args `(logand ,arg #xffffffff))
+ (if (oddp (length (new-arg-types)))
+ (new-arg-types (parse-alien-type '(unsigned 32) env)))
+ (if (alien-integer-type-signed type)
+ (new-arg-types (parse-alien-type '(signed 32) env))
+ (new-arg-types (parse-alien-type '(unsigned 32) env)))
+ (new-arg-types (parse-alien-type '(unsigned 32) env))))
+ (t
+ (new-args arg)
+ (new-arg-types type)))))
+ (cond ((and (alien-integer-type-p result-type)
+ (> (sb!alien::alien-integer-type-bits result-type) 32))
+ (let ((new-result-type
+ (let ((sb!alien::*values-type-okay* t))
+ (parse-alien-type
+ (if (alien-integer-type-signed result-type)
+ '(values (signed 32) (unsigned 32))
+ '(values (unsigned 32) (unsigned 32)))
+ env))))
+ `(lambda (function type ,@(lambda-vars))
+ (declare (ignore type))
+ (multiple-value-bind
+ (high low)
+ (%alien-funcall function
+ ',(make-alien-fun-type
+ :arg-types (new-arg-types)
+ :result-type new-result-type)
+ ,@(new-args))
+ (logior low (ash high 32))))))
+ (t
+ `(lambda (function type ,@(lambda-vars))
+ (declare (ignore type))
+ (%alien-funcall function
+ ',(make-alien-fun-type
+ :arg-types (new-arg-types)
+ :result-type result-type)
+ ,@(new-args))))))
+ (sb!c::give-up-ir1-transform))))
(define-vop (foreign-symbol-sap)
(:translate foreign-symbol-sap)
(:generator 2
(inst li (make-fixup foreign-symbol :foreign) res)))
+#!+linkage-table
+(define-vop (foreign-symbol-dataref-sap)
+ (:translate foreign-symbol-dataref-sap)
+ (:policy :fast-safe)
+ (:args)
+ (:arg-types (:constant simple-string))
+ (:info foreign-symbol)
+ (:results (res :scs (sap-reg)))
+ (:result-types system-area-pointer)
+ (:temporary (:scs (non-descriptor-reg)) addr)
+ (:generator 2
+ (inst li (make-fixup foreign-symbol :foreign-dataref) addr)
+ (loadw res addr)))
+
(define-vop (call-out)
(:args (function :scs (sap-reg) :target cfunc)
(args :more t))
(: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)
+ ; Not sure if using nargs is safe ( have we saved it ).
+ ; but we cant use any non-descriptor-reg because c-args nl-4 is of that type
+ (:temporary (:sc non-descriptor-reg :offset nargs-offset) temp)
(: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)
+ (inst ble fixup c-text-space temp)
+ (move function cfunc t))
(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)))
(:result-types system-area-pointer)
+ (:results (result :scs (sap-reg any-reg)))
(:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
(:generator 0
+ ; Because stack grows to higher addresses, we have the result
+ ; pointing to an lowerer address than nsp
(move nsp-tn result)
(unless (zerop amount)
- (let ((delta (logandc2 (+ amount 63) 63)))
+ ; hp-ux stack grows towards larger addresses and stack must be
+ ; allocated in blocks of 64 bytes
+ (let ((delta (+ 0 (logandc2 (+ amount 63) 63)))) ; was + 16
(cond ((< delta (ash 1 10))
(inst addi delta nsp-tn nsp-tn))
(t
(inst li delta temp)
- (inst add temp nsp-tn nsp-tn)))))))
+ (inst add nsp-tn temp nsp-tn)))))))
(define-vop (dealloc-number-stack-space)
(:info amount)
(: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))
+ (let ((delta (+ 0 (logandc2 (+ amount 63) 63)))) ; was + 16
+ (cond ((< delta (ash 1 10))
+ (inst addi (- delta) nsp-tn nsp-tn))
(t
- (inst li delta temp)
- (inst add temp nsp-tn nsp-tn)))))))
+ (inst li (- delta) temp)
+ (inst sub nsp-tn temp nsp-tn)))))))
+
+#-sb-xc-host
+(defun alien-callback-accessor-form (type sap offset)
+ (let ((parsed-type type))
+ (if (alien-integer-type-p parsed-type)
+ (let ((bits (sb!alien::alien-integer-type-bits parsed-type)))
+ (let ((byte-offset
+ (cond ((< bits n-word-bits)
+ (- n-word-bytes
+ (ceiling bits n-byte-bits)))
+ (t 0))))
+ `(deref (sap-alien (sap+ ,sap
+ ,(+ byte-offset offset))
+ (* ,type)))))
+ `(deref (sap-alien (sap+ ,sap ,offset) (* ,type))))))
+
-;;;; the VM definition of function call for the HPPA
+;;;; the VM definition of function call for HPPA
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
(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)))
+ (let ((ptype *backend-t-primitive-type*))
+ (specify-save-tn
+ (physenv-debug-live-tn (make-normal-tn ptype) env)
+ (make-wired-tn ptype control-stack-arg-scn lra-save-offset))))
;;; Make a TN for the standard argument count passing location. We only
;;; need to make the standard location, since a count is never passed when we
(values))
\f
-;;;; Frame hackery:
-
+;;; bytes-needed-for-non-descriptor-stack-frame is the amount
+;;; we grow or shrink the NSP/NFP stack. This stack is used
+;;; by C-code so the convention (grow direction, grow size)
+;;; is governed by the hpux+hppa ABI or linux+hppa ABI.
;;; Return the number of bytes needed for the current non-descriptor stack.
-;;; We have to allocate multiples of 64 bytes.
+;;; 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))
(trace-table-entry trace-table-fun-prologue)
(emit-label start-lab)
;; Allocate function header.
- (inst fun-header-word)
+ (inst simple-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-lip lip-tn entry-point temp code-tn))
+ (inst compute-code-from-lip lip-tn entry-point temp code-tn)
+ ;; ### We should also save it on the stack so that the garbage
+ ;; collector won't forget about us if we call anyone else.
+ )
;; Build our stack frames.
(inst addi (* n-word-bytes (sb-allocated-size 'control-stack))
cfp-tn csp-tn)
(when nfp
(move nsp-tn nfp)
(inst addi (bytes-needed-for-non-descriptor-stack-frame)
- nsp-tn nsp-tn)))
+ nsp-tn nsp-tn)))
(trace-table-entry trace-table-normal)))
(define-vop (allocate-frame)
(nfp :scs (any-reg)))
(:info callee)
(:generator 2
+ (trace-table-entry trace-table-fun-prologue)
(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))))
+ nsp-tn nsp-tn))
+ (trace-table-entry trace-table-normal)))
;;; Allocate a partial frame for passing stack arguments in a full call. Nargs
;;; is the number of arguments passed. If no stack arguments are passed, then
(inst addi (* nargs n-word-bytes) csp-tn csp-tn))))
\f
+;;; Fix: boil down below notes into something nicer
;;; 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
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))
+ (type unsigned-byte nvals)
+ (type tn move-temp temp))
(cond
- ((<= nvals 1)
- (assemble ()
+ ((<= nvals 1)
;; 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.
+ (without-scheduling ()
+ (note-this-location vop :single-value-return)
+ (move ocfp-tn csp-tn t)
+ (inst nop))
+ (when lra-label
+ (inst compute-code-from-lra code-tn lra-label temp code-tn)))
+ (t
+ (let ((regs-defaulted (gen-label))
+ (defaulting-done (gen-label))
+ (default-stack-vals (gen-label)))
+ (without-scheduling ()
+ ;; 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) ; dont nullify
+ ;; If there are no stack results, clear the stack before branch.
+ (if (> nvals register-arg-count) ; what inst to late-branch-exec
+ (inst addi (fixnumize (- register-arg-count)) nargs-tn temp)
+ (move ocfp-tn csp-tn t)))
+ ;; Do the single value case.
(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)))
- (aver 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)))))))
+ ((= i (min nvals register-arg-count)))
+ (move null-tn (tn-ref-tn val)))
+ (when (> nvals register-arg-count)
+ (inst b default-stack-vals)
+ (move csp-tn ocfp-tn t))
+
+ (emit-label regs-defaulted)
+
+ (when (> nvals register-arg-count)
+ ;; If there are stack results, we have to default them
+ ;; and clear the stack.
+ (collect ((defaults))
+ (do ((i register-arg-count (1+ i))
+ (val (do ((i 0 (1+ i))
+ (val values (tn-ref-across val)))
+ ((= i register-arg-count) val))
+ (tn-ref-across val)))
+ ((null val))
+
+ (let ((default-lab (gen-label))
+ (tn (tn-ref-tn val)))
+ (defaults (cons default-lab tn))
+
+ (inst ldw (* i n-word-bytes) ocfp-tn move-temp)
+ (inst bc :<= nil temp zero-tn default-lab)
+ (inst addi (fixnumize -1) temp temp)
+ (store-stack-tn tn move-temp)))
+
+ (emit-label defaulting-done)
+ (move ocfp-tn csp-tn)
+
+ (let ((defaults (defaults)))
+ (aver defaults)
+ (assemble (*elsewhere*)
+ (emit-label default-stack-vals)
+ (trace-table-entry trace-table-fun-prologue)
+ (do ((remaining defaults (cdr remaining)))
+ ((null remaining))
+ (let ((def (car remaining)))
+ (emit-label (car def))
+ (when (null (cdr remaining))
+ (inst b defaulting-done))
+ (store-stack-tn (cdr def) null-tn)))
+ (trace-table-entry trace-table-normal)))))
+ (when lra-label
+ (inst compute-code-from-lra code-tn lra-label temp code-tn)))))
(values))
\f
;;; 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)
+ (let ((variable-values (gen-label))
+ (done (gen-label)))
+ (without-scheduling ()
+ (inst b variable-values :nullify t)
+ (inst nop)) ; nop because of emit-return-pc alignment
+
+ (when lra-label
+ (inst compute-code-from-lra code-tn lra-label temp code-tn))
+ (inst addi n-word-bytes csp-tn csp-tn)
+ (storew (first *register-arg-tns*) csp-tn -1)
+ (inst addi (- n-word-bytes) csp-tn start)
(inst li (fixnumize 1) count)
- DONE
+ (emit-label 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))
+ (trace-table-entry trace-table-fun-prologue)
+ (emit-label variable-values)
+ (when lra-label
+ (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)
+ (inst b done)
+ (move nargs count t)
(trace-table-entry trace-table-normal)))
(values))
(: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
(when callee-nfp
(maybe-load-stack-tn callee-nfp nfp)))
(maybe-load-stack-tn cfp-tn cfp)
+ (trace-table-entry trace-table-call-site)
(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)
+ (trace-table-entry trace-table-normal)
(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)))
+ (load-stack-tn cur-nfp nfp-save)))))
;;; 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
(:ignore args save)
(:vop-var vop)
(:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
+ (:temporary (:scs (non-descriptor-reg)) temp)
(:generator 20
- (trace-table-entry trace-table-call-site)
(let ((label (gen-label))
(cur-nfp (current-nfp-tn vop)))
(when cur-nfp
(when callee-nfp
(maybe-load-stack-tn callee-nfp nfp)))
(maybe-load-stack-tn cfp-tn cfp)
+ (trace-table-entry trace-table-call-site)
(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)
+ (trace-table-entry trace-table-normal)
(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)))
+ (load-stack-tn cur-nfp nfp-save)))))
\f
;;;; Local call with known values return:
(: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
(when callee-nfp
(maybe-load-stack-tn callee-nfp nfp)))
(maybe-load-stack-tn cfp-tn cfp)
+ (trace-table-entry trace-table-call-site)
(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)
+ (trace-table-entry trace-table-normal)
(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)))
+ (load-stack-tn cur-nfp nfp-save)))))
;;; Return from known values call. We receive the return locations as
;;; arguments to terminate their lifetimes in the returning function. We
;;; MAYBE-LOAD-STACK-TN.
;;;
(define-vop (known-return)
- (:args (old-fp :target old-fp-temp)
+ (:args (ocfp :target ocfp-temp)
(return-pc :target return-pc-temp)
(vals :more t))
- (:temporary (:sc any-reg :from (:argument 0)) old-fp-temp)
+ (:temporary (:sc any-reg :from (:argument 0)) ocfp-temp)
(:temporary (:sc descriptor-reg :from (:argument 1)) return-pc-temp)
(:temporary (:scs (interior-reg)) lip)
(:move-args :known-return)
(: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 ocfp-temp ocfp)
(maybe-load-stack-tn return-pc-temp return-pc)
(move cfp-tn csp-tn)
(let ((cur-nfp (current-nfp-tn vop)))
(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)
+ (move ocfp-temp cfp-tn t)
(trace-table-entry trace-table-normal)))
\f
;;; 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)
(aver (not (and variable (eq return :tail))))
`(define-vop (,name
'((new-fp :scs (any-reg) :to :eval)))
,(if named
- '(fdefn :target fdefn-pass)
+ '(name :target name-pass)
'(arg-fun :target lexenv))
,@(when (eq return :tail)
'((ocfp :target ocfp-pass)
- (lra :target lra-pass)))
+ (return-pc :target return-pc-pass)))
,@(unless variable '((args :more t :scs (descriptor-reg)))))
(:vop-var vop)
(:info ,@(unless (or variable (eq return :tail)) '(arg-locs))
,@(unless variable '(nargs))
- ,@(when (eq return :fixed) '(nvals)))
+ ,@(when (eq return :fixed) '(nvals))
+ step-instrumenting)
(:ignore
- ,@(unless (or variable (eq return :tail)) '(arg-locs))
- ,@(unless variable '(args)))
+ ,@(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)))
+ :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)))
+ :from (:argument ,(if (eq return :tail) 2 1))
:to :eval)
- lra-pass)
+ return-pc-pass)
,@(if named
`((:temporary (:sc descriptor-reg :offset fdefn-offset
:from (:argument ,(if (eq return :tail) 0 1))
:to :eval)
- fdefn-pass))
+ name-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)
+ (:temporary (:scs (descriptor-reg) :from (:argument 0) :to :eval)
function)))
(:temporary (:sc any-reg :offset nargs-offset :to :eval)
nargs-pass)
,@(when variable
- (mapcar #'(lambda (name offset)
- `(:temporary (:sc descriptor-reg
- :offset ,offset
- :to :eval)
- ,name))
+ (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)))
+ (:temporary (:scs (descriptor-reg) :to :eval) stepping)
+
,@(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)
+ (:temporary (:sc interior-reg :offset lip-offset) entry-point)
(:generator ,(+ (if named 5 0)
(if variable 19 1)
(if (eq return :tail) 0 10)
15
(if (eq return :unknown) 25 0))
- (trace-table-entry trace-table-call-site)
(let* ((cur-nfp (current-nfp-tn vop))
,@(unless (eq return :tail)
'((lra-label (gen-label))))
+ (step-done-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))))))))))
-
+ (remove nil
+ (list :load-nargs
+ ,@(if (eq return :tail)
+ '((unless (location= ocfp ocfp-pass)
+ :load-ocfp)
+ (unless (location= return-pc
+ return-pc-pass)
+ :load-return-pc)
+ (when cur-nfp
+ :frob-nfp))
+ '(:comp-lra
+ (when cur-nfp
+ :frob-nfp)
+ :save-fp
+ :load-fp))))))
+ (flet ((do-next-filler ()
+ (let* ((next (pop filler))
+ (what (if (consp next) (car next) next)))
+ (ecase what
+ (:load-nargs
+ ,@(if variable
+ `((inst sub csp-tn new-fp nargs-pass)
+ ,@(let ((index -1))
+ (mapcar (lambda (name)
+ `(inst ldw ,(ash (incf index)
+ word-shift)
+ new-fp
+ ,name))
+ register-arg-names)))
+ '((inst li (fixnumize nargs) nargs-pass))))
+ ,@(if (eq return :tail)
+ '((:load-ocfp
+ (sc-case ocfp
+ (any-reg
+ (move ocfp ocfp-pass t))
+ (control-stack
+ (inst ldw (ash (tn-offset ocfp)
+ word-shift)
+ cfp-tn ocfp-pass))))
+ (:load-return-pc
+ (sc-case return-pc
+ (descriptor-reg
+ (move return-pc return-pc-pass t))
+ (control-stack
+ (inst ldw (ash (tn-offset return-pc)
+ word-shift)
+ cfp-tn return-pc-pass))))
+ (:frob-nfp
+ (inst addi (- (bytes-needed-for-non-descriptor-stack-frame))
+ nsp-tn nsp-tn)))
+ `((:comp-lra
+ (inst compute-lra-from-code code-tn lra-label
+ temp return-pc-pass))
+ (:frob-nfp
+ (store-stack-tn nfp-save cur-nfp))
+ (:save-fp
+ (move cfp-tn ocfp-pass t))
+ (:load-fp
+ ,(if variable
+ '(move new-fp cfp-tn)
+ '(if (> nargs register-arg-count)
+ (move new-fp cfp-tn)
+ (move csp-tn cfp-tn)))
+ (trace-table-entry trace-table-call-site))))
+ ((nil)
+ (inst nop)))))
+ (insert-step-instrumenting (callable-tn)
+ ;; Conditionally insert a conditional trap:
+ (when step-instrumenting
+ ;; Get the symbol-value of SB!IMPL::*STEPPING*
+ (inst ldw (- (+ symbol-value-slot
+ (truncate (static-symbol-offset 'sb!impl::*stepping*)
+ n-word-bytes))
+ other-pointer-lowtag)
+ null-tn stepping)
+ ;; If it's not NIL, trap.
+ ;(inst comb := stepping null-tn step-done-label)
+ (inst comb := null-tn null-tn step-done-label :nullify t)
+ ;; CONTEXT-PC will be pointing here when the
+ ;; interrupt is handled, not after the BREAK.
+ (note-this-location vop :step-before-vop)
+ ;; Construct a trap code with the low bits from
+ ;; SINGLE-STEP-AROUND-TRAP and the high bits from
+ ;; the register number of CALLABLE-TN.
+ (inst break 0 (logior single-step-around-trap
+ (ash (reg-tn-encoding callable-tn)
+ 5)))
+ (emit-label step-done-label))))
,@(if named
- `((sc-case fdefn
- (descriptor-reg (move fdefn fdefn-pass))
+ `((sc-case name
+ (descriptor-reg (move name name-pass))
(control-stack
- (loadw fdefn-pass cfp-tn (tn-offset fdefn))
+ (inst ldw (ash (tn-offset name) word-shift)
+ cfp-tn name-pass)
(do-next-filler))
(constant
- (loadw fdefn-pass code-tn (tn-offset fdefn)
- other-pointer-lowtag)
+ (inst ldw (- (ash (tn-offset name) word-shift)
+ other-pointer-lowtag)
+ code-tn name-pass)
(do-next-filler)))
- (loadw lip fdefn-pass fdefn-raw-addr-slot
- other-pointer-lowtag)
+ ;; The step instrumenting must be done after
+ ;; FUNCTION is loaded, but before ENTRY-POINT is
+ ;; calculated.
+ (insert-step-instrumenting name-pass)
+ (inst ldw (- (ash fdefn-raw-addr-slot word-shift)
+ other-pointer-lowtag)
+ name-pass entry-point)
(do-next-filler))
`((sc-case arg-fun
- (descriptor-reg (move arg-fun lexenv))
+ (descriptor-reg
+ (move arg-fun lexenv))
(control-stack
- (loadw lexenv cfp-tn (tn-offset arg-fun))
+ (inst ldw (ash (tn-offset arg-fun) word-shift)
+ cfp-tn lexenv)
(do-next-filler))
(constant
- (loadw lexenv code-tn (tn-offset arg-fun)
- other-pointer-lowtag)
+ (inst ldw
+ (- (ash (tn-offset arg-fun) word-shift)
+ other-pointer-lowtag) code-tn lexenv)
(do-next-filler)))
- (loadw function lexenv closure-fun-slot
- fun-pointer-lowtag)
+ (inst ldw (- (ash closure-fun-slot word-shift)
+ fun-pointer-lowtag)
+ lexenv function)
(do-next-filler)
+ ;; The step instrumenting must be done before
+ ;; after FUNCTION is loaded, but before ENTRY-POINT
+ ;; is calculated.
+ (insert-step-instrumenting function)
(inst addi (- (ash simple-fun-code-offset word-shift)
fun-pointer-lowtag)
- function lip)))
+ function entry-point)))
(loop
- (cond ((null filler)
- (return))
- ((null (car filler))
- (pop filler))
- ((null (cdr filler))
- (return))
- (t
- (do-next-filler))))
+ (if (cdr filler)
+ (do-next-filler)
+ (return)))
+ (do-next-filler)
(note-this-location vop :call-site)
- (inst bv lip :nullify (null filler))
- (do-next-filler))
+ (inst bv entry-point :nullify t))
,@(ecase return
(:fixed
- '((emit-return-pc lra-label)
+ '((trace-table-entry trace-table-normal)
+ (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)
+ '((trace-table-entry trace-table-normal)
+ (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)))))
+ (:tail)))))))
(define-full-call call nil :fixed nil)
(define-full-call call-named t :fixed nil)
(define-full-call multiple-call-variable nil :unknown t))
-;;; Defined separately, since needs special code that BLT's the arguments
+;;; Defined separately, since needs special code that blits 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)
+ (ocfp-arg :scs (any-reg) :target ocfp)
(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 ocfp-offset :from (:argument 2)) ocfp)
(: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 ocfp-arg ocfp)
(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))))
+ (inst be fixup lisp-heap-space tmp))
+ ;; Pull the number stack if anything is there.
+ (let ((cur-nfp (current-nfp-tn vop)))
+ (if cur-nfp
+ ;;; NSP is restored by setting it to NSP,
+ ;;; because stack grows towards higher addresses.
+ (move cur-nfp nsp-tn)
+ (inst nop)))))
\f
;;;; Unknown values return:
;;; Return a single value using the unknown-values convention.
;;;
+;;; NSP is restored by setting it to NSP, because stack grows
+;;; towards higher addresses.
(define-vop (return-single)
- (:args (old-fp :scs (any-reg))
+ (:args (ocfp :scs (any-reg))
(return-pc :scs (descriptor-reg))
(value))
(:ignore value)
(trace-table-entry trace-table-fun-epilogue)
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (inst move cur-nfp nsp-tn)))
+ (move cur-nfp nsp-tn)))
;; Clear the control stack, and restore the frame pointer.
(move cfp-tn csp-tn)
- (move old-fp cfp-tn)
+ (move ocfp cfp-tn)
;; Out of here.
- (lisp-return return-pc :offset 1)
+ (lisp-return return-pc :offset 2)
(trace-table-entry trace-table-normal)))
;;; Do unknown-values return of a fixed number of values. The Values are
;;; current frame.)
;;;
(define-vop (return)
- (:args
- (old-fp :scs (any-reg))
- (return-pc :scs (descriptor-reg) :to (:eval 1))
- (values :more t))
+ (:args (ocfp :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 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)
+ (move cur-nfp nsp-tn)))
+ (cond
+ ((= nvals 1) ;; Clear the control stack, and restore the frame pointer
+ (move cfp-tn csp-tn)
+ (move ocfp cfp-tn)
+ ;; Out of here.
+ (lisp-return return-pc :offset 2))
+ (t
+ ;; 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 ocfp cfp-tn)
+ (inst addi (* nvals n-word-bytes) val-ptr csp-tn)
+ (aver (= (* nvals n-word-bytes) (fixnumize nvals)))
+ ;; 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
;;; 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))
+ (:args (ocfp-arg :scs (any-reg) :target ocfp)
+ (lra-arg :scs (descriptor-reg) :target lra)
+ (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 any-reg :offset nl1-offset :from (:argument 0)) ocfp)
(: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))
+ (let ((not-single (gen-label)))
+ ;; Clear the number stack.
+ (let ((cur-nfp (current-nfp-tn vop)))
+ (when cur-nfp
+ (move cur-nfp nsp-tn)))
;; 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))
+ (move ocfp-arg cfp-tn)
+ (lisp-return lra-arg :offset 2)
+ ;; Nope, not the single case.
+ (emit-label not-single)
+ (move ocfp-arg ocfp)
+ (move lra-arg lra)
+ (move vals-arg vals)
+ (move nvals-arg nvals) ; FIX-lav: cant utilize branch-delay-slot, why?
+ (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:
;; Don't bother doing anything.
))
-;;; Get the lexical environment from it's passing location.
+;;; Get the lexical environment from its passing location.
;;;
(define-vop (setup-closure-environment)
(:temporary (:sc descriptor-reg :offset lexenv-offset :target closure
;;; Copy a more arg from the argument area to the end of the current frame.
;;; Fixed is the number of non-more arguments.
-;;;
+;;; FIX-lav: old hppa code look smarter.
(define-vop (copy-more-arg)
(:temporary (:sc any-reg :offset nl0-offset) result)
(:temporary (:sc any-reg :offset nl1-offset) count)
(: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)
+ (let ((loop (gen-label))
+ (do-regs (gen-label))
+ (done (gen-label)))
+ (when (< fixed register-arg-count)
+ ;; Save a pointer to the results so we can fill in register args.
+ ;; We don't need this if there are more fixed args than reg args.
+ (move csp-tn result))
+ ;; Allocate the space on the stack.
+ (cond ((zerop fixed)
+ (inst comb := nargs-tn zero-tn done)
+ (inst add nargs-tn csp-tn csp-tn))
+ (t
+ (inst addi (fixnumize (- fixed)) nargs-tn count)
+ (inst comb :<= count zero-tn done :nullify t)
+ (inst add count csp-tn csp-tn)))
+ (when (< fixed register-arg-count)
+ ;; We must stop when we run out of stack args, not when we run out of
+ ;; more args.
+ (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))
+ (inst comb :<= count zero-tn do-regs)
+ ;; Initialize dst to be end of stack.
+ (move csp-tn dst t)
+ ;; Initialize src to be end of args.
+ (inst add nargs-tn cfp-tn src)
+
+ (emit-label loop)
+ ; decrease src, then load src into temp
+ (inst ldwm (- n-word-bytes) src temp)
+ ; increase, compare if count >= to zero, if true, jump
+ (inst addib :>= (fixnumize -1) count loop)
+ ; decrease dst, then store temp at dst
+ (inst stwm temp (- n-word-bytes) dst)
+
+ (emit-label 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 (1+ fixed))) nargs-tn count)
+ (do ((i fixed (1+ i)))
+ ((>= i register-arg-count))
+ ;; Is this the last one?
+ (inst comb := count zero-tn done)
+ ;; Store it relative to the pointer saved at the start.
+ (storew (nth i *register-arg-tns*) result (- i fixed))
+ ;; Decrement count.
+ (inst addi (- (fixnumize 1)) count count)))
+ (emit-label 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)
+ (:translate %listify-rest-args)
(:args (context-arg :target context :scs (descriptor-reg))
(count-arg :target count :scs (any-reg)))
(:arg-types * tagged-num)
(:temporary (:scs (any-reg) :from (:argument 0)) context)
(:temporary (:scs (any-reg) :from (:argument 1)) count)
- (:temporary (:scs (descriptor-reg) :from :eval) temp)
- (:temporary (:scs (non-descriptor-reg) :from :eval) dst)
+ (:temporary (:scs (descriptor-reg) :from :eval) temp dst)
(:results (result :scs (descriptor-reg)))
- (:translate %listify-rest-args)
(:policy :safe)
+ (:node-var node)
(: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 ()
+ (let* ((enter (gen-label))
+ (loop (gen-label))
+ (done (gen-label))
+ (dx-p (node-stack-allocate-p node))
+ (alloc-area-tn (if dx-p csp-tn alloc-tn)))
+ (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 t)
+
+ ;; We need to do this atomically.
+ (pseudo-atomic ()
+ (when dx-p
+ (align-csp temp))
;; Allocate a cons (2 words) for each item.
- (inst move alloc-tn result)
- (inst dep list-pointer-lowtag 31 3 result)
+ (set-lowtag list-pointer-lowtag alloc-area-tn result)
(move result dst)
(inst sll count 1 temp)
- (inst add alloc-tn temp alloc-tn)
+ (inst b enter)
+ (inst add temp alloc-area-tn alloc-area-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.
+ ;; Store the current cons in the cdr of the previous cons.
+ (emit-label loop)
(inst addi (* 2 n-word-bytes) dst dst)
- (inst addib :> (fixnumize -1) count loop :nullify t)
(storew dst dst -1 list-pointer-lowtag)
+ (emit-label enter)
+ ;; Grab one value.
+ (inst ldwm n-word-bytes context temp)
+ ;; Dec count, and if != zero, go back for more.
+ (inst addib :<> (fixnumize -1) count loop)
+ ;; Store the value in the car (in delay slot)
+ (storew temp dst 0 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))
+ (storew null-tn dst 1 list-pointer-lowtag))
+ (emit-label 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
;;; 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)
(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)
(t
(inst bci :<> nil (fixnumize count) nargs err-lab))))))
-;;; Signal an argument count error.
+;;; Signal argument errors.
;;;
(macrolet ((frob (name error translate &rest args)
`(define-vop (,name)
(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))
+
+;;; Single-stepping
+
+(define-vop (step-instrument-before-vop)
+ (:temporary (:scs (descriptor-reg)) stepping)
+ (:policy :fast-safe)
+ (:vop-var vop)
+ (:generator 3
+ ;; Get the symbol-value of SB!IMPL::*STEPPING*
+ (inst ldw (- (+ symbol-value-slot
+ (truncate (static-symbol-offset 'sb!impl::*stepping*)
+ n-word-bytes))
+ other-pointer-lowtag)
+ null-tn stepping)
+ ;; If it's not NIL, trap.
+ (inst comb := stepping null-tn DONE :nullify t)
+ ;; CONTEXT-PC will be pointing here when the interrupt is handled,
+ ;; not after the BREAK.
+ (note-this-location vop :step-before-vop)
+ ;; CALLEE-REGISTER-OFFSET isn't needed for before-traps, so we
+ ;; can just use a bare SINGLE-STEP-BEFORE-TRAP as the code.
+ (inst break 0 single-step-before-trap)
+ DONE))
+
(define-vop (set-slot)
(:args (object :scs (descriptor-reg))
- (value :scs (descriptor-reg any-reg)))
+ (value :scs (descriptor-reg any-reg null zero)))
(:info name offset lowtag)
(:ignore name)
(:results)
(:policy :fast-safe)
(:vop-var vop)
(:save-p :compute-only)
- (:temporary (:type random :scs (non-descriptor-reg)) temp)
+ (:temporary (: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
(:info target not-p)
(:policy :fast-safe)
(:temporary (:scs (descriptor-reg)) value)
- (:temporary (:type random :scs (non-descriptor-reg)) temp))
+ (:temporary (:scs (non-descriptor-reg)) temp))
(define-vop (boundp boundp-frob)
(:translate boundp)
(:policy :fast-safe)
(:translate symbol-hash)
(:args (symbol :scs (descriptor-reg)))
+ (:temporary (:scs (non-descriptor-reg)) temp)
(:results (res :scs (any-reg)))
(:result-types positive-fixnum)
(:generator 2
- ;; The symbol-hash slot of NIL holds NIL because it is also the
- ;; cdr slot, so we have to strip off the two low bits to make sure
- ;; it is a fixnum. The lowtag selection magic that is required to
- ;; ensure this is explained in the comment in objdef.lisp
- (loadw res symbol symbol-hash-slot other-pointer-lowtag)
- (inst andcm res #b11 res)))
+ (loadw temp symbol symbol-hash-slot other-pointer-lowtag)
+ (inst dep 0 31 n-fixnum-tag-bits temp)
+ ; we must go through an temporary to avoid gc
+ (move temp res)))
+
\f
;;;; Fdefinition (fdefn) objects.
(: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)))
+ (let ((normal-fn (gen-label)))
+ (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 :assembly-routine) lip)
+ (emit-label 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)
(storew temp fdefn fdefn-raw-addr-slot other-pointer-lowtag)
(move fdefn result)))
-
\f
;;;; Binding and Unbinding.
(: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)
+ (inst addi (* 2 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)))
(storew value symbol symbol-value-slot other-pointer-lowtag)
(storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
(storew zero-tn bsp-tn (- binding-value-slot binding-size))
- (inst addi (- (* binding-size n-word-bytes)) bsp-tn bsp-tn)))
+ (inst addi (- (* 2 n-word-bytes)) bsp-tn bsp-tn)))
(define-vop (unbind-to-here)
- (:args (where :scs (descriptor-reg any-reg)))
+ (:args (arg :scs (descriptor-reg any-reg) :target where))
+ (:temporary (:scs (any-reg) :from (:argument 0)) where)
(:temporary (:scs (descriptor-reg)) symbol value)
(:generator 0
- (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
- (storew zero-tn bsp-tn (- binding-value-slot binding-size))
- (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))
-
+ (let ((loop (gen-label))
+ (skip (gen-label))
+ (done (gen-label)))
+ (move arg where)
+ (inst comb := where bsp-tn done :nullify t)
+
+ (emit-label loop)
+ (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
+ (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))
+
+ (emit-label skip)
+ (storew zero-tn bsp-tn (- binding-value-slot binding-size))
+ (inst addi (* -2 n-word-bytes) bsp-tn bsp-tn)
+ (inst comb :<> where bsp-tn loop)
+ (inst nop)
+ (emit-label done))))
\f
;;;; Closure indexing.
(define-full-setter set-funcallable-instance-info *
funcallable-instance-info-offset fun-pointer-lowtag
- (descriptor-reg any-reg) * %set-funcallable-instance-info)
+ (descriptor-reg any-reg null zero) * %set-funcallable-instance-info)
(define-full-reffer funcallable-instance-info *
funcallable-instance-info-offset fun-pointer-lowtag
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)
+ instance-pointer-lowtag (descriptor-reg any-reg null zero) * %instance-set)
\f
(descriptor-reg any-reg) * code-header-ref)
(define-full-setter code-header-set * 0 other-pointer-lowtag
- (descriptor-reg any-reg) * code-header-set)
+ (descriptor-reg any-reg null zero) * code-header-set)
+
\f
;;;; raw instance slot accessors
(:policy :fast-safe)
(:args (ch :scs (character-reg) :target res))
(:arg-types character)
- (:results (res :scs (unsigned-reg)))
+ (:results (res :scs (any-reg)))
(:result-types positive-fixnum)
(:generator 1
- (move ch res)))
+ (inst sll ch 2 res)))
(define-vop (code-char)
(:translate code-char)
(:policy :fast-safe)
- (:args (code :scs (unsigned-reg) :target res))
+ (:args (code :scs (any-reg) :target res))
(:arg-types positive-fixnum)
(:results (res :scs (character-reg)))
(:result-types character)
(:generator 1
- (move code res)))
+ (inst srl code 2 res)))
\f
;;; Comparison of characters.
(define-vop (character-compare)
(define-vop (fast-char>/character character-compare)
(:translate char>)
(:variant :>>))
+
(in-package "SB!VM")
-
(define-vop (debug-cur-sp)
- (:translate current-sp)
+ (:translate sb!di::current-sp)
(:policy :fast-safe)
(:results (res :scs (sap-reg)))
(:result-types system-area-pointer)
(move csp-tn res)))
(define-vop (debug-cur-fp)
- (:translate current-fp)
+ (:translate sb!di::current-fp)
(:policy :fast-safe)
(:results (res :scs (sap-reg)))
(:result-types system-area-pointer)
(move cfp-tn res)))
(define-vop (read-control-stack)
- (:translate stack-ref)
+ (:translate sb!kernel:stack-ref)
(:policy :fast-safe)
(:args (object :scs (sap-reg))
(offset :scs (any-reg)))
(:result-types *)
(:generator 5
(inst ldwx offset object result)))
-
(define-vop (read-control-stack-c)
- (:translate stack-ref)
+ (:translate sb!kernel:stack-ref)
(:policy :fast-safe)
(:args (object :scs (sap-reg)))
(:info offset)
+ ; make room for multiply by limiting to 12 bits
(:arg-types system-area-pointer (:constant (signed-byte 12)))
(:results (result :scs (descriptor-reg)))
(:result-types *)
(inst ldw (* offset n-word-bytes) object result)))
(define-vop (write-control-stack)
- (:translate %set-stack-ref)
+ (:translate sb!kernel:%set-stack-ref)
(:policy :fast-safe)
(:args (object :scs (sap-reg) :target sap)
(offset :scs (any-reg))
(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)
(define-vop (code-from-mumble)
(:policy :fast-safe)
- (:args (thing :scs (descriptor-reg) :to :save))
+ (:args (thing :scs (descriptor-reg)))
(: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))
+ (let ((bogus (gen-label))
+ (done (gen-label)))
+ (loadw temp thing 0 lowtag)
+ (inst srl temp n-widetag-bits temp)
+ (inst comb := zero-tn temp bogus)
+ (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)
+ (emit-label done)
+ (assemble (*elsewhere*)
+ (emit-label bogus)
+ (inst b done)
+ (move null-tn code t)))))
(define-vop (code-from-lra code-from-mumble)
- (:translate lra-code-header)
+ (:translate sb!di::lra-code-header)
(:variant other-pointer-lowtag))
(define-vop (code-from-fun code-from-mumble)
- (:translate fun-code-header)
+ (:translate sb!di::fun-code-header)
(:variant fun-pointer-lowtag))
(define-vop (%make-lisp-obj)
(define-vop (get-lisp-obj-address)
(:policy :fast-safe)
- (:translate get-lisp-obj-address)
+ (:translate sb!di::get-lisp-obj-address)
(:args (thing :scs (descriptor-reg) :target result))
(:results (result :scs (unsigned-reg)))
(:result-types unsigned-num)
(define-vop (fun-word-offset)
(:policy :fast-safe)
- (:translate fun-word-offset)
+ (:translate sb!di::fun-word-offset)
(:args (fun :scs (descriptor-reg)))
(:results (res :scs (unsigned-reg)))
(:result-types positive-fixnum)
(defun ld-float (offset base r)
(cond ((< offset (ash 1 4))
(inst flds offset base r))
- (t
+ ((and (< offset (ash 1 13))
+ (> offset 0))
(inst ldo offset zero-tn lip-tn)
- (inst fldx lip-tn base r))))
+ (inst fldx lip-tn base r))
+ (t
+ (error "ld-float: bad offset: ~s~%" offset))))
(define-move-fun (load-float 1) (vop x y)
((single-stack) (single-reg)
(defun str-float (x offset base)
(cond ((< offset (ash 1 4))
+ ;(note-next-instruction vop :internal-error)
(inst fsts x offset base))
- (t
+ ((and (< offset (ash 1 13))
+ (> offset 0))
+ ; FIX-lav, ok with GC to use lip-tn for arbitrary offsets ?
(inst ldo offset zero-tn lip-tn)
- (inst fstx x lip-tn base))))
+ ;(note-next-instruction vop :internal-error)
+ (inst fstx x lip-tn base))
+ (t
+ (error "str-float: bad offset: ~s~%" offset))))
(define-move-fun (store-float 1) (vop x y)
((single-reg) (single-stack)
(:variant-vars size type data)
(:note "float to pointer coercion")
(:generator 13
- (with-fixed-allocation (y ndescr type size)
+ (with-fixed-allocation (y nil ndescr type size nil)
(inst fsts x (- (* data n-word-bytes) other-pointer-lowtag) y))))
(macrolet ((frob (name sc &rest args)
(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))))
+(macrolet
+ ((def-move-fun (dir type size from to)
+ `(define-move-fun (,(symbolicate dir "-" type) ,size) (vop x y)
+ ((,(symbolicate type "-" from)) (,(symbolicate type "-" to)))
+ (let ((nfp (current-nfp-tn vop))
+ (offset (* (tn-offset ,(if (eq dir 'load) 'x 'y)) n-word-bytes)))
+ ,@(if (eq dir 'load)
+ `((let ((real-tn (,(symbolicate type "-REG-REAL-TN") y)))
+ (ld-float offset nfp real-tn))
+ (let ((imag-tn (,(symbolicate type "-REG-IMAG-TN") y)))
+ (ld-float (+ offset n-word-bytes) nfp imag-tn)))
+ `((let ((real-tn (,(symbolicate type "-REG-REAL-TN") x)))
+ (str-float real-tn offset nfp))
+ (let ((imag-tn (,(symbolicate type "-REG-IMAG-TN") x)))
+ (str-float imag-tn
+ (+ offset (* ,(/ size 2) n-word-bytes))
+ nfp))))))))
+ (def-move-fun load complex-single 2 stack reg)
+ (def-move-fun store complex-single 2 reg stack)
+ (def-move-fun load complex-double 4 stack reg)
+ (def-move-fun store complex-double 4 reg stack))
;;; Complex float register to register moves.
(define-vop (complex-single-move)
(: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)
+ (with-fixed-allocation (y nil ndescr complex-single-float-widetag
+ complex-single-float-size nil)
(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))
+ 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)))))
+ other-pointer-lowtag) y)))))
(define-move-vop move-from-complex-single :move
(complex-single-reg) (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)
+ (with-fixed-allocation (y nil ndescr complex-double-float-widetag
+ complex-double-float-size nil)
(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))
+ 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)))))
+ other-pointer-lowtag) y)))))
(define-move-vop move-from-complex-double :move
(complex-double-reg) (descriptor-reg))
(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))
+ 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))))
+ x imag-tn))))
(define-move-vop move-to-complex-single :move
(descriptor-reg) (complex-single-reg))
(single-reg double-reg complex-single-reg complex-double-reg)
(descriptor-reg))
\f
+;;;; stuff for c-call float-in-int-register arguments
+(define-vop (move-to-single-int-reg)
+ (:note "pointer to float-in-int coercion")
+ (:args (x :scs (single-reg descriptor-reg)))
+ (:results (y :scs (single-int-carg-reg) :load-if nil))
+ (:generator 1
+ (sc-case x
+ (single-reg
+ (inst funop :copy x y))
+ (descriptor-reg
+ (inst ldw (- (* single-float-value-slot n-word-bytes)
+ other-pointer-lowtag) x y)))))
+(define-move-vop move-to-single-int-reg
+ :move (single-reg descriptor-reg) (single-int-carg-reg))
+
+(define-vop (move-single-int-reg)
+ (:args (x :target y :scs (single-int-carg-reg) :load-if nil)
+ (fp :scs (any-reg) :load-if (not (sc-is y single-int-carg-reg))))
+ (:results (y :scs (single-int-carg-reg) :load-if nil))
+ (:generator 1
+ (unless (location= x y)
+ (error "Huh? why did it do that?"))))
+(define-move-vop move-single-int-reg :move-arg
+ (single-int-carg-reg) (single-int-carg-reg))
+
+; move contents of float register x to register y
+(define-vop (move-to-double-int-reg)
+ (:note "pointer to float-in-int coercion")
+ (:args (x :scs (double-reg descriptor-reg)))
+ (:results (y :scs (double-int-carg-reg) :load-if nil))
+ (:temporary (:scs (signed-stack) :to (:result 0)) temp)
+ (:temporary (:scs (signed-reg) :to (:result 0) :target y) old1)
+ (:temporary (:scs (signed-reg) :to (:result 0) :target y) old2)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 2
+ (sc-case x
+ (double-reg
+ (let* ((nfp (current-nfp-tn vop))
+ (stack-tn (sc-case y
+ (double-stack y)
+ (double-int-carg-reg temp)))
+ (offset (* (tn-offset stack-tn) n-word-bytes)))
+ ; save 8 bytes of stack to two register,
+ ; write down float in stack and load it back
+ ; into result register. Notice the result hack,
+ ; we are writing to one extra register.
+ ; Double float argument convention uses two registers,
+ ; but we only know about one (thanks to c-call).
+ (inst ldw offset nfp old1)
+ (inst ldw (+ offset n-word-bytes) nfp old2)
+ (str-float x offset nfp) ; writes 8 bytes
+ (inst ldw offset nfp y)
+ (inst ldw (+ offset n-word-bytes) nfp
+ (make-wired-tn (primitive-type-or-lose 'unsigned-byte-32)
+ (sc-number-or-lose 'unsigned-reg)
+ (+ 1 (tn-offset y))))
+ (inst stw old1 offset nfp)
+ (inst stw old2 (+ offset n-word-bytes) nfp)))
+ (descriptor-reg
+ (inst ldw (- (* double-float-value-slot n-word-bytes)
+ other-pointer-lowtag) x y)
+ (inst ldw (- (* (1+ double-float-value-slot) n-word-bytes)
+ other-pointer-lowtag) x
+ (make-wired-tn (primitive-type-or-lose 'unsigned-byte-32)
+ (sc-number-or-lose 'unsigned-reg)
+ (+ 1 (tn-offset y))))))))
+(define-move-vop move-to-double-int-reg
+ :move (double-reg descriptor-reg) (double-int-carg-reg))
+
+(define-vop (move-double-int-reg)
+ (:args (x :target y :scs (double-int-carg-reg) :load-if nil)
+ (fp :scs (any-reg) :load-if (not (sc-is y double-int-carg-reg))))
+ (:results (y :scs (double-int-carg-reg) :load-if nil))
+ (:generator 2
+ (unless (location= x y)
+ (error "Huh? why did it do that?"))))
+(define-move-vop move-double-int-reg :move-arg
+ (double-int-carg-reg) (double-int-carg-reg))
+
;;;; Arithmetic VOPs.
(define-vop (float-op)
(: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))))
+ (note-this-location vop :internal-error)
+ (inst fbinop operation x y r)))
(macrolet ((frob (name sc zero-sc ptype)
`(define-vop (,name float-op)
(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)))
(: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))))))
+ (note-this-location vop :internal-error)
+ ,inst))))
(frob abs/single-float abs single-reg single-float
(inst funop :abs x y))
(frob abs/double-float abs double-reg double-float
(:vop-var vop)
(:save-p :compute-only)
(:generator 3
+ (note-this-location vop :internal-error)
;; 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)))
(define-vop (,dname double-float-compare)
(:translate ,translate)
(:variant ,condition ,complement)))))
+ ;FIX-lav: let 'inst cmp' translate keywords into raw binary instead of giving it here
(frob < #b01001 #b10101 </single-float </double-float)
(frob > #b10001 #b01101 >/single-float >/double-float)
(frob = #b00101 #b11001 eql/single-float eql/double-float))
(: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))))))
+ (note-this-location vop :internal-error)
+ (inst fcnvff x y)))))
(frob %single-float/double-float %single-float
double-reg double-float
single-reg single-float)
single-reg single-float
double-reg double-float))
+; convert register-integer to registersingle/double by
+; putting it on single-float-stack and then float-loading it into
+; an float register, and finally convert the float-register and
+; storing the result into y
(macrolet ((frob (name translate to-sc to-type)
`(define-vop (,name)
(:args (x :scs (signed-reg)
(: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)
(offset (* (tn-offset stack-tn) n-word-bytes)))
(cond ((< offset (ash 1 4))
(inst flds offset nfp fp-temp))
- (t
+ ((and (< offset (ash 1 13))
+ (> offset 0))
(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)))))))
+ (inst fldx index nfp fp-temp))
+ (t
+ (error "in vop ~s offset ~s is out-of-range" ',name offset)))
+ (note-this-location vop :internal-error)
+ (inst fcnvxf fp-temp y))))))
(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)
(cond ((< offset (ash 1 4))
(note-next-instruction vop :internal-error)
(inst fsts fp-temp offset nfp))
- (t
+ ((and (< offset (ash 1 13))
+ (> offset 0))
(inst ldo offset zero-tn index)
(note-next-instruction vop :internal-error)
- (inst fstx fp-temp index nfp)))
+ (inst fstx fp-temp index nfp))
+ (t
+ (error "unary error, ldo offset too high")))
(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-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))
(inst stw bits offset nfp)
(cond ((< offset (ash 1 4))
(inst flds offset nfp res))
- (t
+ ((and (< offset (ash 1 13))
+ (> offset 0))
(inst ldo offset zero-tn index)
- (inst fldx index nfp res)))))
+ (inst fldx index nfp res))
+ (t
+ (error "make-single-float error, ldo offset too large")))))
(single-stack
(inst stw bits (* (tn-offset res) n-word-bytes) nfp))))
(signed-stack
(let ((offset (* (tn-offset bits) n-word-bytes)))
(cond ((< offset (ash 1 4))
(inst flds offset nfp res))
- (t
+ ((and (< offset (ash 1 13))
+ (> offset 0))
(inst ldo offset zero-tn index)
- (inst fldx index nfp res)))))))))))
+ (inst fldx index nfp res))
+ (t
+ (error "make-single-float error, ldo offset too large")))))))))))
(define-vop (make-double-float)
(:args (hi-bits :scs (signed-reg))
(cond ((eq stack-tn res))
((< offset (ash 1 4))
(inst flds offset nfp res))
- (t
+ ((and (< offset (ash 1 13))
+ (> offset 0))
(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)))))))))
-
+ (inst fldx index nfp res))
+ (t
+ (error "make-single-float error, ldo offset too large"))))))
+
+(macrolet
+ ((float-bits (name reg rreg stack rstack atype anum side offset)
+ `(define-vop (,name)
+ (:args (float :scs (,reg)
+ :load-if (not (sc-is float ,stack))))
+ (:results (bits :scs (,rreg)
+ :load-if (or (not (sc-is bits ,rstack))
+ (sc-is float ,stack))))
+ (:arg-types ,atype)
+ (:result-types ,anum)
+ (:translate ,name)
+ (: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
+ (,reg
+ (sc-case bits
+ (,rreg
+ (let ((offset (* (tn-offset temp) n-word-bytes)))
+ (cond ((< offset (ash 1 4))
+ ,@(if side
+ `((inst fsts float offset nfp :side ,side))
+ `((inst fsts float offset nfp))))
+ ((and (< offset (ash 1 13))
+ (> offset 0))
+ (inst ldo offset zero-tn index)
+ ,@(if side
+ `((inst fstx float index nfp :side ,side))
+ `((inst fstx float index nfp))))
+ (t
+ (error ,(format nil "~s,~s: inst-LDO offset too large"
+ name rreg))))
+ (inst ldw offset nfp bits)))
+ (,rstack
+ (let ((offset (* (tn-offset bits) n-word-bytes)))
+ (cond ((< offset (ash 1 4))
+ ,@(if side
+ `((inst fsts float offset nfp :side ,side))
+ `((inst fsts float offset nfp))))
+ ((and (< offset (ash 1 13))
+ (> offset 0))
+ (inst ldo offset zero-tn index)
+ ,@(if side
+ `((inst fstx float index nfp :side ,side))
+ `((inst fstx float index nfp))))
+ (t
+ (error ,(format nil "~s,~s: inst-LDO offset too large"
+ name rstack))))))))
+ (,stack
+ (sc-case bits
+ (,rreg
+ (inst ldw (* (+ (tn-offset float) ,offset) n-word-bytes)
+ nfp bits))))))))))
+ (float-bits single-float-bits single-reg signed-reg single-stack
+ signed-stack single-float signed-num nil 0)
+ (float-bits double-float-high-bits double-reg signed-reg
+ double-stack signed-stack double-float signed-num 0 0)
+ (float-bits double-float-low-bits double-reg unsigned-reg
+ double-stack unsigned-stack double-float unsigned-num 1 1))
-\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)
+ 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)
+ (: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)))))
+ (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))
+ ((and (< offset (ash 1 13))
+ (> offset 0))
+ (inst ldo offset zero-tn index)
+ (inst fstx fp-single-zero-tn index nfp))
+ (t
+ (error "floating-point-modes error, ldo offset too large")))
+ (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)
+ (: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))))
-
+ (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))
+ ((and (< offset (ash 1 13))
+ (> offset 0))
+ (inst ldo offset zero-tn index)
+ (inst fldx index nfp fp-single-zero-tn))
+ (t
+ (error "set-floating-point-modes error, ldo offset too large")))
+ (inst ldw offset nfp res))))
\f
;;;; Complex float VOPs
(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))))
(in-package "SB!VM")
+; normally assem-scheduler-p is t, and nil if debugging the assembler
(eval-when (:compile-toplevel :load-toplevel :execute)
- (setf sb!assem:*assem-scheduler-p* nil))
+ (setf *assem-scheduler-p* nil))
+(setf *assem-max-locations* 68) ; see number-location
+
\f
;;;; Utility functions.
\f
;;;; Initial disassembler setup.
-
-(setf sb!disassem:*disassem-inst-alignment-bytes* 4)
+;FIX-lav: is this still used, if so , why use package prefix
+;(setf sb!disassem:*disassem-inst-alignment-bytes* 4)
(defvar *disassem-use-lisp-reg-names* t)
+; In each define-instruction the form (:dependencies ...)
+; contains read and write howto that passed as LOC here.
+; Example: (:dependencies (reads src) (writes dst) (writes temp))
+; src, dst and temp is passed each in loc, and can be a register
+; immediate or anything else.
+; this routine will return an location-number
+; this number must be less than *assem-max-locations*
+(!def-vm-support-routine location-number (loc)
+ (etypecase loc
+ (null)
+ (number)
+ (label)
+ (fixup)
+ (tn
+ (ecase (sb-name (sc-sb (tn-sc loc)))
+ (immediate-constant
+ ;; Can happen if $ZERO or $NULL are passed in.
+ nil)
+ (registers
+ (unless (zerop (tn-offset loc))
+ (tn-offset loc)))))
+ (symbol
+ (ecase loc
+ (:memory 0)))))
+
(defparameter reg-symbols
(map 'vector
- #'(lambda (name)
- (cond ((null name) nil)
- (t (make-symbol (concatenate 'string "$" name)))))
+ (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))))
+ :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
'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))))
+ :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)))))
+ :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))))
(incf offset (byte-size e)))
result))
-(defmacro define-imx-decode (name bits)
+(macrolet ((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)
+ :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)
+ :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))))))
+ :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))))
+ :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))))
+ :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 \,<> \,>=
\?>= \!< \!?= \<> \!= \!=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)))
+ :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,|))
(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))))
+ (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))
(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))))
+ (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))
(nt "Halt trap"))
(#.fun-end-breakpoint-trap
(nt "Function end breakpoint trap"))
- )))
+ (#.single-step-around-trap
+ (nt "Single step around trap")))))
(sb!disassem:define-instruction-format
(system-inst 32)
(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)
- (aver (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
+(defun encode-imm21 (segment value)
+ (declare (type (or fixup (signed-byte 32) (unsigned-byte 32)) value))
+ (cond ((fixup-p value)
+ (note-fixup segment :hi value)
+ (aver (or (null (fixup-offset value)) (zerop (fixup-offset value))))
0)
(t
- (dpb (ldb (byte 13 0) disp)
- (byte 13 1)
- (ldb (byte 1 13) disp)))))
+ (let ((hi (ldb (byte 21 11) value)))
+ (logior (ash (ldb (byte 5 2) hi) 16)
+ (ash (ldb (byte 2 7) hi) 14)
+ (ash (ldb (byte 2 0) hi) 12)
+ (ash (ldb (byte 11 9) hi) 1)
+ (ldb (byte 1 20) hi))))))
+
+(defun encode-imm11 (value)
+ (declare (type (signed-byte 11) value))
+ (dpb (ldb (byte 10 0) value)
+ (byte 10 1)
+ (ldb (byte 1 10) value)))
-(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
+(defun encode-imm11u (value)
+ (declare (type (or (signed-byte 32) (unsigned-byte 32)) value))
+ (declare (type (unsigned-byte 11) value))
+ (dpb (ldb (byte 11 0) value)
+ (byte 11 1)
+ 0))
+
+(defun encode-imm14 (value)
+ (declare (type (signed-byte 14) value))
+ (dpb (ldb (byte 13 0) value)
+ (byte 13 1)
+ (ldb (byte 1 13) value)))
+
+(defun encode-disp/fixup (segment disp imm-bits)
+ (cond
+ ((fixup-p disp)
+ (aver (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
+ (if imm-bits
+ (note-fixup segment :load11u disp)
+ (note-fixup segment :load disp))
+ 0)
+ (t
+ (if imm-bits
+ (encode-imm11u disp)
+ (encode-imm14 disp)))))
+
+; LDO can be used in two ways: to load an 14bit-signed value
+; or load an 11bit-unsigned value. The latter is used for
+; example in an LDIL/LDO pair. The key :unsigned specifies this.
+(macrolet ((define-load-inst (name opcode &optional imm-bits)
+ `(define-instruction ,name (segment disp base reg &key unsigned)
+ (:declare (type tn reg base)
+ (type (member t nil) unsigned)
+ (type (or fixup (signed-byte 14)) disp))
+ (:delay 0)
+ (:printer load/store ((op ,opcode) (s 0))
+ '(:name :tab im14 "(" s b ")," t/r))
+ (:dependencies (reads base) (reads :memory) (writes reg))
+ (: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))
+ (reg-tn-encoding base) (reg-tn-encoding reg) 0
+ (if unsigned
+ (encode-disp/fixup segment disp t)
+ (encode-disp/fixup segment disp nil))))))
+ (define-store-inst (name opcode &optional imm-bits)
+ `(define-instruction ,name (segment reg disp base)
+ (:declare (type tn reg base)
+ (type (or fixup (signed-byte 14)) disp))
+ (:delay 0)
+ (:printer load/store ((op ,opcode) (s 0))
'(:name :tab t/r "," im14 "(" s b ")"))
- (:emitter
+ (:dependencies (reads base) (reads reg) (writes :memory))
+ (: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))
+ (reg-tn-encoding base) (reg-tn-encoding reg) 0
+ (encode-disp/fixup segment disp ,imm-bits))))))
+ (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)
`(define-instruction ,name (segment index base reg &key modify scale)
(:declare (type tn reg base index)
(type (member t nil) modify scale))
+ (:delay 0)
+ (:dependencies (reads index) (reads base) (writes reg) (reads :memory))
(:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'reg)
(op2 0))
`(:name ,@cmplt-index-print :tab x/im5/r
(:declare (type tn base reg)
(type (or fixup (signed-byte 5)) disp)
(type (member :before :after nil) modify))
+ (:delay 0)
+ (:dependencies (reads base) (writes reg) (reads :memory))
(:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'im5)
(op2 4))
`(:name ,@cmplt-disp-print :tab x/im5/r
(:declare (type tn reg base)
(type (or fixup (signed-byte 5)) disp)
(type (member :before :after nil) modify))
+ (:delay 0)
+ (:dependencies (reads base) (reads reg) (writes :memory))
(:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'im5)
(op2 4))
`(:name ,@cmplt-disp-print :tab x/im5/r
(type (signed-byte 5) disp)
(type (member :begin :end) where)
(type (member t nil) modify))
+ (:delay 0)
+ (:dependencies (reads base) (reads reg) (writes :memory))
(: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
(short-disp-encoding segment disp))))
\f
-;;;; Immediate Instructions.
+;;;; Immediate 21-bit Instructions.
+;;; Note the heavy scrambling of the immediate value to instruction memory
-(define-bitfield-emitter emit-ldil 32
+(define-bitfield-emitter emit-imm21 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)
- (aver (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))
+ (type (or (signed-byte 32) (unsigned-byte 32) fixup) value))
+ (:delay 0)
+ (:dependencies (writes reg))
(:printer ldil ((op #x08)))
(:emitter
- (emit-ldil segment #x08 (reg-tn-encoding reg)
- (immed-21-encoding segment value))))
+ (emit-imm21 segment #x08 (reg-tn-encoding reg)
+ (encode-imm21 segment value))))
+; this one overwrites number stack ?
(define-instruction addil (segment value reg)
(:declare (type tn reg)
- (type (or (signed-byte 21) (unsigned-byte 21) fixup) value))
+ (type (or (signed-byte 32) (unsigned-byte 32) fixup) value))
+ (:delay 0)
+ (:dependencies (writes reg))
(:printer ldil ((op #x0A)))
(:emitter
- (emit-ldil segment #x0A (reg-tn-encoding reg)
- (immed-21-encoding segment value))))
+ (emit-imm21 segment #x0A (reg-tn-encoding reg)
+ (encode-imm21 segment value))))
\f
;;;; Branch instructions.
(type label target)
(type (member t nil) nullify))
(emit-back-patch segment 4
- #'(lambda (segment posn)
- (let ((disp (label-relative-displacement target posn)))
- (aver (<= (- (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))))))
+ (lambda (segment posn)
+ (let ((disp (label-relative-displacement target posn)))
+ (aver (<= (- (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))
+ (:delay 0)
(: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))
+ (:delay 0)
+ (:dependencies (writes reg))
(: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))
+ (:delay 0)
+ (:dependencies (writes reg))
(:emitter
(emit-relative-branch segment #x3A (reg-tn-encoding reg) 1 target nullify)))
(:declare (type tn base)
(type (member t nil) nullify)
(type (or tn null) offset))
+ (:delay 0)
+ (:dependencies (reads base))
(:printer branch ((op1 #x3A) (op2 6)) '(:name n :tab x "(" t ")"))
(:emitter
(emit-branch segment #x3A (reg-tn-encoding base)
(type tn base)
(type (unsigned-byte 3) space)
(type (member t nil) nullify))
+ (:delay 0)
+ (:dependencies (reads base))
(:printer branch17 ((op1 #x38) (op2 nil :type 'im3))
'(:name n :tab w "(" op2 "," t ")"))
(:emitter
(type tn base)
(type (unsigned-byte 3) space)
(type (member t nil) nullify))
+ (:delay 0)
+ (:dependencies (reads base))
(:printer branch17 ((op1 #x39) (op2 nil :type 'im3))
'(:name n :tab w "(" op2 "," t ")"))
+ (:dependencies (writes lip-tn))
(:emitter
(multiple-value-bind
(w1 w2 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)))
- (aver (<= (- (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))))))
+ (lambda (segment posn)
+ (let ((disp (label-relative-displacement target posn)))
+ (when (not (<= (- (ash 1 11)) disp (1- (ash 1 11))))
+ (format t "AVER fail: disp = ~s~%" disp)
+ (format t "target = ~s~%" target)
+ (format t "posn = ~s~%" posn)
+ )
+ (aver (<= (- (ash 1 11)) disp (1- (ash 1 11))))
+ (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)
(byte 4 1)
(ldb (byte 1 4) value)))
-(macrolet ((define-branch-inst (r-name r-opcode i-name i-opcode cond-kind)
+(macrolet ((define-branch-inst (r-name r-opcode i-name i-opcode cond-kind
+ writes-reg)
(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))
+ (type tn r1 r2)
+ (type label target)
+ (type (member t nil) nullify))
+ (:delay 0)
+ ,@(ecase writes-reg
+ (:write-reg
+ '((:dependencies (reads r1) (reads r2) (writes r2))))
+ (:pinned
+ '(:pinned))
+ (nil
+ '((:dependencies (reads r1) (reads r2)))))
+; ,@(if writes-reg
+; '((:dependencies (reads r1) (reads r2) (writes r2)))
+; '((:dependencies (reads r1) (reads r2))))
(: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))))
+ `((: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)
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))
+ (type (signed-byte 5) imm)
+ (type tn reg)
+ (type (member t nil) nullify))
+ (:delay 0)
+; ,@(if writes-reg
+; '((:dependencies (reads reg) (writes reg)))
+; '((:dependencies (reads reg))))
+ ,@(ecase writes-reg
+ (:write-reg
+ '((:dependencies (reads r1) (reads r2) (writes r2))))
+ (:pinned
+ '(:pinned))
+ (nil
+ '((:dependencies (reads r1) (reads r2)))))
(:printer branch12 ((op1 ,i-opcode) (r1 nil :type 'im5)
(c nil :type ',conditional))
'(:name c n :tab r1 "," r2 "," w))
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-branch-inst movb #x32 movib #x33 extract/deposit :write-reg)
+ (define-branch-inst comb #x20 comib #x21 compare :pinned)
+ (define-branch-inst addb #x28 addib #x29 add :write-reg))
(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))
+ (:delay 0)
+ (:dependencies (reads reg))
(:printer branch12 ((op1 30) (c nil :type 'extract/deposit-condition))
'('BVB c n :tab r1 "," w))
(:emitter
(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)
+(macrolet ((define-r3-inst (name cond-kind opcode &optional pinned)
`(define-instruction ,name (segment r1 r2 res &optional cond)
(:declare (type tn res r1 r2))
+ (:delay 0)
+ ,@(if pinned
+ '(:pinned)
+ '((:dependencies (reads r1) (reads r2) (writes res))))
(:printer r3-inst ((op ,opcode) (c nil :type ',(symbolicate
cond-kind
"-CONDITION"))))
+ ;FIX-lav, change opcode test to name test
,@(when (= opcode #x12)
`((:printer r3-inst ((op ,opcode) (r2 0)
(c nil :type ',(symbolicate cond-kind
(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 or logical #x12 t) ; as a nop it must be pinned
(define-r3-inst xor logical #x14)
(define-r3-inst and logical #x10)
(define-r3-inst andcm logical #x00)
(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)
+(macrolet ((define-imm-inst (name cond-kind opcode subcode &optional pinned)
+ `(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)
+ (:delay 0)
+ (:printer imm-inst ((op ,opcode) (o ,subcode)
+ (c nil :type
+ ',(symbolicate cond-kind "-CONDITION"))))
+ (:dependencies (reads imm) (reads src) (writes dst))
+ (: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)))))))
+ (encode-imm11 imm)))))))
(define-imm-inst addi add #x2D 0)
(define-imm-inst addio add #x2D 1)
(define-imm-inst addit add #x2C 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))
+ (:delay 0)
+ :pinned
(: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))
(:declare (type tn res src)
(type (or (member :variable) (integer 0 31)) posn)
(type (integer 1 32) len))
+ (:delay 0)
+ (:dependencies (reads src) (writes res))
(:printer extract/deposit-inst ((op1 #x34) (cp nil :type 'integer)
(op2 ,opcode))
'(:name c :tab r2 "," cp "," t/clen "," r1))
(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
+ `(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))
+ (:delay 0)
+ (:dependencies (reads src) (writes res))
+ (: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 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))))))))
+ (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))
(define-instruction break (segment &optional (im5 0) (im13 0))
(:declare (type (unsigned-byte 13) im13)
(type (unsigned-byte 5) im5))
+ (:cost 0)
+ (:delay 0)
+ :pinned
(:printer break () :default :control #'break-control)
(:emitter
(emit-break segment 0 im13 0 im5)))
(define-instruction ldsid (segment res base &optional (space 0))
(:declare (type tn res base)
(type (integer 0 3) space))
+ (:delay 0)
+ :pinned
(: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))
(define-instruction mtsp (segment reg space)
(:declare (type tn reg) (type (integer 0 7) space))
+ (:delay 0)
+ :pinned
(:printer system-inst ((op2 #xC1)) '(:name :tab r2 "," s))
(:emitter
(emit-system-inst segment 0 0 (reg-tn-encoding reg) (space-encoding space)
(define-instruction mfsp (segment space reg)
(:declare (type tn reg) (type (integer 0 7) space))
+ (:delay 0)
+ :pinned
(: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
(define-instruction mtctl (segment reg ctrl-reg)
(:declare (type tn reg) (type control-reg ctrl-reg))
+ (:delay 0)
+ :pinned
(:printer system-inst ((op2 #xC2)) '(:name :tab r2 "," r1))
(:emitter
(emit-system-inst segment 0 (control-reg ctrl-reg) (reg-tn-encoding reg)
(define-instruction mfctl (segment ctrl-reg reg)
(:declare (type tn reg) (type control-reg ctrl-reg))
+ (:delay 0)
+ :pinned
(:printer system-inst ((op2 #x45)) '(:name :tab r1 "," r3))
(:emitter
(emit-system-inst segment 0 (control-reg ctrl-reg) 0 0 #x45
(:declare (type tn index base result)
(type (member t nil) modify scale)
(type (member nil 0 1) side))
+ (:delay 0)
+ :pinned
(:printer fp-load/store ((op #x0b) (x1 0) (x2 0) (x3 0))
- `('FLDDX ,@cmplt-index-print :tab x "(" s b ")" "," t))
+ `('FLDD ,@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))
+ `('FLDW ,@cmplt-index-print :tab x "(" s b ")" "," t))
(:emitter
(multiple-value-bind
(result-encoding double-p)
(:declare (type tn index base value)
(type (member t nil) modify scale)
(type (member nil 0 1) side))
+ (:delay 0)
+ :pinned
(:printer fp-load/store ((op #x0b) (x1 0) (x2 0) (x3 1))
- `('FSTDX ,@cmplt-index-print :tab t "," x "(" s b ")"))
+ `('FSTD ,@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 ")"))
+ `('FSTW ,@cmplt-index-print :tab t "," x "(" s b ")"))
(:emitter
(multiple-value-bind
(value-encoding double-p)
(type (signed-byte 5) disp)
(type (member :before :after nil) modify)
(type (member nil 0 1) side))
+ (:delay 0)
+ :pinned
(: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))
+ `('FLDD ,@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))
+ `('FLDW ,@cmplt-disp-print :tab x "(" s b ")," t))
(:emitter
(multiple-value-bind
(result-encoding double-p)
(type (signed-byte 5) disp)
(type (member :before :after nil) modify)
(type (member nil 0 1) side))
+ (:delay 0)
+ :pinned
(: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 ")"))
+ `('FSTD ,@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 ")"))
+ `('FSTW ,@cmplt-disp-print :tab t "," x "(" s b ")"))
(:emitter
(multiple-value-bind
(value-encoding double-p)
(define-instruction funop (segment op from to)
(:declare (type funop op)
(type tn from to))
+ (:delay 0)
+ :pinned
(: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))
(macrolet ((define-class-1-fp-inst (name subcode)
`(define-instruction ,name (segment from to)
(:declare (type tn from to))
+ (:delay 0)
(:printer fp-class-1-inst ((op1 #x0C) (x2 ,subcode))
'(:name sf df :tab r "," t))
(:emitter
(define-instruction fcmp (segment cond r1 r2)
(:declare (type (unsigned-byte 5) cond)
(type tn r1 r2))
+ (:delay 0)
+ :pinned
(:printer fp-class-0-inst ((op1 #x0C) (op2 0) (x2 2) (t nil :type 'fcmp-cond))
'(:name fmt t :tab r "," x1))
(:emitter
(if r1-double-p 1 0) 2 0 0 cond)))))
(define-instruction ftest (segment)
+ (:delay 0)
+ :pinned
(: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)))
(define-instruction fbinop (segment op r1 r2 result)
(:declare (type fbinop op)
(type tn r1 r2 result))
+ (:delay 0)
+ :pinned
(: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))
(define-instruction li (segment value reg)
(:declare (type tn reg)
(type (or fixup (signed-byte 32) (unsigned-byte 32)) value))
+ (:delay 0)
+ (:dependencies (reads reg))
(:vop-var vop)
(:emitter
(assemble (segment vop)
(etypecase value
(fixup
(inst ldil value reg)
- (inst ldo value reg reg))
+ (inst ldo value reg reg :unsigned t))
((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))))))))
+ (let ((lo (ldb (byte 11 0) value)))
+ (inst ldil value reg)
+ (inst ldo lo reg reg :unsigned t)))))))
(define-instruction-macro sll (src count result &optional cond)
(once-only ((result result) (src src) (count count) (cond cond))
(type (member t nil) not-p)
(type tn r1 r2)
(type label target))
+ (:delay 0)
+ (:dependencies (reads r1) (reads r2))
(: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)))
+ (lambda (segment posn delta)
+ (let ((disp (label-relative-displacement target posn delta)))
+ (when (<= 0 disp (1- (ash 1 11)))
(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)))))))))
+ (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)) ;FIX-lav, cant nullify when backward branch
+ (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 (signed-byte 11) imm)
(type tn reg)
(type label target))
+ (:delay 0)
+ (:dependencies (reads reg))
(: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)))
+ (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)
- (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)))))))))
+ (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 = lip - header - label-offset + other-pointer-tag
-(define-instruction compute-code-from-lip (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
-;; = lra - (header + label-offset)
-(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
-;; = code + header + label-offset
-(define-instruction compute-lra-from-code (segment src label temp dst)
- (:declare (type tn src dst temp)
- (type label label))
- (:vop-var vop)
+(defun emit-header-data (segment type)
+ (emit-back-patch
+ segment 4
+ (lambda (segment posn)
+ (emit-word segment
+ (logior type
+ (ash (+ posn (component-header-length))
+ (- n-widetag-bits word-shift)))))))
+
+(define-instruction simple-fun-header-word (segment)
+ :pinned
+ (:cost 0)
+ (:delay 0)
(: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))))))
+ (emit-header-data segment simple-fun-header-widetag)))
-\f
-;;;; Data instructions.
-
-(define-instruction byte (segment byte)
+(define-instruction lra-header-word (segment)
+ :pinned
+ (:cost 0)
+ (:delay 0)
(:emitter
- (emit-byte segment byte)))
+ (emit-header-data segment return-pc-header-widetag)))
-(define-bitfield-emitter emit-halfword 16
- (byte 16 0))
-
-(define-instruction halfword (segment halfword)
- (:emitter
- (emit-halfword segment halfword)))
+(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
+ ; This is the best-case that emits one instruction ( 4 bytes )
+ (lambda (segment posn delta-if-after)
+ (let ((delta (funcall calc label posn delta-if-after)))
+ ; WHEN, Why not AVER ?
+ (when (<= (- (ash 1 10)) delta (1- (ash 1 10)))
+ (emit-back-patch segment 4
+ (lambda (segment posn)
+ (assemble (segment vop)
+ (inst addi (funcall calc label posn 0) src
+ dst))))
+ t)))
+ ; This is the worst-case that emits three instruction ( 12 bytes )
+ (lambda (segment posn)
+ (let ((delta (funcall calc label posn 0)))
+ ; FIX-lav: why do we hit below check ?
+ ;(when (<= (- (ash 1 10)) delta (1- (ash 1 10)))
+ ; (error "emit-compute-inst selected worst-case, but is shrinkable, delta is ~s" delta))
+ ;; Note: if we used addil/ldo to do this in 2 instructions then the
+ ;; intermediate value would be tagged but pointing into space.
+ ;; Does above note mean that the intermediate value would be
+ ;; a bogus pointer that would be GCed wrongly ?
+ ;; Also what I can see addil would also overwrite NFP (r1) ???
+ (assemble (segment vop)
+ ; Three instructions (4 * 3) this is the reason for 12 bytes
+ (inst ldil delta temp)
+ (inst ldo (ldb (byte 11 0) delta) temp temp :unsigned t)
+ (inst add src temp dst))))))
+
+(macrolet ((compute ((name) &body body)
+ `(define-instruction ,name (segment src label temp dst)
+ (:declare (type tn src dst temp) (type label label))
+ (:attributes variable-length)
+ (:dependencies (reads src) (writes dst) (writes temp))
+ (:delay 0)
+ (:vop-var vop)
+ (:emitter
+ (emit-compute-inst segment vop src label temp dst
+ ,@body)))))
+ (compute (compute-code-from-lip)
+ (lambda (label posn delta-if-after)
+ (- other-pointer-lowtag
+ (label-position label posn delta-if-after)
+ (component-header-length))))
+ (compute (compute-code-from-lra)
+ (lambda (label posn delta-if-after)
+ (- (+ (label-position label posn delta-if-after)
+ (component-header-length)))))
+ (compute (compute-lra-from-code)
+ (lambda (label posn delta-if-after)
+ (+ (label-position label posn delta-if-after)
+ (component-header-length)))))
+\f
+;;;; Data instructions.
(define-bitfield-emitter emit-word 32
(byte 32 0))
-(define-instruction word (segment word)
- (:emitter
- (emit-word segment word)))
+(macrolet ((data (size type)
+ `(define-instruction ,size (segment ,size)
+ (:declare (type ,type ,size))
+ (:cost 0)
+ (:delay 0)
+ :pinned
+ (:emitter
+ (,(symbolicate "EMIT-" size) segment ,size)))))
+ (data byte (or (unsigned-byte 8) (signed-byte 8)))
+ (data short (or (unsigned-byte 16) (signed-byte 16)))
+ (data word (or (unsigned-byte 23) (signed-byte 23))))
-(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))))))))
(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 expand (expr)
+ (let ((gensym (gensym)))
+ `(macrolet
+ ((,gensym ()
+ ,expr))
+ (,gensym))))
+
+;;; Instruction-like macros.
+;;; FIX-lav: add if always-emit-code-p is :e= then error if location=
+(defmacro move (src dst &optional always-emit-code-p)
+ #!+sb-doc
+ "Move SRC into DST (unless they are location= and ALWAYS-EMIT-CODE-P is nil)."
+ (once-only ((n-src src)
+ (n-dst dst))
+ `(if (location= ,n-dst ,n-src)
+ (when ,always-emit-code-p
+ (inst nop))
+ (inst move ,n-src ,n-dst))))
(defmacro loadw (result base &optional (offset 0) (lowtag 0))
(once-only ((result result) (base base))
(+ (static-symbol-offset ',symbol)
(ash symbol-value-slot word-shift)
(- other-pointer-lowtag))
- null-tn
- ,reg))
+ null-tn ,reg))
(defmacro store-symbol-value (reg symbol)
`(inst stw ,reg (+ (static-symbol-offset ',symbol)
null-tn))
(defmacro load-type (target source &optional (offset 0))
+ #!+sb-doc
"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 (1- n-word-bytes)) ,source ,target))))
+byte-ordering issues."
+ (once-only ((n-target target)
+ (n-source source)
+ (n-offset offset))
+ (ecase *backend-byte-order*
+ (:little-endian
+ `(inst ldb ,n-offset ,n-source ,n-target))
+ (:big-endian
+ `(inst ldb (+ ,n-offset (1- n-word-bytes)) ,n-source ,n-target)))))
(defmacro set-lowtag (tag src dst)
`(progn
;;; return instructions.
(defmacro lisp-jump (function)
- "Jump to the lisp function FUNCTION. LIP is an interior-reg temporary."
+ #!+sb-doc
+ "Jump to the lisp function FUNCTION."
`(progn
- (inst addi
- (- (ash simple-fun-code-offset word-shift) fun-pointer-lowtag)
- ,function
- lip-tn)
+ (inst addi (- (ash simple-fun-code-offset word-shift)
+ fun-pointer-lowtag) ,function lip-tn)
(inst bv lip-tn)
- (move ,function code-tn)))
+ (move ,function code-tn t)))
(defmacro lisp-return (return-pc &key (offset 0) (frob-code t))
+ #!+sb-doc
"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)))))
+ ,@(if frob-code
+ `((move ,return-pc code-tn t)))))
(defmacro emit-return-pc (label)
+ #!+sb-doc
"Emit a return-pc header word. LABEL is the label to use for this
return-pc."
`(progn
+ ; alignment causes the return point to land on two address,
+ ; where the first must be nop pad.
(emit-alignment n-lowtag-bits)
(emit-label ,label)
(inst lra-header-word)))
(sc-case stack
((control-stack)
(loadw reg cfp-tn offset))))))
+
(defmacro store-stack-tn (stack reg)
`(let ((stack ,stack)
(reg ,reg))
(storew reg cfp-tn offset))))))
(defmacro maybe-load-stack-tn (reg reg-or-stack)
+ #!+sb-doc
"Move the TN Reg-Or-Stack into Reg if it isn't already there."
(once-only ((n-reg reg)
(n-stack reg-or-stack))
\f
;;;; Error Code
-(eval-when (compile load eval)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
(defun emit-error-break (vop kind code values)
(let ((vector (gensym)))
`((let ((vop ,vop))
(emit-alignment word-shift)))))
(defmacro error-call (vop error-code &rest values)
+ #!+sb-doc
"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)
+ #!+sb-doc
"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)))
+ (without-scheduling ()
+ (inst b ,label)
+ ,@(emit-error-break vop cerror-trap error-code values))))
(defmacro generate-error-code (vop error-code &rest values)
+ #!+sb-doc
"Generate-Error-Code Error-code Value*
Emit code for an error with the specified Error-Code and context Values."
`(assemble (*elsewhere*)
start-lab)))
(defmacro generate-cerror-code (vop error-code &rest values)
+ #!+sb-doc
"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
,@(when translate
`((:translate ,translate)))
(:policy :fast-safe)
- (:args (object :scs (descriptor-reg) :to (:eval 0))
- (index :scs (any-reg) :target temp))
+ (:args (object :scs (descriptor-reg))
+ (index :scs (any-reg)))
(:arg-types ,type tagged-num)
- (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp)
+ (:temporary (:scs (interior-reg)) lip)
(:results (value :scs ,scs))
(:result-types ,el-type)
(:generator 5
- (inst addi (- (* ,offset n-word-bytes) ,lowtag) index temp)
- (inst ldwx temp object value)))
+ (inst add object index lip)
+ (loadw value lip ,offset ,lowtag)))
(define-vop (,(symbolicate name "-C"))
,@(when translate
`((:translate ,translate)))
(:results (value :scs ,scs))
(:result-types ,el-type)
(:generator 4
- (inst ldw (- (* (+ ,offset index) n-word-bytes) ,lowtag)
- object value)))))
+ (loadw value object (+ ,offset index) ,lowtag)))))
(defmacro define-full-setter (name type offset lowtag scs el-type
&optional translate)
(:result-types ,el-type)
(:generator 2
(inst add object index lip)
- (inst stw value (- (* ,offset n-word-bytes) ,lowtag) lip)
+ (storew value lip ,offset ,lowtag)
(move value result)))
(define-vop (,(symbolicate name "-C"))
,@(when translate
(:results (result :scs ,scs))
(:result-types ,el-type)
(:generator 1
- (inst stw value (- (* (+ ,offset index) n-word-bytes) ,lowtag) object)
+ (storew value object (+ ,offset index) ,lowtag)
(move value result)))))
(declare (ignore objects)) ;should we eval these for side-effect?
`(without-gcing
,@body))
+
;;;
(define-vop (cell-set)
(:args (object :scs (descriptor-reg))
- (value :scs (descriptor-reg any-reg)))
+ (value :scs (descriptor-reg any-reg null zero)))
(:variant-vars offset lowtag)
(:policy :fast-safe)
(:generator 1
;;;
(define-vop (slot-set)
(:args (object :scs (descriptor-reg))
- (value :scs (descriptor-reg any-reg)))
+ (value :scs (descriptor-reg any-reg null zero)))
(:variant-vars base lowtag)
(:info offset)
- (:generator 1
+ (:generator 4
(storew value object (+ base offset) lowtag)))
(load-symbol y val))
(character
(inst li (logior (ash (char-code val) n-widetag-bits)
- character-widetag)
- y)))))
+ character-widetag) y)))))
(define-move-fun (load-number 1) (vop x y)
- ((immediate zero)
+ ((zero immediate)
(signed-reg unsigned-reg))
- (let ((x (tn-value x)))
- (inst li (if (>= x (ash 1 31)) (logior (ash -1 32) x) x) y)))
+ (inst li (tn-value x) y))
(define-move-fun (load-character 1) (vop x y)
((immediate) (character-reg))
(inst li (sap-int (tn-value x)) y))
(define-move-fun (load-constant 5) (vop x y)
- ((constant) (descriptor-reg))
+ ((constant) (descriptor-reg any-reg))
(loadw y code-tn (tn-offset x) other-pointer-lowtag))
(define-move-fun (load-stack 5) (vop x y)
(loadw y nfp (tn-offset x))))
(define-move-fun (store-stack 5) (vop x y)
- ((any-reg descriptor-reg) (control-stack))
+ ((any-reg descriptor-reg null zero) (control-stack))
(store-stack-tn y x))
(define-move-fun (store-number-stack 5) (vop x y)
;;;; The Move VOP:
(define-vop (move)
(:args (x :target y
- :scs (any-reg descriptor-reg)
+ :scs (any-reg descriptor-reg zero null)
:load-if (not (location= x y))))
- (:results (y :scs (any-reg descriptor-reg)
+ (:results (y :scs (any-reg descriptor-reg control-stack)
:load-if (not (location= x y))))
(:effects)
(:affected)
(:generator 0
- (move x y)))
+ (unless (location= x y)
+ (sc-case y
+ ((any-reg descriptor-reg)
+ (inst move x y))
+ (control-stack
+ (store-stack-tn y x))))))
(define-move-vop move :move
- (any-reg descriptor-reg)
+ (any-reg descriptor-reg zero null)
(any-reg descriptor-reg))
;;; Make MOVE the check VOP for T so that type check generation
;;; frame for argument or known value passing.
(define-vop (move-arg)
(:args (x :target y
- :scs (any-reg descriptor-reg))
+ :scs (any-reg descriptor-reg null zero))
(fp :scs (any-reg)
:load-if (not (sc-is y any-reg descriptor-reg))))
(:results (y))
(control-stack
(storew x fp (tn-offset y))))))
(define-move-vop move-arg :move-arg
- (any-reg descriptor-reg)
+ (any-reg descriptor-reg null zero)
(any-reg descriptor-reg))
-
\f
;;;; ILLEGAL-MOVE
(: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))
(:note "constant load")
(:generator 1
(inst li (tn-value x) y)))
+
(define-move-vop move-to-word-c :move
(constant) (signed-reg unsigned-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)
+ (inst sra x 2 y)
+ (inst extru x 31 2 zero-tn :=)
(loadw y x bignum-digits-offset other-pointer-lowtag)))
+
(define-move-vop move-to-word/integer :move
(descriptor-reg) (signed-reg unsigned-reg))
(: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)
+ (:args (arg :scs (signed-reg unsigned-reg) :target x))
+ (:results (y :scs (any-reg descriptor-reg)))
+ (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x temp)
(: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))
+ (move arg x)
+ (let ((done (gen-label)))
+ ;; 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 nil temp bignum-widetag (1+ bignum-digits-offset) nil)
+ (storew x y bignum-digits-offset other-pointer-lowtag))
+ (emit-label done))))
+
(define-move-vop move-from-signed :move
(signed-reg) (descriptor-reg))
;;; 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")
+ (:args (arg :scs (signed-reg unsigned-reg) :target x))
+ (:results (y :scs (any-reg descriptor-reg)))
+ (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x temp)
(: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)
+ (move arg x)
+ (inst srl x 29 temp)
+ (inst comb := temp zero-tn 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 if it's 0.
+ (pseudo-atomic (:extra (pad-data-block (+ bignum-digits-offset 2)))
+ (set-lowtag other-pointer-lowtag alloc-tn y)
+ (inst xor temp temp temp)
(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))
+ (inst li 1 temp)
+ (inst sll temp n-widetag-bits temp)
+ (inst addi (logior (ash 1 n-widetag-bits) bignum-widetag) temp temp)
+ (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))
(:note "word integer move")
(:generator 0
(move x y)))
+
(define-move-vop word-move :move
(signed-reg unsigned-reg) (signed-reg unsigned-reg))
(move x y))
((signed-stack unsigned-stack)
(storew x fp (tn-offset y))))))
+
(define-move-vop move-word-arg :move-arg
(descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg))
;;; 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
+;;; 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
(:args (tn)
(tag :scs (any-reg descriptor-reg)))
(:info entry-label)
- (:results (block :scs (any-reg) :from (:argument 0)))
+ (:results (block :scs (any-reg)))
(:temporary (:scs (descriptor-reg)) temp)
+ (:temporary (:scs (descriptor-reg) :target block :to (:result 0)) result)
(:temporary (:scs (non-descriptor-reg)) ndescr)
(:generator 44
- (inst addi (* (tn-offset tn) n-word-bytes) cfp-tn block)
+ (inst addi (* (tn-offset tn) n-word-bytes) cfp-tn result)
(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)
+ (storew temp result catch-block-current-uwp-slot)
+ (storew cfp-tn result catch-block-current-cont-slot)
+ (storew code-tn result 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 temp result catch-block-entry-pc-slot)
- (storew tag block catch-block-tag-slot)
+ (storew tag result 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*)))
-
+ (storew temp result catch-block-previous-catch-slot)
+ (store-symbol-value result *current-catch-block*)
+ (move result block)))
;;; Just set the current unwind-protect to TN's address. This instantiates an
;;; unwind block as an unwind-protect.
(note-this-location vop :non-local-entry)
(cond ((zerop nvals))
((= nvals 1)
+ (loadw (tn-ref-tn values) start)
(inst comclr count zero-tn zero-tn :<>)
- (inst move null-tn (tn-ref-tn values) :tr)
- (loadw (tn-ref-tn values) start))
+ (move null-tn (tn-ref-tn values) t))
(t
(collect ((defaults))
(do ((i 0 (1+ i))
(let ((default-lab (gen-label))
(tn (tn-ref-tn tn-ref)))
(defaults (cons default-lab tn))
-
- (inst bci := nil (fixnumize i) count default-lab)
+ (inst comb := zero-tn count default-lab)
+ (inst addi (fixnumize -1) count count)
(sc-case tn
((descriptor-reg any-reg)
- (loadw tn start i))
+ (loadw tn start i))
(control-stack
- (loadw move-temp start i)
- (store-stack-tn tn move-temp)))))
-
+ (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)))))))))))
+ (dolist (def (defaults))
+ (emit-label (car def))
+ (let ((tn (cdr def)))
+ (sc-case tn
+ ((descriptor-reg any-reg)
+ (move null-tn tn))
+ (control-stack
+ (store-stack-tn tn null-tn)))))
+ (inst b defaulting-done)
+ (inst nop)))))) ; FIX remove me or tell why I'm needed
(load-stack-tn csp-tn sp)))
(: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)))
-
+ (let ((loop (gen-label))
+ (done (gen-label)))
+
+ ;; 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)
+ (inst nop) ; fix-lav remove nop
+ (sc-case new-count
+ (any-reg (move num new-count))
+ (control-stack (store-stack-tn new-count num)))
+
+ ;; Copy stuff on stack.
+ (emit-label loop)
+ (inst ldwm n-word-bytes src temp)
+ (inst addib :<> (fixnumize -1) num loop)
+ (inst stwm temp n-word-bytes dst)
+
+ (emit-label done)
+ (move dst csp-tn))))
;;; This VOP is just to force the TNs used in the cleanup onto the stack.
;;;
(in-package "SB!VM")
-
\f
;;;; Machine Architecture parameters:
+(eval-when (:compile-toplevel :load-toplevel :execute)
;;; number of bits per word where a word holds one lisp descriptor
(def!constant n-word-bits 32)
(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)
+(defconstant-eqx single-float-exponent-byte (byte 8 23) #'equalp)
+(defconstant-eqx single-float-significand-byte (byte 23 0) #'equalp)
(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)
+(defconstant-eqx double-float-exponent-byte (byte 11 20) #'equalp)
+(defconstant-eqx double-float-significand-byte (byte 20 0) #'equalp)
(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 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))
+(defconstant-eqx float-rounding-mode (byte 2 7) #'equalp)
+(defconstant-eqx float-sticky-bits (byte 5 27) #'equalp)
+(defconstant-eqx float-traps-byte (byte 5 0) #'equalp)
+(defconstant-eqx float-exceptions-byte (byte 5 27) #'equalp)
+(defconstant-eqx float-condition-bit (ash 1 26) #'equalp)
(def!constant float-fast-bit 0) ; No fast mode on HPPA.
;;; Where to put the different spaces.
;;;
-(def!constant read-only-space-start #x20000000)
-(def!constant read-only-space-end #x24000000)
+(def!constant read-only-space-start #x4b000000)
+(def!constant read-only-space-end #x4dff0000)
+
+(def!constant static-space-start #x4e000000)
+(def!constant static-space-end #x4fff0000)
-(def!constant static-space-start #x28000000)
-(def!constant static-space-end #x2a000000)
+(def!constant dynamic-0-space-start #x50000000)
+(def!constant dynamic-0-space-end #x54000000)
+(def!constant dynamic-1-space-start #x60000000)
+(def!constant dynamic-1-space-end #x64000000)
-(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)
+); eval-when
-;;; FIXME: WTF are these for?
+;;; When doing external branching on hppa (e.g. inst ble)
+;;; we must know which space we want to jump into (text, code)
;; The space-register holding the lisp heap.
(def!constant lisp-heap-space 5)
-;; The space-register holding the C text segment.
+;; The space-register holding the C text heap.
(def!constant c-text-space 4)
\f
;;;; Other random constants.
+(defenum (:suffix -flag)
+ atomic
+ interrupted)
+
(defenum (:suffix -trap :start 8)
halt
pending-interrupt
cerror
breakpoint
fun-end-breakpoint
- single-step-breakpoint)
+ single-step-breakpoint
+ single-step-around
+ single-step-before
+ single-step-after)
(defenum (:prefix trace-table-)
normal
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
- ))
+ sb!kernel:two-arg-lcm))
+
(in-package "SB!VM")
+; FIX-lav, can we do this in assembly instead ?
(defun sanctify-for-execution (component)
(without-gcing
(alien-funcall (extern-alien "sanctify_for_execution"
;;; Move a tagged SAP to an untagged representation.
(define-vop (move-to-sap)
- (:args (x :scs (descriptor-reg)))
+ (:args (x :scs (any-reg 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)))
+ (:args (sap :scs (sap-reg) :to :save))
(:temporary (:scs (non-descriptor-reg)) ndescr)
- (:results (y :scs (descriptor-reg) :from (:eval 0)))
+ (:results (res :scs (descriptor-reg)))
(: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))))
+ (with-fixed-allocation (res nil ndescr sap-widetag sap-size nil)
+ (storew sap res sap-pointer-slot other-pointer-lowtag))))
+
(define-move-vop move-from-sap :move
(sap-reg) (descriptor-reg))
:load-if (not (location= x y))))
(:results (y :scs (sap-reg)
:load-if (not (location= x y))))
+ (:note "SAP move")
(:effects)
(:affected)
(:generator 0
(move x y)))
+
(define-move-vop sap-move :move
(sap-reg) (sap-reg))
(fp :scs (any-reg)
:load-if (not (sc-is y sap-reg))))
(:results (y))
+ (:note "SAP argument move")
(:generator 0
(sc-case y
(sap-reg
(move x y))
(sap-stack
(storew x fp (tn-offset y))))))
+
(define-move-vop move-sap-arg :move-arg
(descriptor-reg sap-reg) (sap-reg))
;;;; POINTER+ and POINTER-
(define-vop (pointer+)
(:translate sap+)
- (:args (ptr :scs (sap-reg) :target res)
- (offset :scs (signed-reg)))
+ (:args (ptr :scs (sap-reg))
+ (offset :scs (signed-reg immediate)))
(: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)))
+ (sc-case offset
+ (signed-reg
+ (inst add ptr offset res))
+ (immediate
+ (cond
+ ((and (< (tn-value offset) (ash 1 10))
+ (> (tn-value offset) (- (ash 1 10))))
+ (inst addi (tn-value offset) ptr res))
+ (t
+ (inst li (tn-value offset) res)
+ (inst add ptr res res)))))))
(define-vop (pointer-)
(:translate sap-)
(: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)))
+ (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
+ vector sap)))
\f
;;; Transforms for 64-bit SAP accessors.
(in-package "SB!VM")
-
(define-vop (print)
- (:args (object :scs (descriptor-reg) :target arg))
- (:results (result :scs (descriptor-reg)))
+ (:args (object :scs (descriptor-reg any-reg) :target nl0))
+ (:results)
(: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 any-reg :offset nl0-offset :from (:argument 0)) nl0)
+ (:temporary (:sc any-reg :offset cfunc-offset) cfunc)
(:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
(:temporary (:scs (non-descriptor-reg)) temp)
(:vop-var vop)
- (:generator 0
+ (:generator 100
(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)
+ (move object nl0)
(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 ble fixup c-text-space temp))
+ (inst addi 64 nsp-tn nsp-tn)
(inst addi -64 nsp-tn nsp-tn)
(when cur-nfp
- (load-stack-tn cur-nfp nfp-save))
- (move res result))))
+ (load-stack-tn cur-nfp nfp-save)))))
+
(in-package "SB!VM")
-
(define-vop (static-fun-template)
(:save-p t)
(:policy :safe)
(: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 interior-reg :offset lip-offset) lip)
(:temporary (:sc any-reg :offset nargs-offset) nargs)
- (:temporary (:sc any-reg :offset ocfp-offset) old-fp)
+ (:temporary (:sc any-reg :offset ocfp-offset) ocfp)
(:temporary (:sc control-stack :offset nfp-save-offset) nfp-save))
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
+;why do we have this ?
+(eval-when (#-sb-xc :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))
(let ((arg-name (intern (format nil "ARG-~D" i))))
(arg-names arg-name)
(args `(,arg-name
- :scs (any-reg descriptor-reg)
+ :scs (any-reg descriptor-reg null zero)
:target ,(nth i (temp-names))))))
`(define-vop (,(static-fun-template-name num-args num-results)
static-fun-template)
(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)
+ (move cfp-tn ocfp)
(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)
+ (move csp-tn cfp-tn t)
(emit-return-pc lra-label)
,(collect ((bindings) (links))
(do ((temp (temp-names) (cdr temp))
) ; EVAL-WHEN
-(macrolet
- ((foo ()
- (collect ((templates (list 'progn)))
- (dotimes (i register-arg-count)
- (templates (static-fun-template-vop i 1)))
- (templates))))
- (foo))
+
+(expand
+ (collect ((templates (list 'progn)))
+ (dotimes (i register-arg-count)
+ (templates (static-fun-template-vop i 1)))
+ (templates)))
+
(defmacro define-static-fun (name args &key (results '(x)) translate
- policy cost arg-types result-types)
+ policy cost arg-types result-types)
`(define-vop (,name
,(static-fun-template-name (length args)
- (length results)))
+ (length results)))
(:variant ',name)
(:note ,(format nil "static-fun ~@(~S~)" name))
,@(when translate
(inst li 0 count)
(inst extru ptr 31 3 temp)
- (inst comib :<> list-pointer-lowtag temp loose :nullify t)
+ (inst comib :<> list-pointer-lowtag temp lose :nullify t)
(loadw ptr ptr cons-cdr-slot list-pointer-lowtag)
LOOP
(inst comib := list-pointer-lowtag temp loop :nullify t)
(loadw ptr ptr cons-cdr-slot list-pointer-lowtag)
- LOOSE
+ LOSE
(cerror-call vop done object-not-list-error ptr)
DONE
(:results (result :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 1
- (inst extru object 31 3 result)))
+ (inst extru object 31 n-lowtag-bits result)))
+;FIX this vop got instruction-exploded after mips convert, look at old hppa
(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)))
+ (:args (object :scs (descriptor-reg)))
+ (:temporary (:scs (non-descriptor-reg)) temp1 temp2)
+ (:results (result :scs (unsigned-reg)))
(: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)
+ (inst li lowtag-mask temp1)
+ (inst li other-pointer-lowtag temp2)
+ (inst and temp1 object temp1)
+ (inst xor temp1 temp2 temp1)
+ (inst comb := temp1 zero-tn OTHER-PTR)
+ (inst li (logxor other-pointer-lowtag fun-pointer-lowtag) temp2)
+ (inst xor temp1 temp2 temp1)
+ (inst comb := temp1 zero-tn FUNCTION-PTR)
+ (inst li 3 temp1) ; pick off fixnums
+ (inst li 1 temp2)
+ (inst and temp1 object result)
+ (inst comb := result zero-tn DONE)
+
+ (inst and object temp2 result)
+ (inst comb :<> result zero-tn LOWTAG-ONLY :nullify t)
+
+ ; must be an other immediate
+ (inst li widetag-mask temp2)
+ (inst b DONE)
+ (inst and temp2 object result)
FUNCTION-PTR
(load-type result object (- fun-pointer-lowtag))
- (inst nop :tr)
+ (inst b done)
+ (inst nop)
+
+ LOWTAG-ONLY
+ (inst li lowtag-mask temp1)
+ (inst b done)
+ (inst and object temp1 result)
OTHER-PTR
(load-type result object (- other-pointer-lowtag))
+ (inst nop)
DONE))
+
(define-vop (fun-subtype)
(:translate fun-subtype)
(:policy :fast-safe)
(:results (result :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 6
- (load-type result function (- fun-pointer-lowtag))))
+ (load-type result function (- fun-pointer-lowtag))
+ (inst nop))) ;FIX-lav, not sure this nop is needed
(define-vop (set-fun-subtype)
(:translate (setf fun-subtype))
(:results (result :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 6
- (inst stb type (- 3 fun-pointer-lowtag) function)
+ (inst stb type (- fun-pointer-lowtag) function)
(move type result)))
(define-vop (get-header-data)
(:result-types positive-fixnum)
(:generator 6
(loadw res x 0 other-pointer-lowtag)
- (inst srl res 8 res)))
+ (inst srl res n-widetag-bits res)))
(define-vop (get-closure-length)
(:translate get-closure-length)
(:result-types positive-fixnum)
(:generator 6
(loadw res x 0 fun-pointer-lowtag)
- (inst srl res 8 res)))
-
+ (inst srl res n-widetag-bits res)))
+;FIX-lav, not sure we need data of type immediate and zero, test without, if so revert to old hppa code
(define-vop (set-header-data)
(:translate set-header-data)
(:policy :fast-safe)
(:args (x :scs (descriptor-reg) :target res)
- (data :scs (unsigned-reg)))
+ (data :scs (any-reg immediate zero)))
(:arg-types * positive-fixnum)
(:results (res :scs (descriptor-reg)))
- (:temporary (:scs (non-descriptor-reg)) temp)
+ (:temporary (:scs (non-descriptor-reg)) t1 t2)
(: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)))
+ (loadw t1 x 0 other-pointer-lowtag)
+ ; replace below 2 inst with: (mask widetag-mask t1 t1)
+ (inst li widetag-mask t2)
+ (inst and t1 t2 t1)
+ (sc-case data
+ (any-reg
+ (inst sll data (- n-widetag-bits 2) t2)
+ (inst or t1 t2 t1))
+ (immediate
+ (inst li (ash (tn-value data) n-widetag-bits) t2)
+ (inst or t1 t2 t1))
+ (zero))
-(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)
+ (storew t1 x 0 other-pointer-lowtag)
(move x res)))
(define-vop (pointer-hash)
(:results (res :scs (any-reg descriptor-reg)))
(:policy :fast-safe)
(:generator 1
- ;; FIXME: It would be better if this would mask the lowtag,
- ;; and shift the result into a positive fixnum like on x86.
(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)))
+ (type :scs (any-reg descriptor-reg immediate) :target temp))
+ (:results (res :scs (any-reg descriptor-reg)))
(:temporary (:scs (non-descriptor-reg)) temp)
+ (:temporary (:scs (non-descriptor-reg)) t2)
(:generator 2
- (inst sll val (- n-widetag-bits 2) res)
- (inst sra type 2 temp)
- (inst or res temp res)))
-
+ (sc-case type
+ ((immediate)
+ (inst sll val n-widetag-bits temp)
+ (inst li (tn-value type) t2)
+ (inst or temp t2 res))
+ (t
+ (inst sra type 2 temp)
+ (inst sll val (- n-widetag-bits 2) res)
+ (inst or res temp res)))))
\f
;;;; Allocation
(: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 srl ndescr n-widetag-bits ndescr)
+ (inst sll ndescr word-shift ndescr)
(inst addi (- other-pointer-lowtag) ndescr ndescr)
(inst add code ndescr sap)))
(: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)
+ ;FIX-lav: replace below two with DEPW
+ (inst srl ndescr n-widetag-bits ndescr)
+ (inst sll ndescr word-shift ndescr)
(inst add ndescr offset ndescr)
(inst addi (- fun-pointer-lowtag other-pointer-lowtag) ndescr ndescr)
(inst add ndescr code func)))
(inst extru value 31 8 temp)
(inst bci := not-p immediate temp target)))
-(defun %test-lowtag (value target not-p lowtag
- &key temp temp-loaded)
+(defun %test-lowtag (value target not-p lowtag &key temp temp-loaded)
(assemble ()
(unless temp-loaded
(inst extru value 31 3 temp))
;;; 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)
;;; 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)
+ (move value temp t)
;; If not, is it an other pointer?
(inst extru value 31 3 temp)
;; 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)
+ ; Dont nullify comb here, because we cant guarantee target is forward
+ (inst comb (if not-p := :<>) temp zero-tn not-target)
+ (inst nop)
+ (inst b target)
SINGLE-WORD
;; Get the single digit.
(:generator 1
(move ptr csp-tn)))
+(define-vop (%%pop-dx)
+ (:args (ptr :scs (any-reg)))
+ (:ignore ptr)
+ (:generator 1
+ (bug "VOP %%POP-DX is not implemented.")))
+
+(define-vop (%%nip-dx)
+ (:args (last-nipped-ptr :scs (any-reg) :target dest)
+ (last-preserved-ptr :scs (any-reg) :target src)
+ (moved-ptrs :scs (any-reg) :more t))
+ (:results (r-moved-ptrs :scs (any-reg) :more t))
+ (:temporary (:sc any-reg) src)
+ (:temporary (:sc any-reg) dest)
+ (:temporary (:sc non-descriptor-reg) temp)
+ (:ignore r-moved-ptrs
+ last-nipped-ptr last-preserved-ptr moved-ptrs
+ src dest temp)
+ (:generator 1
+ (bug "VOP %%NIP-DX is not implemented.")))
+
+(define-vop (%%nip-values)
+ (:args (last-nipped-ptr :scs (any-reg) :target dest)
+ (last-preserved-ptr :scs (any-reg) :target src)
+ (moved-ptrs :scs (any-reg) :more t))
+ (:results (r-moved-ptrs :scs (any-reg) :more t))
+ (:temporary (:sc any-reg) src)
+ (:temporary (:sc any-reg) dest)
+ (:temporary (:sc non-descriptor-reg) temp)
+ (:ignore r-moved-ptrs)
+ (:generator 1
+ (move last-preserved-ptr src)
+ (move last-nipped-ptr dest)
+ (inst comb :>= src csp-tn DONE :nullify t)
+ LOOP
+ (inst ldwm n-word-bytes src temp)
+ (inst addi n-word-bytes dest dest)
+ (storew temp dest -1)
+ (inst comb :> csp-tn src LOOP)
+ (inst nop)
+ DONE
+ (move dest csp-tn)
+ (inst sub src dest src)
+ (loop for moved = moved-ptrs then (tn-ref-across moved)
+ while moved do
+ (sc-case (tn-ref-tn moved)
+ ((descriptor-reg any-reg)
+ (inst sub (tn-ref-tn moved) src (tn-ref-tn moved)))
+ ((control-stack)
+ (load-stack-tn temp (tn-ref-tn moved))
+ (inst sub temp src temp)
+ (store-stack-tn (tn-ref-tn moved) temp))))))
;;; 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
(define-vop (push-values)
(:args
(vals :more t))
- (:results (start :scs (any-reg) :from :load)
+ (:results (start :scs (any-reg))
(count :scs (any-reg)))
(:info nvals)
(:temporary (:scs (descriptor-reg)) temp)
+ (:temporary (:scs (descriptor-reg)
+ :to (:result 0)
+ :target start)
+ start-temp)
(:generator 20
- (move csp-tn start)
+ (move csp-tn start-temp)
(inst addi (* nvals n-word-bytes) csp-tn csp-tn)
(do ((val vals (tn-ref-across val))
(i 0 (1+ i)))
(let ((tn (tn-ref-tn val)))
(sc-case tn
(descriptor-reg
- (storew tn start i))
+ (storew tn start-temp i))
(control-stack
(load-stack-tn temp tn)
- (storew temp start i)))))
+ (storew temp start-temp i)))))
+ (move start-temp start)
(inst li (fixnumize nvals) count)))
-
;;; Push a list of values on the stack, returning Start and Count as used in
;;; unknown values continuations.
;;;
(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)
+ (:temporary (:scs (non-descriptor-reg)) ndescr)
(:vop-var vop)
(:save-p :compute-only)
(:generator 0
(move arg list)
- (inst comb := list null-tn done)
(move csp-tn start)
-
LOOP
+ (inst comb := list null-tn done)
(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)
+ (inst nop)
(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.
;;;
(:args (context :scs (descriptor-reg any-reg) :target src)
(skip :scs (any-reg zero immediate))
(num :scs (any-reg) :target count))
+ (:arg-types * positive-fixnum positive-fixnum)
(:temporary (:sc any-reg :from (:argument 0)) src)
- (:temporary (:sc any-reg :from (:argument 1)) dst end)
+ (:temporary (:sc any-reg :from (:argument 2)) dst end)
(:temporary (:sc descriptor-reg :from (:argument 1)) temp)
(:results (start :scs (any-reg))
(count :scs (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)
+ (move csp-tn start t)
+ (move csp-tn dst)
+ (inst add count csp-tn 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)
+ (inst ldwm n-word-bytes src temp)
+ (inst comb :<> dst end loop)
+ (inst stwm temp n-word-bytes dst)
DONE))
(in-package "SB!VM")
\f
-;;;; Define the registers
+;;;; 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)
`(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 nfp 1) ;; and saved by lisp before calling C
(defreg cfunc 2)
;; These are the callee saves, so these registers are stay live over
;; call-out.
(defreg lip 31)
(defregset non-descriptor-regs
- nl0 nl1 nl2 nl3 nl4 nl5 nfp cfunc)
+ nl0 nl1 nl2 nl3 nl4 nl5 cfunc nargs nfp)
(defregset descriptor-regs
- fdefn lexenv nargs ocfp lra a0 a1 a2 a3 a4 a5 l0 l1 l2)
+ a0 a1 a2 a3 a4 a5 fdefn lexenv ocfp lra l0 l1 l2)
(defregset *register-arg-offsets*
- a0 a1 a2 a3 a4 a5))
+ a0 a1 a2 a3 a4 a5)
+
+ (defregset reserve-descriptor-regs
+ fdefn lexenv)
+ (defregset reserve-non-descriptor-regs
+ cfunc))
(define-storage-base registers :finite :size 32)
(define-storage-base float-registers :finite :size 64)
;;;
;;; Handy macro so we don't have to keep changing all the numbers whenever
;;; we insert a new storage class.
-;;;
+;;; FIX-lav: move this into arch-generic-helpers.lisp and rip out from arches
(defmacro !define-storage-classes (&rest classes)
(do ((forms (list 'progn)
(let* ((class (car classes))
(!define-storage-classes
- ;; Non-immediate contstants in the constant pool
+ ;; Non-immediate constants in the constant pool
(constant constant)
;; ZERO and NULL are in registers.
(any-reg
registers
:locations #.(append non-descriptor-regs descriptor-regs)
- :constant-scs (zero immediate)
+ :reserve-locations #.(append reserve-non-descriptor-regs
+ reserve-descriptor-regs)
+ :constant-scs (constant zero immediate)
:save-p t
:alternate-scs (control-stack))
;; Pointer descriptor objects. Must be seen by GC.
(descriptor-reg registers
:locations #.descriptor-regs
+ :reserve-locations #.reserve-descriptor-regs
:constant-scs (constant null immediate)
:save-p t
:alternate-scs (control-stack))
(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.
;; Non-Descriptor characters
(character-reg registers
:locations #.non-descriptor-regs
+ :reserve-locations #.reserve-non-descriptor-regs
:constant-scs (immediate)
:save-p t
:alternate-scs (character-stack))
;; Non-Descriptor SAP's (arbitrary pointers into address space)
(sap-reg registers
:locations #.non-descriptor-regs
+ :reserve-locations #.reserve-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
+ :reserve-locations #.reserve-non-descriptor-regs
:constant-scs (zero immediate)
:save-p t
:alternate-scs (signed-stack))
(unsigned-reg registers
:locations #.non-descriptor-regs
+ :reserve-locations #.reserve-non-descriptor-regs
:constant-scs (zero immediate)
:save-p t
:alternate-scs (unsigned-stack))
:alternate-scs (complex-double-stack))
;; A catch or unwind block.
- (catch-block control-stack :element-size kludge-nondeterministic-catch-block-size))
+ (catch-block control-stack :element-size kludge-nondeterministic-catch-block-size)
+
+
+ ;; floating point numbers temporarily stuck in integer registers for c-call
+ (single-int-carg-reg registers
+ :locations (26 25 24 23)
+ :alternate-scs ()
+ :constant-scs ())
+ (double-int-carg-reg registers
+ :locations (25 23)
+ :constant-scs ()
+ :alternate-scs ()
+; :alignment 2 ;is this needed?
+; :element-size 2
+ ))
\f
;;;; Make some random tns for important registers.
-
+; how can we address reg L0 through L0-offset when it is not
+; defined here ? do all registers have an -offset and this is
+; redundant work ?
+;FIX-lav: move this into arch-generic-helpers
(macrolet ((defregtn (name sc)
(let ((offset-sym (symbolicate name "-OFFSET"))
(tn-sym (symbolicate name "-TN")))
;; These, we access by foo-TN only
(defregtn zero any-reg)
+ (defregtn nargs any-reg)
+ ;FIX-lav: 20080820: not a fix, but fdefn and lexenv is used in assembly-rtns
+ (defregtn fdefn descriptor-reg) ; FIX-lav, not used
+ (defregtn lexenv descriptor-reg) ; FIX-lav, not used
+
+ (defregtn nfp descriptor-reg) ; why not descriptor-reg ?
+ (defregtn ocfp any-reg) ; why not descriptor-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 csp any-reg)
+ (defregtn alloc 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 code descriptor-reg)
(defregtn lip interior-reg))
;; And some floating point values.
(null
(sc-number-or-lose 'null))
((or (integer #.sb!xc:most-negative-fixnum #.sb!xc:most-positive-fixnum)
- character)
+ system-area-pointer character)
(sc-number-or-lose 'immediate))
(symbol
(if (static-symbol-p value)
;;; 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))
+(defparameter *register-arg-tns*
+ (mapcar (lambda (n)
+ (make-random-tn :kind :normal
+ :sc (sc-or-lose 'descriptor-reg)
+ :offset n))
*register-arg-offsets*))
;;; This is used by the debugger.
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.24.21"
+"1.0.24.22"
projects / sbcl.git / commitdiff