From: Nikodemus Siivola Date: Sun, 4 Jan 2009 07:49:02 +0000 (+0000) Subject: 1.0.24.22: mudball of VOP updates for HPPA X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=0d74ed478e7f3af5d3292153726373763631aa8e;p=sbcl.git 1.0.24.22: mudball of VOP updates for HPPA * Based on a mix of the old hppa-code and the mips backend. * Patch by Larry Valkama. --- diff --git a/src/assembly/hppa/arith.lisp b/src/assembly/hppa/arith.lisp index d3a2ffa..0a378e4 100644 --- a/src/assembly/hppa/arith.lisp +++ b/src/assembly/hppa/arith.lisp @@ -49,8 +49,6 @@ (inst xor res sign res) (inst add res sign res)) - -#+sb-assembling (define-assembly-routine (truncate) ((:arg dividend signed-reg nl0-offset) @@ -58,7 +56,6 @@ (: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) @@ -87,7 +84,6 @@ (inst move dividend zero-tn :>=) (inst sub zero-tn rem rem)) - ;;;; Generic arithmetic. @@ -99,26 +95,43 @@ (: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) @@ -131,24 +144,42 @@ (: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)) ;;;; Comparison routines. diff --git a/src/assembly/hppa/array.lisp b/src/assembly/hppa/array.lisp index 5afb42b..8240e87 100644 --- a/src/assembly/hppa/array.lisp +++ b/src/assembly/hppa/array.lisp @@ -1,69 +1 @@ (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)) diff --git a/src/assembly/hppa/assem-rtns.lisp b/src/assembly/hppa/assem-rtns.lisp index b90b2cb..7a90e06 100644 --- a/src/assembly/hppa/assem-rtns.lisp +++ b/src/assembly/hppa/assem-rtns.lisp @@ -1,25 +1,20 @@ (in-package "SB!VM") - ;;;; Return-multiple with other than one value #+sb-assembling ;; we don't want a vop for this one. (define-assembly-routine (return-multiple (:return-style :none)) - ;; These four are really arguments. ((:temp nvals any-reg nargs-offset) (:temp vals any-reg nl0-offset) - (:temp 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) @@ -27,55 +22,48 @@ (: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)) - ;;;; tail-call-variable. @@ -83,20 +71,16 @@ (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) @@ -104,11 +88,8 @@ (: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) @@ -117,35 +98,28 @@ (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)) - ;;;; 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) @@ -156,38 +130,36 @@ (: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*) @@ -196,11 +168,50 @@ (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 diff --git a/src/assembly/hppa/support.lisp b/src/assembly/hppa/support.lisp index 76c39b5..2a5e4e1 100644 --- a/src/assembly/hppa/support.lisp +++ b/src/assembly/hppa/support.lisp @@ -13,13 +13,12 @@ (!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 @@ -32,32 +31,26 @@ (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 diff --git a/src/compiler/hppa/alloc.lisp b/src/compiler/hppa/alloc.lisp index 30ce93c..c72e87d 100644 --- a/src/compiler/hppa/alloc.lisp +++ b/src/compiler/hppa/alloc.lisp @@ -10,10 +10,8 @@ ;;;; files for more information. (in-package "SB!VM") - ;;;; LIST and LIST* - (define-vop (list-or-list*) (:args (things :more t)) (:temporary (:scs (descriptor-reg) :type list) ptr) @@ -24,44 +22,47 @@ (: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)) @@ -128,33 +129,29 @@ (: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) @@ -163,17 +160,14 @@ (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) @@ -181,13 +175,10 @@ (: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)))) ;;;; Automatic allocators for primitive objects. @@ -201,7 +192,8 @@ (: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) @@ -226,9 +218,9 @@ (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)))) + diff --git a/src/compiler/hppa/arith.lisp b/src/compiler/hppa/arith.lisp index 8d9ae19..984b141 100644 --- a/src/compiler/hppa/arith.lisp +++ b/src/compiler/hppa/arith.lisp @@ -13,21 +13,24 @@ ;;;; 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) @@ -40,9 +43,9 @@ (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))) @@ -56,76 +59,29 @@ ;;; 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))) @@ -142,162 +98,188 @@ (: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) @@ -360,8 +342,9 @@ ;;; 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 @@ -372,17 +355,18 @@ (: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) @@ -400,13 +384,36 @@ :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)))) @@ -422,7 +429,7 @@ :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) @@ -436,6 +443,51 @@ (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))) @@ -554,7 +606,7 @@ ;;; 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") @@ -563,11 +615,13 @@ (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) @@ -575,17 +629,34 @@ (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))) + ;;;; 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) @@ -594,17 +665,17 @@ (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))) @@ -615,20 +686,10 @@ (: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)) @@ -641,7 +702,7 @@ (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) @@ -692,9 +753,7 @@ (: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) @@ -702,7 +761,7 @@ (: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))) @@ -806,25 +865,18 @@ (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) @@ -854,10 +906,14 @@ (: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) @@ -892,11 +948,21 @@ (define-static-fun two-arg-gcd (x y) :translate gcd) (define-static-fun two-arg-lcm (x y) :translate lcm) +(define-static-fun two-arg-+ (x y) :translate +) +(define-static-fun two-arg-- (x y) :translate -) (define-static-fun two-arg-* (x y) :translate *) (define-static-fun two-arg-/ (x y) :translate /) +(define-static-fun two-arg-< (x y) :translate <) +(define-static-fun two-arg-<= (x y) :translate <=) +(define-static-fun two-arg-> (x y) :translate >) +(define-static-fun two-arg->= (x y) :translate >=) +(define-static-fun two-arg-= (x y) :translate =) +(define-static-fun two-arg-/= (x y) :translate /=) + (define-static-fun %negate (x) :translate %negate) (define-static-fun two-arg-and (x y) :translate logand) (define-static-fun two-arg-ior (x y) :translate logior) (define-static-fun two-arg-xor (x y) :translate logxor) + diff --git a/src/compiler/hppa/array.lisp b/src/compiler/hppa/array.lisp index 4ae7ef9..9afaf87 100644 --- a/src/compiler/hppa/array.lisp +++ b/src/compiler/hppa/array.lisp @@ -17,24 +17,25 @@ (: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)))) ;;;; Additional accessors and setters for the array header. @@ -50,12 +51,12 @@ (: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))) ;;;; Bounds checking routine. (define-vop (check-bound) @@ -82,14 +83,16 @@ (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 @@ -98,9 +101,11 @@ ,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) @@ -125,38 +130,41 @@ (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) @@ -165,7 +173,7 @@ (: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) @@ -173,7 +181,7 @@ (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)) @@ -186,16 +194,17 @@ (: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) @@ -224,9 +233,9 @@ (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)) @@ -246,67 +255,46 @@ (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) @@ -314,19 +302,30 @@ (unless (location= result value) (inst funop :copy value result)))) - -;;; 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) @@ -334,21 +333,8 @@ (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) @@ -362,19 +348,8 @@ (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) @@ -382,21 +357,8 @@ (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) @@ -413,37 +375,6 @@ (inst funop :copy value-imag result-imag))))) -;;; These VOPs are used for implementing float slots in structures (whose raw -;;; data is an unsigned-32 vector. -(define-vop (raw-ref-single data-vector-ref/simple-array-single-float) - (:translate %raw-ref-single) - (:arg-types 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 diff --git a/src/compiler/hppa/c-call.lisp b/src/compiler/hppa/c-call.lisp index 088393a..4df3613 100644 --- a/src/compiler/hppa/c-call.lisp +++ b/src/compiler/hppa/c-call.lisp @@ -11,106 +11,220 @@ (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) @@ -123,6 +237,20 @@ (: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)) @@ -131,35 +259,40 @@ (: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) @@ -167,9 +300,25 @@ (: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)))))) + diff --git a/src/compiler/hppa/call.lisp b/src/compiler/hppa/call.lisp index 45bc167..ff31fe1 100644 --- a/src/compiler/hppa/call.lisp +++ b/src/compiler/hppa/call.lisp @@ -1,4 +1,4 @@ -;;;; 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. @@ -53,12 +53,12 @@ (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 @@ -98,10 +98,12 @@ (values)) -;;;; 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)) @@ -137,14 +139,17 @@ (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) @@ -152,7 +157,7 @@ (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) @@ -160,13 +165,15 @@ (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 @@ -181,6 +188,7 @@ (inst addi (* nargs n-word-bytes) csp-tn csp-tn)))) +;;; 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 @@ -245,92 +253,85 @@ default-value-8 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)) @@ -352,30 +353,35 @@ default-value-8 ;;; 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)) @@ -430,7 +436,6 @@ default-value-8 (: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 @@ -439,15 +444,16 @@ default-value-8 (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 @@ -467,8 +473,8 @@ default-value-8 (: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 @@ -477,16 +483,17 @@ default-value-8 (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))))) ;;;; Local call with known values return: @@ -511,7 +518,6 @@ default-value-8 (: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 @@ -520,15 +526,16 @@ default-value-8 (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 @@ -539,10 +546,10 @@ default-value-8 ;;; 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) @@ -551,7 +558,7 @@ default-value-8 (: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))) @@ -559,7 +566,7 @@ default-value-8 (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))) @@ -603,6 +610,7 @@ default-value-8 ;;; 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 @@ -613,12 +621,12 @@ default-value-8 '((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))))) @@ -633,185 +641,227 @@ default-value-8 (: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) @@ -824,48 +874,48 @@ default-value-8 (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))))) ;;;; 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) @@ -875,12 +925,12 @@ default-value-8 (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 @@ -897,10 +947,9 @@ default-value-8 ;;; 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) @@ -911,26 +960,35 @@ default-value-8 (: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 @@ -939,51 +997,43 @@ default-value-8 ;;; 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))) - ;;;; XEP hackery: @@ -996,7 +1046,7 @@ default-value-8 ;; 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 @@ -1011,7 +1061,7 @@ default-value-8 ;;; 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) @@ -1020,104 +1070,112 @@ default-value-8 (: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 @@ -1129,10 +1187,6 @@ default-value-8 ;;; 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) @@ -1147,7 +1201,6 @@ default-value-8 (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) @@ -1166,7 +1219,7 @@ default-value-8 (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) @@ -1191,3 +1244,27 @@ default-value-8 (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)) + diff --git a/src/compiler/hppa/cell.lisp b/src/compiler/hppa/cell.lisp index 7334e4e..78df196 100644 --- a/src/compiler/hppa/cell.lisp +++ b/src/compiler/hppa/cell.lisp @@ -24,7 +24,7 @@ (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) @@ -44,7 +44,7 @@ (: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 @@ -65,7 +65,7 @@ (: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) @@ -83,15 +83,15 @@ (: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))) + ;;;; Fdefinition (fdefn) objects. @@ -119,16 +119,17 @@ (: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) @@ -142,7 +143,6 @@ (storew temp fdefn fdefn-raw-addr-slot other-pointer-lowtag) (move fdefn result))) - ;;;; Binding and Unbinding. @@ -156,7 +156,7 @@ (: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))) @@ -169,29 +169,32 @@ (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)))) ;;;; Closure indexing. @@ -202,7 +205,7 @@ (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 @@ -240,7 +243,7 @@ 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) @@ -250,7 +253,8 @@ (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) + ;;;; raw instance slot accessors diff --git a/src/compiler/hppa/char.lisp b/src/compiler/hppa/char.lisp index 0a9d310..06b59dd 100644 --- a/src/compiler/hppa/char.lisp +++ b/src/compiler/hppa/char.lisp @@ -77,20 +77,20 @@ (: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))) ;;; Comparison of characters. (define-vop (character-compare) @@ -116,3 +116,4 @@ (define-vop (fast-char>/character character-compare) (:translate char>) (:variant :>>)) + diff --git a/src/compiler/hppa/debug.lisp b/src/compiler/hppa/debug.lisp index 24a9691..d25d226 100644 --- a/src/compiler/hppa/debug.lisp +++ b/src/compiler/hppa/debug.lisp @@ -1,8 +1,7 @@ (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) @@ -10,7 +9,7 @@ (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) @@ -18,7 +17,7 @@ (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))) @@ -27,12 +26,12 @@ (: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 *) @@ -40,7 +39,7 @@ (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)) @@ -53,7 +52,6 @@ (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) @@ -69,27 +67,32 @@ (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) @@ -103,7 +106,7 @@ (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) @@ -112,7 +115,7 @@ (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) diff --git a/src/compiler/hppa/float.lisp b/src/compiler/hppa/float.lisp index 86853e8..9e80579 100644 --- a/src/compiler/hppa/float.lisp +++ b/src/compiler/hppa/float.lisp @@ -20,9 +20,12 @@ (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) @@ -32,10 +35,16 @@ (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) @@ -64,7 +73,7 @@ (: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) @@ -129,41 +138,27 @@ (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) @@ -210,16 +205,14 @@ (: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)) @@ -229,16 +222,14 @@ (: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)) @@ -251,11 +242,11 @@ (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)) @@ -328,6 +319,86 @@ (single-reg double-reg complex-single-reg complex-double-reg) (descriptor-reg)) +;;;; 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) @@ -338,12 +409,9 @@ (: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) @@ -370,7 +438,6 @@ (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))) @@ -382,12 +449,9 @@ (: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 @@ -410,9 +474,9 @@ (: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))) @@ -432,6 +496,7 @@ (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 #b10001 #b01101 >/single-float >/double-float) (frob = #b00101 #b11001 eql/single-float eql/double-float)) @@ -450,12 +515,9 @@ (: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) @@ -463,6 +525,10 @@ 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) @@ -476,7 +542,6 @@ (: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) @@ -495,19 +560,19 @@ (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) @@ -537,10 +602,13 @@ (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") @@ -550,7 +618,6 @@ (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)) @@ -575,9 +642,12 @@ (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 @@ -586,9 +656,12 @@ (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)) @@ -613,185 +686,137 @@ (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)) - ;;;; 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)))) ;;;; Complex float VOPs @@ -847,7 +872,6 @@ (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)))) diff --git a/src/compiler/hppa/insts.lisp b/src/compiler/hppa/insts.lisp index ac68119..74d96c7 100644 --- a/src/compiler/hppa/insts.lisp +++ b/src/compiler/hppa/insts.lisp @@ -11,8 +11,11 @@ (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 + ;;;; Utility functions. @@ -120,28 +123,53 @@ ;;;; 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 @@ -149,23 +177,23 @@ '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)))) @@ -186,39 +214,38 @@ (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 \,<> \,>= @@ -258,9 +285,9 @@ \?>= \!< \!?= \<> \!= \!=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,|)) @@ -314,14 +341,14 @@ (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)) @@ -332,13 +359,13 @@ (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)) @@ -435,7 +462,8 @@ (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) @@ -496,48 +524,91 @@ (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) @@ -547,6 +618,8 @@ `(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 @@ -577,6 +650,8 @@ (: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 @@ -597,6 +672,8 @@ (: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 @@ -626,6 +703,8 @@ (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 @@ -636,41 +715,34 @@ (short-disp-encoding segment disp)))) -;;;; 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)))) ;;;; Branch instructions. @@ -706,29 +778,34 @@ (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))) @@ -738,6 +815,8 @@ (: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) @@ -749,6 +828,8 @@ (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 @@ -763,8 +844,11 @@ (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) @@ -774,13 +858,18 @@ (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) @@ -789,21 +878,33 @@ (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) @@ -814,9 +915,20 @@ 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)) @@ -832,14 +944,16 @@ 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 @@ -859,12 +973,17 @@ (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 @@ -899,7 +1018,7 @@ (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) @@ -913,28 +1032,22 @@ (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) @@ -950,6 +1063,8 @@ (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)) @@ -973,6 +1088,8 @@ (: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)) @@ -994,44 +1111,46 @@ (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)) @@ -1046,6 +1165,9 @@ (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))) @@ -1056,6 +1178,8 @@ (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)) @@ -1065,6 +1189,8 @@ (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) @@ -1072,6 +1198,8 @@ (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 @@ -1090,6 +1218,8 @@ (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) @@ -1097,6 +1227,8 @@ (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 @@ -1114,10 +1246,12 @@ (: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) @@ -1133,10 +1267,12 @@ (: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) @@ -1153,10 +1289,12 @@ (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) @@ -1174,10 +1312,12 @@ (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) @@ -1211,6 +1351,8 @@ (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)) @@ -1235,6 +1377,7 @@ (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 @@ -1256,6 +1399,8 @@ (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 @@ -1270,6 +1415,8 @@ (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))) @@ -1283,6 +1430,8 @@ (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)) @@ -1322,21 +1471,21 @@ (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)) @@ -1365,26 +1514,28 @@ (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) @@ -1392,127 +1543,128 @@ (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))))))))) ;;;; 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))) - -;;;; 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))))) + +;;;; 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)))))))) diff --git a/src/compiler/hppa/macros.lisp b/src/compiler/hppa/macros.lisp index 0360de0..6e3af24 100644 --- a/src/compiler/hppa/macros.lisp +++ b/src/compiler/hppa/macros.lisp @@ -11,13 +11,25 @@ (in-package "SB!VM") -;;; 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)) @@ -36,8 +48,7 @@ (+ (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) @@ -46,13 +57,17 @@ 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 @@ -63,28 +78,31 @@ ;;; 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))) @@ -100,6 +118,7 @@ (sc-case stack ((control-stack) (loadw reg cfp-tn offset)))))) + (defmacro store-stack-tn (stack reg) `(let ((stack ,stack) (reg ,reg)) @@ -109,6 +128,7 @@ (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)) @@ -169,7 +189,7 @@ initializes the object." ;;;; 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)) @@ -191,19 +211,23 @@ initializes the object." (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*) @@ -213,6 +237,7 @@ initializes the object." 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 @@ -255,15 +280,15 @@ initializes the object." ,@(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))) @@ -276,8 +301,7 @@ initializes the object." (: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) @@ -295,7 +319,7 @@ initializes the object." (: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 @@ -311,7 +335,7 @@ initializes the object." (: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))))) @@ -406,3 +430,4 @@ garbage collection. This is currently implemented by disabling GC" (declare (ignore objects)) ;should we eval these for side-effect? `(without-gcing ,@body)) + diff --git a/src/compiler/hppa/memory.lisp b/src/compiler/hppa/memory.lisp index b77cd3f..a3e7dc1 100644 --- a/src/compiler/hppa/memory.lisp +++ b/src/compiler/hppa/memory.lisp @@ -16,7 +16,7 @@ ;;; (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 @@ -36,9 +36,9 @@ ;;; (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))) diff --git a/src/compiler/hppa/move.lisp b/src/compiler/hppa/move.lisp index e8f754a..724ab93 100644 --- a/src/compiler/hppa/move.lisp +++ b/src/compiler/hppa/move.lisp @@ -24,14 +24,12 @@ (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)) @@ -42,7 +40,7 @@ (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) @@ -58,7 +56,7 @@ (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) @@ -73,17 +71,22 @@ ;;;; 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 @@ -95,7 +98,7 @@ ;;; 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)) @@ -106,10 +109,9 @@ (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)) - ;;;; ILLEGAL-MOVE @@ -142,6 +144,7 @@ (: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)) @@ -152,6 +155,7 @@ (:note "constant load") (:generator 1 (inst li (tn-value x) y))) + (define-move-vop move-to-word-c :move (constant) (signed-reg unsigned-reg)) @@ -161,9 +165,10 @@ (: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)) @@ -176,29 +181,34 @@ (: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)) @@ -206,36 +216,27 @@ ;;; 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)) @@ -251,6 +252,7 @@ (:note "word integer move") (:generator 0 (move x y))) + (define-move-vop word-move :move (signed-reg unsigned-reg) (signed-reg unsigned-reg)) @@ -268,6 +270,7 @@ (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)) diff --git a/src/compiler/hppa/nlx.lisp b/src/compiler/hppa/nlx.lisp index a890cdb..b5dd83a 100644 --- a/src/compiler/hppa/nlx.lisp +++ b/src/compiler/hppa/nlx.lisp @@ -10,11 +10,10 @@ ;;; non-local entry. (!def-vm-support-routine make-nlx-entry-arg-start-location () (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ocfp-offset)) - ;;; Save and restore dynamic environment. ;;; -;;; These VOPs are used in the reentered function to restore the appropriate +;;; 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 @@ -83,23 +82,24 @@ (: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. @@ -149,9 +149,9 @@ (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)) @@ -160,31 +160,27 @@ (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))) @@ -203,32 +199,32 @@ (: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. ;;; diff --git a/src/compiler/hppa/parms.lisp b/src/compiler/hppa/parms.lisp index 30cba51..8cec2ba 100644 --- a/src/compiler/hppa/parms.lisp +++ b/src/compiler/hppa/parms.lisp @@ -1,7 +1,7 @@ (in-package "SB!VM") - ;;;; 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) @@ -17,16 +17,16 @@ (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)) @@ -49,11 +49,11 @@ (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. @@ -62,28 +62,35 @@ ;;; 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) ;;;; Other random constants. +(defenum (:suffix -flag) + atomic + interrupted) + (defenum (:suffix -trap :start 8) halt pending-interrupt @@ -91,7 +98,10 @@ 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 @@ -125,11 +135,14 @@ 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)) + diff --git a/src/compiler/hppa/sanctify.lisp b/src/compiler/hppa/sanctify.lisp index fb25bae..45afb7b 100644 --- a/src/compiler/hppa/sanctify.lisp +++ b/src/compiler/hppa/sanctify.lisp @@ -14,6 +14,7 @@ (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" diff --git a/src/compiler/hppa/sap.lisp b/src/compiler/hppa/sap.lisp index 6aa3972..669041f 100644 --- a/src/compiler/hppa/sap.lisp +++ b/src/compiler/hppa/sap.lisp @@ -15,23 +15,25 @@ ;;; 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)) @@ -42,10 +44,12 @@ :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)) @@ -56,12 +60,14 @@ (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)) @@ -94,25 +100,24 @@ ;;;; 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-) @@ -243,10 +248,8 @@ (: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))) ;;; Transforms for 64-bit SAP accessors. diff --git a/src/compiler/hppa/show.lisp b/src/compiler/hppa/show.lisp index 52d800c..7e4130f 100644 --- a/src/compiler/hppa/show.lisp +++ b/src/compiler/hppa/show.lisp @@ -1,31 +1,25 @@ (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))))) + diff --git a/src/compiler/hppa/static-fn.lisp b/src/compiler/hppa/static-fn.lisp index 0d95e08..b1aa18b 100644 --- a/src/compiler/hppa/static-fn.lisp +++ b/src/compiler/hppa/static-fn.lisp @@ -1,6 +1,5 @@ (in-package "SB!VM") - (define-vop (static-fun-template) (:save-p t) (:policy :safe) @@ -9,19 +8,18 @@ (: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)) @@ -56,7 +54,7 @@ (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) @@ -71,11 +69,11 @@ (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)) @@ -98,19 +96,19 @@ ) ; 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 diff --git a/src/compiler/hppa/subprim.lisp b/src/compiler/hppa/subprim.lisp index 6a5d718..e26207f 100644 --- a/src/compiler/hppa/subprim.lisp +++ b/src/compiler/hppa/subprim.lisp @@ -22,7 +22,7 @@ (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 @@ -32,7 +32,7 @@ (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 diff --git a/src/compiler/hppa/system.lisp b/src/compiler/hppa/system.lisp index 9246fae..a6fc0ff 100644 --- a/src/compiler/hppa/system.lisp +++ b/src/compiler/hppa/system.lisp @@ -10,32 +10,55 @@ (: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) @@ -43,7 +66,8 @@ (: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)) @@ -54,7 +78,7 @@ (: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) @@ -65,7 +89,7 @@ (: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) @@ -75,34 +99,31 @@ (: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) @@ -111,20 +132,24 @@ (: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))))) ;;;; Allocation @@ -164,8 +189,8 @@ (: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))) @@ -177,8 +202,9 @@ (: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))) diff --git a/src/compiler/hppa/type-vops.lisp b/src/compiler/hppa/type-vops.lisp index 29a4a6b..03144c8 100644 --- a/src/compiler/hppa/type-vops.lisp +++ b/src/compiler/hppa/type-vops.lisp @@ -31,8 +31,7 @@ (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)) @@ -116,7 +115,6 @@ ;;; 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) @@ -149,14 +147,13 @@ ;;; 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) @@ -170,8 +167,10 @@ ;; 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. diff --git a/src/compiler/hppa/values.lisp b/src/compiler/hppa/values.lisp index 09844f8..44df9fe 100644 --- a/src/compiler/hppa/values.lisp +++ b/src/compiler/hppa/values.lisp @@ -5,6 +5,57 @@ (: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 @@ -17,12 +68,16 @@ (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))) @@ -30,13 +85,13 @@ (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. ;;; @@ -48,28 +103,25 @@ (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. ;;; @@ -77,8 +129,9 @@ (: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))) @@ -92,12 +145,12 @@ (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)) diff --git a/src/compiler/hppa/vm.lisp b/src/compiler/hppa/vm.lisp index 3ead719..d67d49c 100644 --- a/src/compiler/hppa/vm.lisp +++ b/src/compiler/hppa/vm.lisp @@ -12,12 +12,11 @@ (in-package "SB!VM") -;;;; 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) @@ -27,11 +26,10 @@ `(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. @@ -73,14 +71,19 @@ (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) @@ -92,7 +95,7 @@ ;;; ;;; 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)) @@ -113,7 +116,7 @@ (!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. @@ -141,13 +144,16 @@ (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)) @@ -163,12 +169,12 @@ (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)) @@ -176,6 +182,7 @@ ;; 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)) @@ -183,11 +190,13 @@ ;; 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)) @@ -232,11 +241,28 @@ :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 + )) ;;;; 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"))) @@ -248,18 +274,23 @@ ;; 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. @@ -282,7 +313,7 @@ (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) @@ -326,11 +357,11 @@ ;;; 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. diff --git a/version.lisp-expr b/version.lisp-expr index e8a18e8..801c999 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; 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"