From 8a19c6876412b8ad1cf729297c2a373d63a0d0ec Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Mon, 19 Aug 2002 12:13:59 +0000 Subject: [PATCH] 0.7.6.27: Merge (alpha-quality, probably) HPPA/Linux port ... added hppa fixups in genesis.lisp ... moved disassem-state definition from target-disassem.lisp to disassem.lisp, so building it on the host ... lots of new files (thank you, CMUCL) Minor boilerplate cleanups in src/runtime/ --- NEWS | 4 + make-config.sh | 1 + src/assembly/hppa/alloc.lisp | 6 + src/assembly/hppa/arith.lisp | 265 ++++++ src/assembly/hppa/array.lisp | 96 +++ src/assembly/hppa/assem-rtns.lisp | 203 +++++ src/assembly/hppa/support.lisp | 62 ++ src/code/hppa-vm.lisp | 103 +++ src/compiler/disassem.lisp | 65 ++ src/compiler/generic/genesis.lisp | 34 +- src/compiler/hppa/alloc.lisp | 170 ++++ src/compiler/hppa/arith.lisp | 878 ++++++++++++++++++++ src/compiler/hppa/array.lisp | 472 +++++++++++ src/compiler/hppa/backend-parms.lisp | 7 + src/compiler/hppa/c-call.lisp | 165 ++++ src/compiler/hppa/call.lisp | 1220 +++++++++++++++++++++++++++ src/compiler/hppa/cell.lisp | 253 ++++++ src/compiler/hppa/char.lisp | 120 +++ src/compiler/hppa/debug.lisp | 121 +++ src/compiler/hppa/float.lisp | 930 +++++++++++++++++++++ src/compiler/hppa/insts.lisp | 1510 ++++++++++++++++++++++++++++++++++ src/compiler/hppa/macros.lisp | 383 +++++++++ src/compiler/hppa/memory.lisp | 44 + src/compiler/hppa/move.lisp | 290 +++++++ src/compiler/hppa/nlx.lisp | 258 ++++++ src/compiler/hppa/parms.lisp | 168 ++++ src/compiler/hppa/pred.lisp | 25 + src/compiler/hppa/sanctify.lisp | 26 + src/compiler/hppa/sap.lisp | 290 +++++++ src/compiler/hppa/show.lisp | 31 + src/compiler/hppa/static-fn.lisp | 126 +++ src/compiler/hppa/subprim.lisp | 41 + src/compiler/hppa/system.lisp | 213 +++++ src/compiler/hppa/target-insts.lisp | 15 + src/compiler/hppa/type-vops.lisp | 548 ++++++++++++ src/compiler/hppa/values.lisp | 103 +++ src/compiler/hppa/vm.lisp | 353 ++++++++ src/compiler/target-disassem.lisp | 65 -- src/runtime/Config.hppa-linux | 22 + src/runtime/hppa-arch.c | 457 ++++++++++ src/runtime/hppa-arch.h | 6 + src/runtime/hppa-assem.S | 459 +++++++++++ src/runtime/hppa-linux-os.c | 87 ++ src/runtime/hppa-linux-os.h | 13 + src/runtime/hppa-lispregs.h | 63 ++ src/runtime/ppc-arch.c | 9 - src/runtime/sparc-arch.c | 17 +- version.lisp-expr | 2 +- 48 files changed, 10714 insertions(+), 85 deletions(-) create mode 100644 src/assembly/hppa/alloc.lisp create mode 100644 src/assembly/hppa/arith.lisp create mode 100644 src/assembly/hppa/array.lisp create mode 100644 src/assembly/hppa/assem-rtns.lisp create mode 100644 src/assembly/hppa/support.lisp create mode 100644 src/code/hppa-vm.lisp create mode 100644 src/compiler/hppa/alloc.lisp create mode 100644 src/compiler/hppa/arith.lisp create mode 100644 src/compiler/hppa/array.lisp create mode 100644 src/compiler/hppa/backend-parms.lisp create mode 100644 src/compiler/hppa/c-call.lisp create mode 100644 src/compiler/hppa/call.lisp create mode 100644 src/compiler/hppa/cell.lisp create mode 100644 src/compiler/hppa/char.lisp create mode 100644 src/compiler/hppa/debug.lisp create mode 100644 src/compiler/hppa/float.lisp create mode 100644 src/compiler/hppa/insts.lisp create mode 100644 src/compiler/hppa/macros.lisp create mode 100644 src/compiler/hppa/memory.lisp create mode 100644 src/compiler/hppa/move.lisp create mode 100644 src/compiler/hppa/nlx.lisp create mode 100644 src/compiler/hppa/parms.lisp create mode 100644 src/compiler/hppa/pred.lisp create mode 100644 src/compiler/hppa/sanctify.lisp create mode 100644 src/compiler/hppa/sap.lisp create mode 100644 src/compiler/hppa/show.lisp create mode 100644 src/compiler/hppa/static-fn.lisp create mode 100644 src/compiler/hppa/subprim.lisp create mode 100644 src/compiler/hppa/system.lisp create mode 100644 src/compiler/hppa/target-insts.lisp create mode 100644 src/compiler/hppa/type-vops.lisp create mode 100644 src/compiler/hppa/values.lisp create mode 100644 src/compiler/hppa/vm.lisp create mode 100644 src/runtime/Config.hppa-linux create mode 100644 src/runtime/hppa-arch.c create mode 100644 src/runtime/hppa-arch.h create mode 100644 src/runtime/hppa-assem.S create mode 100644 src/runtime/hppa-linux-os.c create mode 100644 src/runtime/hppa-linux-os.h create mode 100644 src/runtime/hppa-lispregs.h diff --git a/NEWS b/NEWS index d9d5817..66875b9 100644 --- a/NEWS +++ b/NEWS @@ -1191,6 +1191,10 @@ changes in sbcl-0.7.6 relative to sbcl-0.7.5: is no longer a static symbol.) changes in sbcl-0.7.7 relative to sbcl-0.7.6: + * An alpha-quality port to the parisc architecture running Linux, + based on the old CMUCL backend has been made. This, even more so + than the other backends, should be considered still a work in + progress. * fixed bug 189: The compiler now respects NOTINLINE declarations for functions declared in FLET and LABELS. (I.e. "LET conversion" is suppressed.) Also now that the compiler is looking at declarations diff --git a/make-config.sh b/make-config.sh index 021b115..47ed7b5 100644 --- a/make-config.sh +++ b/make-config.sh @@ -35,6 +35,7 @@ case `uname -m` in sparc*) guessed_sbcl_arch=sparc ;; sun*) guessed_sbcl_arch=sparc ;; ppc) guessed_sbcl_arch=ppc ;; + parisc) guessed_sbcl_arch=hppa ;; *) # If we're not building on a supported target architecture, we # we have no guess, but it's not an error yet, since maybe diff --git a/src/assembly/hppa/alloc.lisp b/src/assembly/hppa/alloc.lisp new file mode 100644 index 0000000..9508291 --- /dev/null +++ b/src/assembly/hppa/alloc.lisp @@ -0,0 +1,6 @@ +(in-package "SB!VM") + +;;; Given that the pseudo-atomic sequence is so short, there is +;;; nothing that qualifies. But we want to keep the file around +;;; in case we decide to add something later. + diff --git a/src/assembly/hppa/arith.lisp b/src/assembly/hppa/arith.lisp new file mode 100644 index 0000000..4929582 --- /dev/null +++ b/src/assembly/hppa/arith.lisp @@ -0,0 +1,265 @@ +(in-package "SB!VM") + + +;;;; Multiplication and Division helping routines. + +;;; ?? FIXME: Where are generic-* and generic-/? +#+sb-assembling +(define-assembly-routine + multiply + ((:arg x (signed-reg) nl0-offset) + (:arg y (signed-reg) nl1-offset) + + (:res res (signed-reg) nl2-offset) + + (:temp tmp (unsigned-reg) nl3-offset) + (:temp sign (unsigned-reg) nl4-offset)) + + ;; Determine the sign of the result. + (inst extrs x 0 1 sign :=) + (inst sub zero-tn x x) + (inst extrs y 0 1 tmp :=) + (inst sub zero-tn y y) + (inst xor sign tmp sign) + + ;; Make sure X is less then Y. + (inst comclr x y tmp :<<) + (inst xor x y tmp) + (inst xor x tmp x) + (inst xor y tmp y) + ;; Blow out of here if the result is zero. + (inst comb := x zero-tn done) + (inst li 0 res) + + LOOP + (inst extru x 31 1 zero-tn :ev) + (inst add y res res) + (inst extru x 30 1 zero-tn :ev) + (inst sh1add y res res) + (inst extru x 29 1 zero-tn :ev) + (inst sh2add y res res) + (inst extru x 28 1 zero-tn :ev) + (inst sh3add y res res) + + (inst srl x 4 x) + (inst comb :<> x zero-tn loop) + (inst sll y 4 y) + + DONE + (inst xor res sign res) + (inst add res sign res)) + + +#+sb-assembling +(define-assembly-routine + (truncate) + ((:arg dividend signed-reg nl0-offset) + (:arg divisor signed-reg nl1-offset) + + (:res quo signed-reg nl2-offset) + (:res rem signed-reg nl3-offset)) + + ;; Move abs(divident) into quo. + (inst move dividend quo :>=) + (inst sub zero-tn quo quo) + ;; Do one divive-step with -divisor to prime V (use rem as a temp) + (inst sub zero-tn divisor rem) + (inst ds zero-tn rem zero-tn) + ;; Shift the divident/quotient one bit, setting the carry flag. + (inst add quo quo quo) + ;; The first real divive-step. + (inst ds zero-tn divisor rem) + (inst addc quo quo quo) + ;; And 31 more of them. + (dotimes (i 31) + (inst ds rem divisor rem) + (inst addc quo quo quo)) + ;; If the remainder is negative, we need to add the absolute value of the + ;; divisor. + (inst comb :>= rem zero-tn remainder-positive) + (inst comclr divisor zero-tn zero-tn :<) + (inst add rem divisor rem :tr) + (inst sub rem divisor rem) + REMAINDER-POSITIVE + ;; Now we have to fix the signs of quo and rem. + (inst xor divisor dividend zero-tn :>=) + (inst sub zero-tn quo quo) + (inst move dividend zero-tn :>=) + (inst sub zero-tn rem rem)) + + + +;;;; Generic arithmetic. + +(define-assembly-routine (generic-+ + (:cost 10) + (:return-style :full-call) + (:translate +) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res (descriptor-reg any-reg) a0-offset) + + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst extru x 31 2 zero-tn :=) + (inst b do-static-fun :nullify t) + (inst extru y 31 2 zero-tn :=) + (inst b do-static-fun :nullify t) + (inst addo x y res) + (lisp-return lra :offset 1) + + DO-STATIC-FUN + (inst ldw (static-fun-offset 'two-arg-+) null-tn lip) + (inst li (fixnumize 2) nargs) + (inst move cfp-tn ocfp) + (inst bv lip) + (inst move csp-tn cfp-tn)) + +(define-assembly-routine (generic-- + (:cost 10) + (:return-style :full-call) + (:translate -) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res (descriptor-reg any-reg) a0-offset) + + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst extru x 31 2 zero-tn :=) + (inst b do-static-fun :nullify t) + (inst extru y 31 2 zero-tn :=) + (inst b do-static-fun :nullify t) + (inst subo x y res) + (lisp-return lra :offset 1) + + DO-STATIC-FUN + (inst ldw (static-fun-offset 'two-arg--) null-tn lip) + (inst li (fixnumize 2) nargs) + (inst move cfp-tn ocfp) + (inst bv lip) + (inst move csp-tn cfp-tn)) + + + +;;;; Comparison routines. + +(macrolet + ((define-cond-assem-rtn (name translate static-fn cond) + `(define-assembly-routine (,name + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate ,translate) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst extru x 31 2 zero-tn :=) + (inst b do-static-fn :nullify t) + (inst extru y 31 2 zero-tn :=) + (inst b do-static-fn :nullify t) + + (inst comclr x y zero-tn ,cond) + (inst move null-tn res :tr) + (load-symbol res t) + (lisp-return lra :offset 1) + + DO-STATIC-FN + (inst ldw (static-fun-offset ',static-fn) null-tn lip) + (inst li (fixnumize 2) nargs) + (inst move cfp-tn ocfp) + (inst bv lip) + (inst move csp-tn cfp-tn)))) + + (define-cond-assem-rtn generic-< < two-arg-< :<) + (define-cond-assem-rtn generic-> > two-arg-> :>)) + + +(define-assembly-routine + (generic-eql + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate eql) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + + (inst comb := x y return-t :nullify t) + (inst extru x 31 2 zero-tn :<>) + (inst b return-nil :nullify t) + (inst extru y 31 2 zero-tn :=) + (inst b do-static-fn :nullify t) + + RETURN-NIL + (inst move null-tn res) + (lisp-return lra :offset 1) + + DO-STATIC-FN + (inst ldw (static-fun-offset 'eql) null-tn lip) + (inst li (fixnumize 2) nargs) + (inst move cfp-tn ocfp) + (inst bv lip) + (inst move csp-tn cfp-tn) + + RETURN-T + (load-symbol res t)) + +(define-assembly-routine + (generic-= + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate =) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + + (inst comb := x y return-t :nullify t) + (inst extru x 31 2 zero-tn :=) + (inst b do-static-fn :nullify t) + (inst extru y 31 2 zero-tn :=) + (inst b do-static-fn :nullify t) + + (inst move null-tn res) + (lisp-return lra :offset 1) + + DO-STATIC-FN + (inst ldw (static-fun-offset 'two-arg-=) null-tn lip) + (inst li (fixnumize 2) nargs) + (inst move cfp-tn ocfp) + (inst bv lip) + (inst move csp-tn cfp-tn) + + RETURN-T + (load-symbol res t)) diff --git a/src/assembly/hppa/array.lisp b/src/assembly/hppa/array.lisp new file mode 100644 index 0000000..d4dc139 --- /dev/null +++ b/src/assembly/hppa/array.lisp @@ -0,0 +1,96 @@ +(in-package "SB!VM") + +(define-assembly-routine + (allocate-vector + (:policy :fast-safe) + (:translate allocate-vector) + (:arg-types positive-fixnum + positive-fixnum + positive-fixnum)) + ((:arg type any-reg a0-offset) + (:arg length any-reg a1-offset) + (:arg words any-reg a2-offset) + (:res result descriptor-reg a0-offset) + + (:temp ndescr non-descriptor-reg nl0-offset) + (:temp vector descriptor-reg a3-offset)) + (pseudo-atomic () + (move alloc-tn vector) + (inst dep other-pointer-lowtag 31 3 vector) + (inst addi (* (1+ vector-data-offset) n-word-bytes) words ndescr) + (inst dep 0 31 3 ndescr) + (inst add ndescr alloc-tn alloc-tn) + (inst srl type word-shift ndescr) + (storew ndescr vector 0 other-pointer-lowtag) + (storew length vector vector-length-slot other-pointer-lowtag)) + (move vector result)) + + + +;;;; 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 new file mode 100644 index 0000000..85b60a3 --- /dev/null +++ b/src/assembly/hppa/assem-rtns.lisp @@ -0,0 +1,203 @@ +(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 lra descriptor-reg lra-offset) + + ;; These are just needed to facilitate the transfer + (:temp count any-reg nl2-offset) + (:temp src any-reg nl3-offset) + (:temp dst any-reg nl4-offset) + (:temp temp descriptor-reg l0-offset) + + ;; These are needed so we can get at the register args. + (:temp a0 descriptor-reg a0-offset) + (:temp a1 descriptor-reg a1-offset) + (:temp a2 descriptor-reg a2-offset) + (:temp a3 descriptor-reg a3-offset) + (:temp a4 descriptor-reg a4-offset) + (:temp a5 descriptor-reg a5-offset)) + + (inst movb := nvals count default-a0-and-on :nullify t) + (loadw a0 vals 0) + (inst addib := (fixnumize -1) count default-a1-and-on :nullify t) + (loadw a1 vals 1) + (inst addib := (fixnumize -1) count default-a2-and-on :nullify t) + (loadw a2 vals 2) + (inst addib := (fixnumize -1) count default-a3-and-on :nullify t) + (loadw a3 vals 3) + (inst addib := (fixnumize -1) count default-a4-and-on :nullify t) + (loadw a4 vals 4) + (inst addib := (fixnumize -1) count default-a5-and-on :nullify t) + (loadw a5 vals 5) + (inst addib := (fixnumize -1) count done :nullify t) + + ;; Copy the remaining args to the top of the stack. + (inst addi (* 6 n-word-bytes) vals src) + (inst addi (* 6 n-word-bytes) cfp-tn dst) + + LOOP + (inst ldwm 4 src temp) + (inst addib :> (fixnumize -1) count loop) + (inst stwm temp 4 dst) + + (inst b done :nullify t) + + DEFAULT-A0-AND-ON + (inst move null-tn a0) + DEFAULT-A1-AND-ON + (inst move null-tn a1) + DEFAULT-A2-AND-ON + (inst move null-tn a2) + DEFAULT-A3-AND-ON + (inst move null-tn a3) + DEFAULT-A4-AND-ON + (inst move null-tn a4) + DEFAULT-A5-AND-ON + (inst move null-tn a5) + + DONE + ;; Clear the stack. + (move cfp-tn ocfp-tn) + (move old-fp cfp-tn) + (inst add ocfp-tn nvals csp-tn) + + ;; Return. + (lisp-return lra)) + + + +;;;; tail-call-variable. + +#+sb-assembling ;; no vop for this one either. +(define-assembly-routine + (tail-call-variable + (:return-style :none)) + + ;; These are really args. + ((:temp args any-reg nl0-offset) + (:temp lexenv descriptor-reg lexenv-offset) + + ;; We need to compute this + (:temp nargs any-reg nargs-offset) + + ;; These are needed by the blitting code. + (:temp src any-reg nl1-offset) + (:temp dst any-reg nl2-offset) + (:temp count any-reg nl3-offset) + (:temp temp descriptor-reg l0-offset) + + ;; These are needed so we can get at the register args. + (:temp a0 descriptor-reg a0-offset) + (:temp a1 descriptor-reg a1-offset) + (:temp a2 descriptor-reg a2-offset) + (:temp a3 descriptor-reg a3-offset) + (:temp a4 descriptor-reg a4-offset) + (:temp a5 descriptor-reg a5-offset)) + + + ;; Calculate NARGS (as a fixnum) + (inst sub csp-tn args nargs) + + ;; Load the argument regs (must do this now, 'cause the blt might + ;; trash these locations) + (loadw a0 args 0) + (loadw a1 args 1) + (loadw a2 args 2) + (loadw a3 args 3) + (loadw a4 args 4) + (loadw a5 args 5) + + ;; Calc SRC, DST, and COUNT + (inst addi (fixnumize (- register-arg-count)) nargs count) + (inst comb :<= count zero-tn done :nullify t) + (inst addi (* n-word-bytes register-arg-count) args src) + (inst addi (* n-word-bytes register-arg-count) cfp-tn dst) + + LOOP + ;; Copy one arg. + (inst ldwm 4 src temp) + (inst addib :> (fixnumize -1) count loop) + (inst stwm temp 4 dst) + + DONE + ;; We are done. Do the jump. + (loadw temp lexenv closure-fun-slot fun-pointer-lowtag) + (lisp-jump temp)) + + + +;;;; Non-local exit noise. + +;;; FIXME: Really? +#+sb-assembling +(defparameter *unwind-entry-point* (gen-label)) + +(define-assembly-routine + (unwind + (:translate %continue-unwind) + (:policy :fast-safe)) + ((:arg block (any-reg descriptor-reg) a0-offset) + (:arg start (any-reg descriptor-reg) ocfp-offset) + (:arg count (any-reg descriptor-reg) nargs-offset) + (:temp lra descriptor-reg lra-offset) + (:temp cur-uwp any-reg nl0-offset) + (:temp next-uwp any-reg nl1-offset) + (:temp target-uwp any-reg nl2-offset)) + (declare (ignore start count)) + + (emit-label *unwind-entry-point*) + + (let ((error (generate-error-code nil invalid-unwind-error))) + (inst bc := nil block zero-tn error)) + + (load-symbol-value cur-uwp *current-unwind-protect-block*) + (loadw target-uwp block unwind-block-current-uwp-slot) + (inst bc :<> nil cur-uwp target-uwp do-uwp) + + (move block cur-uwp) + + DO-EXIT + + (loadw cfp-tn cur-uwp unwind-block-current-cont-slot) + (loadw code-tn cur-uwp unwind-block-current-code-slot) + (loadw lra cur-uwp unwind-block-entry-pc-slot) + (lisp-return lra :frob-code nil) + + DO-UWP + + (loadw next-uwp cur-uwp unwind-block-current-uwp-slot) + (inst b do-exit) + (store-symbol-value next-uwp *current-unwind-protect-block*)) + + +(define-assembly-routine + throw + ((:arg target descriptor-reg a0-offset) + (:arg start any-reg ocfp-offset) + (:arg count any-reg nargs-offset) + (:temp catch any-reg a1-offset) + (:temp tag descriptor-reg a2-offset)) + (declare (ignore start count)) ; We just need them in the registers. + + (load-symbol-value catch *current-catch-block*) + + LOOP + (let ((error (generate-error-code nil unseen-throw-tag-error target))) + (inst bc := nil catch zero-tn error)) + (loadw tag catch catch-block-tag-slot) + (inst comb :<> tag target loop :nullify t) + (loadw catch catch catch-block-previous-catch-slot) + + (inst b *unwind-entry-point*) + (inst move catch target)) diff --git a/src/assembly/hppa/support.lisp b/src/assembly/hppa/support.lisp new file mode 100644 index 0000000..1ed5d6a --- /dev/null +++ b/src/assembly/hppa/support.lisp @@ -0,0 +1,62 @@ +(in-package "SB!VM") + + +(!def-vm-support-routine generate-call-sequence (name style vop) + (ecase style + (:raw + (let ((fixup (gensym "FIXUP-"))) + (values + `((let ((fixup (make-fixup ',name :assembly-routine))) + (inst ldil fixup ,fixup) + (inst ble fixup lisp-heap-space ,fixup :nullify t)) + (inst nop)) + `((:temporary (:scs (any-reg) :from (:eval 0) :to (:eval 1)) + ,fixup))))) + (:full-call + (let ((temp (make-symbol "TEMP")) + (nfp-save (make-symbol "NFP-SAVE")) + (lra (make-symbol "LRA"))) + (values + `((let ((lra-label (gen-label)) + (cur-nfp (current-nfp-tn ,vop))) + (when cur-nfp + (store-stack-tn ,nfp-save cur-nfp)) + (inst compute-lra-from-code code-tn lra-label ,temp ,lra) + (note-this-location ,vop :call-site) + (let ((fixup (make-fixup ',name :assembly-routine))) + (inst ldil fixup ,temp) + (inst be fixup lisp-heap-space ,temp :nullify t)) + (emit-return-pc lra-label) + (note-this-location ,vop :single-value-return) + (move ocfp-tn csp-tn) + (inst compute-code-from-lra code-tn lra-label ,temp code-tn) + (when cur-nfp + (load-stack-tn cur-nfp ,nfp-save)))) + `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1)) + ,temp) + (:temporary (:sc descriptor-reg :offset lra-offset + :from (:eval 0) :to (:eval 1)) + ,lra) + (:temporary (:scs (control-stack) :offset nfp-save-offset) + ,nfp-save) + (:save-p :compute-only))))) + (:none + (let ((fixup (gensym "FIXUP-"))) + (values + `((let ((fixup (make-fixup ',name :assembly-routine))) + (inst ldil fixup ,fixup) + (inst be fixup lisp-heap-space ,fixup :nullify t))) + `((:temporary (:scs (any-reg) :from (:eval 0) :to (:eval 1)) + ,fixup))))))) + + +(!def-vm-support-routine generate-return-sequence (style) + (ecase style + (:raw + `((inst bv lip-tn :nullify t))) + (:full-call + `((lisp-return (make-random-tn :kind :normal + :sc (sc-or-lose 'descriptor-reg) + :offset lra-offset) + :offset 1))) + (:none))) diff --git a/src/code/hppa-vm.lisp b/src/code/hppa-vm.lisp new file mode 100644 index 0000000..f468470 --- /dev/null +++ b/src/code/hppa-vm.lisp @@ -0,0 +1,103 @@ +(in-package "SB!VM") + +(define-alien-type os-context-t (struct os-context-t-struct)) + +;;;; MACHINE-TYPE and MACHINE-VERSION + +(defun machine-type () + "Returns a string describing the type of the local machine." + "HPPA") + +(defun machine-version () + "Returns a string describing the version of the local machine." + "HPPA") + + +;;; FIXUP-CODE-OBJECT -- Interface +;;; +(defun fixup-code-object (code offset value kind) + (unless (zerop (rem offset n-word-bytes)) + (error "Unaligned instruction? offset=#x~X." offset)) + (sb!sys:without-gcing + (let* ((sap (truly-the system-area-pointer + (%primitive sb!kernel::code-instructions code))) + (inst (sap-ref-32 sap offset))) + (setf (sap-ref-32 sap offset) + (ecase kind + (:load + (logior (ash (ldb (byte 11 0) value) 1) + (logand inst #xffffc000))) + (:load-short + (let ((low-bits (ldb (byte 11 0) value))) + (assert (<= 0 low-bits (1- (ash 1 4)))) + (logior (ash low-bits 17) + (logand inst #xffe0ffff)))) + (:hi + (logior (ash (ldb (byte 5 13) value) 16) + (ash (ldb (byte 2 18) value) 14) + (ash (ldb (byte 2 11) value) 12) + (ash (ldb (byte 11 20) value) 1) + (ldb (byte 1 31) value) + (logand inst #xffe00000))) + (:branch + (let ((bits (ldb (byte 9 2) value))) + (assert (zerop (ldb (byte 2 0) value))) + (logior (ash bits 3) + (logand inst #xffe0e002))))))))) + +(define-alien-routine ("os_context_pc_addr" context-pc-addr) (* unsigned-int) + (context (* os-context-t))) + +(defun context-pc (context) + (declare (type (alien (* os-context-t)) context)) + (int-sap (logandc2 (deref (context-pc-addr context)) 3))) + +(define-alien-routine ("os_context_register_addr" context-register-addr) + (* unsigned-int) + (context (* os-context-t)) + (index int)) + +;;; FIXME: Should this and CONTEXT-PC be INLINE to reduce consing? +;;; (Are they used in anything time-critical, or just the debugger?) +(defun context-register (context index) + (declare (type (alien (* os-context-t)) context)) + (deref (context-register-addr context index))) + +(defun %set-context-register (context index new) +(declare (type (alien (* os-context-t)) context)) +(setf (deref (context-register-addr context index)) + new)) + +#!+linux +;;; For now. +(defun context-floating-point-modes (context) + (warn "stub CONTEXT-FLOATING-POINT-MODES") + 0) + +;;;; Internal-error-arguments. + +;;; INTERNAL-ERROR-ARGUMENTS -- interface. +;;; +;;; Given the sigcontext, extract the internal error arguments from the +;;; instruction stream. +;;; +(defun internal-error-args (context) + (declare (type (alien (* os-context-t)) context)) + (let ((pc (context-pc context))) + (declare (type system-area-pointer pc)) + (let* ((length (sap-ref-8 pc 4)) + (vector (make-array length :element-type '(unsigned-byte 8)))) + (declare (type (unsigned-byte 8) length) + (type (simple-array (unsigned-byte 8) (*)) vector)) + (copy-from-system-area pc (* n-byte-bits 5) + vector (* n-word-bits + vector-data-offset) + (* length n-byte-bits)) + (let* ((index 0) + (error-number (sb!c::read-var-integer vector index))) + (collect ((sc-offsets)) + (loop + (when (>= index length) + (return)) + (sc-offsets (sb!c::read-var-integer vector index))) + (values error-number (sc-offsets))))))) diff --git a/src/compiler/disassem.lisp b/src/compiler/disassem.lisp index f25e490..2341203 100644 --- a/src/compiler/disassem.lisp +++ b/src/compiler/disassem.lisp @@ -1553,6 +1553,71 @@ (type disassem-state dstate) (optimize (speed 3) (safety 0))) (sign-extend (read-suffix length dstate) length)) + +;;; All state during disassembly. We store some seemingly redundant +;;; information so that we can allow garbage collect during disassembly and +;;; not get tripped up by a code block being moved... +(defstruct (disassem-state (:conc-name dstate-) + (:constructor %make-dstate) + (:copier nil)) + ;; offset of current pos in segment + (cur-offs 0 :type offset) + ;; offset of next position + (next-offs 0 :type offset) + ;; a sap pointing to our segment + (segment-sap (missing-arg) :type sb!sys:system-area-pointer) + ;; the current segment + (segment nil :type (or null segment)) + ;; what to align to in most cases + (alignment sb!vm:n-word-bytes :type alignment) + (byte-order :little-endian + :type (member :big-endian :little-endian)) + ;; for user code to hang stuff off of + (properties nil :type list) + (filtered-values (make-array max-filtered-value-index) + :type filtered-value-vector) + ;; used for prettifying printing + (addr-print-len nil :type (or null (integer 0 20))) + (argument-column 0 :type column) + ;; to make output look nicer + (output-state :beginning + :type (member :beginning + :block-boundary + nil)) + + ;; alist of (address . label-number) + (labels nil :type list) + ;; same as LABELS slot data, but in a different form + (label-hash (make-hash-table) :type hash-table) + ;; list of function + (fun-hooks nil :type list) + + ;; alist of (address . label-number), popped as it's used + (cur-labels nil :type list) + ;; OFFS-HOOKs, popped as they're used + (cur-offs-hooks nil :type list) + + ;; for the current location + (notes nil :type list) + + ;; currently active source variables + (current-valid-locations nil :type (or null (vector bit)))) +(def!method print-object ((dstate disassem-state) stream) + (print-unreadable-object (dstate stream :type t) + (format stream + "+~W~@[ in ~S~]" + (dstate-cur-offs dstate) + (dstate-segment dstate)))) + +;;; Return the absolute address of the current instruction in DSTATE. +(defun dstate-cur-addr (dstate) + (the address (+ (seg-virtual-location (dstate-segment dstate)) + (dstate-cur-offs dstate)))) + +;;; Return the absolute address of the next instruction in DSTATE. +(defun dstate-next-addr (dstate) + (the address (+ (seg-virtual-location (dstate-segment dstate)) + (dstate-next-offs dstate)))) ;;; Get the value of the property called NAME in DSTATE. Also SETF'able. ;;; diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 1d1ac48..6ef6c4a 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -1678,8 +1678,8 @@ (descriptor-gspace code-object)))) (ecase +backend-fasl-file-implementation+ ;; See CMU CL source for other formerly-supported architectures - ;; (and note that you have to rewrite them to use VECTOR-REF - ;; unstead of SAP-REF). + ;; (and note that you have to rewrite them to use BVREF-X + ;; instead of SAP-REF). (:alpha (ecase kind (:jmp-hint @@ -1710,6 +1710,36 @@ (ldb (byte 8 0) value) (bvref-8 gspace-bytes (1+ gspace-byte-offset)) (ldb (byte 8 8) value))))) + (:hppa + (ecase kind + (:load + (setf (bvref-32 gspace-bytes gspace-byte-offset) + (logior (ash (ldb (byte 11 0) value) 1) + (logand (bvref-32 gspace-bytes gspace-byte-offset) + #xffffc000)))) + (:load-short + (let ((low-bits (ldb (byte 11 0) value))) + (assert (<= 0 low-bits (1- (ash 1 4)))) + (setf (bvref-32 gspace-bytes gspace-byte-offset) + (logior (ash low-bits 17) + (logand (bvref-32 gspace-bytes gspace-byte-offset) + #xffe0ffff))))) + (:hi + (setf (bvref-32 gspace-bytes gspace-byte-offset) + (logior (ash (ldb (byte 5 13) value) 16) + (ash (ldb (byte 2 18) value) 14) + (ash (ldb (byte 2 11) value) 12) + (ash (ldb (byte 11 20) value) 1) + (ldb (byte 1 31) value) + (logand (bvref-32 gspace-bytes gspace-byte-offset) + #xffe00000)))) + (:branch + (let ((bits (ldb (byte 9 2) value))) + (assert (zerop (ldb (byte 2 0) value))) + (setf (bvref-32 gspace-bytes gspace-byte-offset) + (logior (ash bits 3) + (logand (bvref-32 gspace-bytes gspace-byte-offset) + #xffe0e002))))))) (:ppc (ecase kind (:ba diff --git a/src/compiler/hppa/alloc.lisp b/src/compiler/hppa/alloc.lisp new file mode 100644 index 0000000..5891372 --- /dev/null +++ b/src/compiler/hppa/alloc.lisp @@ -0,0 +1,170 @@ +(in-package "SB!VM") + + +;;;; LIST and LIST* + +(define-vop (list-or-list*) + (:args (things :more t)) + (:temporary (:scs (descriptor-reg) :type list) ptr) + (:temporary (:scs (descriptor-reg)) temp) + (:temporary (:scs (descriptor-reg) :type list :to (:result 0) :target result) + res) + (:info num) + (:results (result :scs (descriptor-reg))) + (:variant-vars star) + (:policy :safe) + (:generator 0 + (cond + ((zerop num) + (move null-tn result)) + ((and star (= num 1)) + (move (tn-ref-tn things) result)) + (t + (macrolet + ((maybe-load (tn) + (once-only ((tn tn)) + `(sc-case ,tn + ((any-reg descriptor-reg zero null) + ,tn) + (control-stack + (load-stack-tn temp ,tn) + temp))))) + (let* ((cons-cells (if star (1- num) num)) + (alloc (* (pad-data-block cons-size) cons-cells))) + (pseudo-atomic (:extra alloc) + (move alloc-tn res) + (inst dep list-pointer-lowtag 31 3 res) + (move res ptr) + (dotimes (i (1- cons-cells)) + (storew (maybe-load (tn-ref-tn things)) ptr + cons-car-slot list-pointer-lowtag) + (setf things (tn-ref-across things)) + (inst addi (pad-data-block cons-size) ptr ptr) + (storew ptr ptr + (- cons-cdr-slot cons-size) + list-pointer-lowtag)) + (storew (maybe-load (tn-ref-tn things)) ptr + cons-car-slot list-pointer-lowtag) + (storew (if star + (maybe-load (tn-ref-tn (tn-ref-across things))) + null-tn) + ptr cons-cdr-slot list-pointer-lowtag)) + (move res result))))))) + + +(define-vop (list list-or-list*) + (:variant nil)) + +(define-vop (list* list-or-list*) + (:variant t)) + + +;;;; Special purpose inline allocators. + +(define-vop (allocate-code-object) + (:args (boxed-arg :scs (any-reg)) + (unboxed-arg :scs (any-reg))) + (:results (result :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:temporary (:scs (any-reg) :from (:argument 0)) boxed) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed) + (:generator 100 + (inst addi (fixnumize (1+ code-trace-table-offset-slot)) boxed-arg boxed) + (inst dep 0 31 3 boxed) + (inst srl unboxed-arg word-shift unboxed) + (inst addi lowtag-mask unboxed unboxed) + (inst dep 0 31 3 unboxed) + (pseudo-atomic () + ;; Note: we don't have to subtract off the 4 that was added by + ;; pseudo-atomic, because depositing other-pointer-lowtag just adds + ;; it right back. + (inst move alloc-tn result) + (inst dep other-pointer-lowtag 31 3 result) + (inst add alloc-tn boxed alloc-tn) + (inst add alloc-tn unboxed alloc-tn) + (inst sll boxed (- n-widetag-bits word-shift) ndescr) + (inst addi code-header-widetag ndescr ndescr) + (storew ndescr result 0 other-pointer-lowtag) + (storew unboxed result code-code-size-slot other-pointer-lowtag) + (storew null-tn result code-entry-points-slot other-pointer-lowtag) + (storew null-tn result code-debug-info-slot other-pointer-lowtag)))) + +(define-vop (make-fdefn) + (:args (name :scs (descriptor-reg) :to :eval)) + (:temporary (:scs (non-descriptor-reg)) temp) + (:results (result :scs (descriptor-reg) :from :argument)) + (:policy :fast-safe) + (:translate make-fdefn) + (:generator 37 + (with-fixed-allocation (result temp fdefn-widetag fdefn-size) + (inst li (make-fixup "undefined_tramp" :foreign) temp) + (storew name result fdefn-name-slot other-pointer-lowtag) + (storew null-tn result fdefn-fun-slot other-pointer-lowtag) + (storew temp result fdefn-raw-addr-slot other-pointer-lowtag)))) + +(define-vop (make-closure) + (:args (function :to :save :scs (descriptor-reg))) + (:info length) + (:temporary (:scs (non-descriptor-reg)) temp) + (:results (result :scs (descriptor-reg))) + (:generator 10 + (let ((size (+ length closure-info-offset))) + (pseudo-atomic (:extra (pad-data-block size)) + (inst move alloc-tn result) + (inst dep fun-pointer-lowtag 31 3 result) + (inst li (logior (ash (1- size) n-widetag-bits) closure-header-widetag) temp) + (storew temp result 0 fun-pointer-lowtag))) + (storew function result closure-fun-slot fun-pointer-lowtag))) + +;;; The compiler likes to be able to directly make value cells. +;;; +(define-vop (make-value-cell) + (:args (value :to :save :scs (descriptor-reg any-reg))) + (:temporary (:scs (non-descriptor-reg)) temp) + (:results (result :scs (descriptor-reg))) + (:generator 10 + (with-fixed-allocation + (result temp value-cell-header-widetag value-cell-size)) + (storew value result value-cell-value-slot other-pointer-lowtag))) + + + +;;;; Automatic allocators for primitive objects. + +(define-vop (make-unbound-marker) + (:args) + (:results (result :scs (any-reg))) + (:generator 1 + (inst li unbound-marker-widetag result))) + +(define-vop (fixed-alloc) + (:args) + (:info name words type lowtag) + (:ignore name) + (:results (result :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 4 + (pseudo-atomic (:extra (pad-data-block words)) + (inst move alloc-tn result) + (inst dep lowtag 31 3 result) + (when type + (inst li (logior (ash (1- words) n-widetag-bits) type) temp) + (storew temp result 0 lowtag))))) + +(define-vop (var-alloc) + (:args (extra :scs (any-reg))) + (:arg-types positive-fixnum) + (:info name words type lowtag) + (:ignore name) + (:results (result :scs (descriptor-reg))) + (:temporary (:scs (any-reg)) bytes header) + (:generator 6 + (inst addi (* (1+ words) n-word-bytes) extra bytes) + (inst sll bytes (- n-widetag-bits 2) header) + (inst addi (+ (ash -2 n-widetag-bits) type) header header) + (inst dep 0 31 3 bytes) + (pseudo-atomic () + (inst move alloc-tn result) + (inst dep lowtag 31 3 result) + (storew header result 0 lowtag) + (inst add alloc-tn bytes alloc-tn)))) diff --git a/src/compiler/hppa/arith.lisp b/src/compiler/hppa/arith.lisp new file mode 100644 index 0000000..1cc39d6 --- /dev/null +++ b/src/compiler/hppa/arith.lisp @@ -0,0 +1,878 @@ +(in-package "SB!VM") + + + +;;;; Unary operations. + +(define-vop (fixnum-unop) + (:args (x :scs (any-reg))) + (:results (res :scs (any-reg))) + (:note "inline fixnum arithmetic") + (:arg-types tagged-num) + (:result-types tagged-num) + (:policy :fast-safe)) + +(define-vop (signed-unop) + (:args (x :scs (signed-reg))) + (:results (res :scs (signed-reg))) + (:note "inline (signed-byte 32) arithmetic") + (:arg-types signed-num) + (:result-types signed-num) + (:policy :fast-safe)) + +(define-vop (fast-negate/fixnum fixnum-unop) + (:translate %negate) + (:generator 1 + (inst sub zero-tn x res))) + +(define-vop (fast-negate/signed signed-unop) + (:translate %negate) + (:generator 2 + (inst sub zero-tn x res))) + +(define-vop (fast-lognot/fixnum fixnum-unop) + (:temporary (:scs (any-reg) :type fixnum :to (:result 0)) + temp) + (:translate lognot) + (:generator 2 + (inst li (fixnumize -1) temp) + (inst xor x temp res))) + +(define-vop (fast-lognot/signed signed-unop) + (:translate lognot) + (:generator 1 + (inst uaddcm zero-tn x res))) + + + +;;;; Binary fixnum operations. + +;;; Assume that any constant operand is the second arg... + +(define-vop (fast-fixnum-binop) + (:args (x :target r :scs (any-reg)) + (y :target r :scs (any-reg))) + (:arg-types tagged-num tagged-num) + (:results (r :scs (any-reg))) + (:result-types tagged-num) + (:note "inline fixnum arithmetic") + (:effects) + (:affected) + (:policy :fast-safe)) + +(define-vop (fast-unsigned-binop) + (:args (x :target r :scs (unsigned-reg)) + (y :target r :scs (unsigned-reg))) + (:arg-types unsigned-num unsigned-num) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num) + (:note "inline (unsigned-byte 32) arithmetic") + (:effects) + (:affected) + (:policy :fast-safe)) + +(define-vop (fast-signed-binop) + (:args (x :target r :scs (signed-reg)) + (y :target r :scs (signed-reg))) + (:arg-types signed-num signed-num) + (:results (r :scs (signed-reg))) + (:result-types signed-num) + (:note "inline (signed-byte 32) arithmetic") + (:effects) + (:affected) + (:policy :fast-safe)) + +(defmacro define-binop (translate cost untagged-cost op) + `(progn + (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM") + fast-fixnum-binop) + (:args (x :target r :scs (any-reg)) + (y :target r :scs (any-reg))) + (:translate ,translate) + (:generator ,cost + (inst ,op x y r))) + (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED") + fast-signed-binop) + (:args (x :target r :scs (signed-reg)) + (y :target r :scs (signed-reg))) + (:translate ,translate) + (:generator ,untagged-cost + (inst ,op x y r))) + (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED") + fast-unsigned-binop) + (:args (x :target r :scs (unsigned-reg)) + (y :target r :scs (unsigned-reg))) + (:translate ,translate) + (:generator ,untagged-cost + (inst ,op x y r))))) + +(define-binop + 2 6 add) +(define-binop - 2 6 sub) +(define-binop logior 1 2 or) +(define-binop logand 1 2 and) +(define-binop logandc2 1 2 andcm) +(define-binop logxor 1 2 xor) + +(define-vop (fast-fixnum-c-binop fast-fixnum-binop) + (:args (x :target r :scs (any-reg))) + (:info y) + (:arg-types tagged-num (:constant integer))) + +(define-vop (fast-signed-c-binop fast-signed-binop) + (:args (x :target r :scs (signed-reg))) + (:info y) + (:arg-types tagged-num (:constant integer))) + +(define-vop (fast-unsigned-c-binop fast-unsigned-binop) + (:args (x :target r :scs (unsigned-reg))) + (:info y) + (:arg-types tagged-num (:constant integer))) + +(defmacro define-c-binop (translate cost untagged-cost tagged-type + untagged-type inst) + `(progn + (define-vop (,(symbolicate "FAST-" translate "-C/FIXNUM=>FIXNUM") + fast-fixnum-c-binop) + (:arg-types tagged-num (:constant ,tagged-type)) + (:translate ,translate) + (:generator ,cost + (let ((y (fixnumize y))) + ,inst))) + (define-vop (,(symbolicate "FAST-" translate "-C/SIGNED=>SIGNED") + fast-signed-c-binop) + (:arg-types signed-num (:constant ,untagged-type)) + (:translate ,translate) + (:generator ,untagged-cost + ,inst)) + (define-vop (,(symbolicate "FAST-" translate "-C/UNSIGNED=>UNSIGNED") + fast-unsigned-c-binop) + (:arg-types unsigned-num (:constant ,untagged-type)) + (:translate ,translate) + (:generator ,untagged-cost + ,inst)))) + +(define-c-binop + 1 3 (signed-byte 9) (signed-byte 11) + (inst addi y x r)) +(define-c-binop - 1 3 + (integer #.(- (1- (ash 1 9))) #.(ash 1 9)) + (integer #.(- (1- (ash 1 11))) #.(ash 1 11)) + (inst addi (- y) x r)) + +;;; Special case fixnum + and - that trap on overflow. Useful when we don't +;;; know that the result is going to be a fixnum. + +(define-vop (fast-+/fixnum fast-+/fixnum=>fixnum) + (:results (r :scs (any-reg descriptor-reg))) + (:result-types (:or signed-num unsigned-num)) + (:note nil) + (:generator 4 + (inst addo x y r))) + +(define-vop (fast-+-c/fixnum fast-+-c/fixnum=>fixnum) + (:results (r :scs (any-reg descriptor-reg))) + (:result-types (:or signed-num unsigned-num)) + (:note nil) + (:generator 3 + (inst addio (fixnumize y) x r))) + +(define-vop (fast--/fixnum fast--/fixnum=>fixnum) + (:results (r :scs (any-reg descriptor-reg))) + (:result-types (:or signed-num unsigned-num)) + (:note nil) + (:generator 4 + (inst subo x y r))) + +(define-vop (fast---c/fixnum fast---c/fixnum=>fixnum) + (:results (r :scs (any-reg descriptor-reg))) + (:result-types (:or signed-num unsigned-num)) + (:note nil) + (:generator 3 + (inst addio (- (fixnumize y)) x r))) + +;;; Shifting + +(define-vop (fast-ash/unsigned=>unsigned) + (:policy :fast-safe) + (:translate ash) + (:note "inline word ASH") + (:args (number :scs (unsigned-reg)) + (count :scs (signed-reg))) + (:arg-types unsigned-num tagged-num) + (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 8 + (inst comb :>= count zero-tn positive :nullify t) + (inst sub zero-tn count temp) + (inst comiclr 31 temp zero-tn :>=) + (inst li 31 temp) + (inst mtctl temp :sar) + (inst extrs number 0 1 temp) + (inst b done) + (inst shd temp number :variable result) + POSITIVE + (inst subi 31 count temp) + (inst mtctl temp :sar) + (inst zdep number :variable 32 result) + DONE)) + +(define-vop (fast-ash/signed=>signed) + (:policy :fast-safe) + (:translate ash) + (:note "inline word ASH") + (:args (number :scs (signed-reg)) + (count :scs (signed-reg))) + (:arg-types signed-num tagged-num) + (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) + (:results (result :scs (signed-reg))) + (:result-types signed-num) + (:generator 8 + (inst comb :>= count zero-tn positive :nullify t) + (inst sub zero-tn count temp) + (inst comiclr 31 temp zero-tn :>=) + (inst li 31 temp) + (inst mtctl temp :sar) + (inst extrs number 0 1 temp) + (inst b done) + (inst shd temp number :variable result) + POSITIVE + (inst subi 31 count temp) + (inst mtctl temp :sar) + (inst zdep number :variable 32 result) + DONE)) + +(define-vop (fast-ash-c/unsigned=>unsigned) + (:policy :fast-safe) + (:translate ash) + (:note nil) + (:args (number :scs (unsigned-reg))) + (:info count) + (:arg-types unsigned-num (:constant integer)) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 1 + (cond ((< count 0) + ;; It is a right shift. + (inst srl number (min (- count) 31) result)) + ((> count 0) + ;; It is a left shift. + (inst sll number (min count 31) result)) + (t + ;; Count=0? Shouldn't happen, but it's easy: + (move number result))))) + +(define-vop (fast-ash-c/signed=>signed) + (:policy :fast-safe) + (:translate ash) + (:note nil) + (:args (number :scs (signed-reg))) + (:info count) + (:arg-types signed-num (:constant integer)) + (:results (result :scs (signed-reg))) + (:result-types signed-num) + (:generator 1 + (cond ((< count 0) + ;; It is a right shift. + (inst sra number (min (- count) 31) result)) + ((> count 0) + ;; It is a left shift. + (inst sll number (min count 31) result)) + (t + ;; Count=0? Shouldn't happen, but it's easy: + (move number result))))) + + +(define-vop (signed-byte-32-len) + (:translate integer-length) + (:note "inline (signed-byte 32) integer-length") + (:policy :fast-safe) + (:args (arg :scs (signed-reg) :target shift)) + (:arg-types signed-num) + (:results (res :scs (any-reg))) + (:result-types positive-fixnum) + (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift) + (:generator 30 + (inst move arg shift :>=) + (inst uaddcm zero-tn shift shift) + (inst comb := shift zero-tn done) + (inst li 0 res) + LOOP + (inst srl shift 1 shift) + (inst comb :<> shift zero-tn loop) + (inst addi (fixnumize 1) res res) + DONE)) + +(define-vop (unsigned-byte-32-count) + (:translate logcount) + (:note "inline (unsigned-byte 32) logcount") + (:policy :fast-safe) + (:args (arg :scs (unsigned-reg) :target num)) + (:arg-types unsigned-num) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:temporary (:scs (non-descriptor-reg) :from (:argument 0) :to (:result 0) + :target res) num) + (:temporary (:scs (non-descriptor-reg)) mask temp) + (:generator 30 + (inst li #x55555555 mask) + (inst srl arg 1 temp) + (inst and arg mask num) + (inst and temp mask temp) + (inst add num temp num) + (inst li #x33333333 mask) + (inst srl num 2 temp) + (inst and num mask num) + (inst and temp mask temp) + (inst add num temp num) + (inst li #x0f0f0f0f mask) + (inst srl num 4 temp) + (inst and num mask num) + (inst and temp mask temp) + (inst add num temp num) + (inst li #x00ff00ff mask) + (inst srl num 8 temp) + (inst and num mask num) + (inst and temp mask temp) + (inst add num temp num) + (inst li #x0000ffff mask) + (inst srl num 16 temp) + (inst and num mask num) + (inst and temp mask temp) + (inst add num temp res))) + +;;; Multiply and Divide. + +(define-vop (fast-*/fixnum=>fixnum fast-fixnum-binop) + (:args (x :scs (any-reg) :target x-pass) + (y :scs (any-reg) :target y-pass)) + (:temporary (:sc signed-reg :offset nl0-offset + :from (:argument 0) :to (:result 0)) x-pass) + (:temporary (:sc signed-reg :offset nl1-offset + :from (:argument 1) :to (:result 0)) y-pass) + (:temporary (:sc signed-reg :offset nl2-offset :target r + :from (:argument 1) :to (:result 0)) res-pass) + (:temporary (:sc signed-reg :offset nl3-offset :to (:result 0)) tmp) + (:temporary (:sc signed-reg :offset nl4-offset + :from (:argument 1) :to (:result 0)) sign) + (:temporary (:sc interior-reg :offset lip-offset) lip) + (:ignore lip sign) + (:translate *) + (:generator 30 + (unless (location= y y-pass) + (inst sra x 2 x-pass)) + (let ((fixup (make-fixup 'multiply :assembly-routine))) + (inst ldil fixup tmp) + (inst ble fixup lisp-heap-space tmp)) + (if (location= y y-pass) + (inst sra x 2 x-pass) + (inst move y y-pass)) + (move res-pass r))) + +(define-vop (fast-*/signed=>signed fast-signed-binop) + (:translate *) + (:args (x :scs (signed-reg) :target x-pass) + (y :scs (signed-reg) :target y-pass)) + (:temporary (:sc signed-reg :offset nl0-offset + :from (:argument 0) :to (:result 0)) x-pass) + (:temporary (:sc signed-reg :offset nl1-offset + :from (:argument 1) :to (:result 0)) y-pass) + (:temporary (:sc signed-reg :offset nl2-offset :target r + :from (:argument 1) :to (:result 0)) res-pass) + (:temporary (:sc signed-reg :offset nl3-offset :to (:result 0)) tmp) + (:temporary (:sc signed-reg :offset nl4-offset + :from (:argument 1) :to (:result 0)) sign) + (:temporary (:sc interior-reg :offset lip-offset) lip) + (:ignore lip sign) + (:translate *) + (:generator 31 + (let ((fixup (make-fixup 'multiply :assembly-routine))) + (move x x-pass) + (move y y-pass) + (inst ldil fixup tmp) + (inst ble fixup lisp-heap-space tmp :nullify t) + (inst nop) + (move res-pass r)))) + +(define-vop (fast-truncate/fixnum fast-fixnum-binop) + (:translate truncate) + (:args (x :scs (any-reg) :target x-pass) + (y :scs (any-reg) :target y-pass)) + (:temporary (:sc signed-reg :offset nl0-offset + :from (:argument 0) :to (:result 0)) x-pass) + (:temporary (:sc signed-reg :offset nl1-offset + :from (:argument 1) :to (:result 0)) y-pass) + (:temporary (:sc signed-reg :offset nl2-offset :target q + :from (:argument 1) :to (:result 0)) q-pass) + (:temporary (:sc signed-reg :offset nl3-offset :target r + :from (:argument 1) :to (:result 1)) r-pass) + (:results (q :scs (signed-reg)) + (r :scs (any-reg))) + (:result-types tagged-num tagged-num) + (:vop-var vop) + (:save-p :compute-only) + (:generator 30 + (let ((zero (generate-error-code vop division-by-zero-error x y))) + (inst bc := nil y zero-tn zero)) + (move x x-pass) + (move y y-pass) + (let ((fixup (make-fixup 'truncate :assembly-routine))) + (inst ldil fixup q-pass) + (inst ble fixup lisp-heap-space q-pass :nullify t)) + (inst nop) + (move q-pass q) + (move r-pass r))) + +(define-vop (fast-truncate/signed fast-signed-binop) + (:translate truncate) + (:args (x :scs (signed-reg) :target x-pass) + (y :scs (signed-reg) :target y-pass)) + (:temporary (:sc signed-reg :offset nl0-offset + :from (:argument 0) :to (:result 0)) x-pass) + (:temporary (:sc signed-reg :offset nl1-offset + :from (:argument 1) :to (:result 0)) y-pass) + (:temporary (:sc signed-reg :offset nl2-offset :target q + :from (:argument 1) :to (:result 0)) q-pass) + (:temporary (:sc signed-reg :offset nl3-offset :target r + :from (:argument 1) :to (:result 1)) r-pass) + (:results (q :scs (signed-reg)) + (r :scs (signed-reg))) + (:result-types signed-num signed-num) + (:vop-var vop) + (:save-p :compute-only) + (:generator 35 + (let ((zero (generate-error-code vop division-by-zero-error x y))) + (inst bc := nil y zero-tn zero)) + (move x x-pass) + (move y y-pass) + (let ((fixup (make-fixup 'truncate :assembly-routine))) + (inst ldil fixup q-pass) + (inst ble fixup lisp-heap-space q-pass :nullify t)) + (inst nop) + (move q-pass q) + (move r-pass r))) + + +;;;; Binary conditional VOPs: + +(define-vop (fast-conditional) + (:conditional) + (:info target not-p) + (:effects) + (:affected) + (:policy :fast-safe)) + +(define-vop (fast-conditional/fixnum fast-conditional) + (:args (x :scs (any-reg)) + (y :scs (any-reg))) + (:arg-types tagged-num tagged-num) + (:note "inline fixnum comparison")) + +(define-vop (fast-conditional-c/fixnum fast-conditional/fixnum) + (:args (x :scs (any-reg))) + (:arg-types tagged-num (:constant (signed-byte 9))) + (:info target not-p y)) + +(define-vop (fast-conditional/signed fast-conditional) + (:args (x :scs (signed-reg)) + (y :scs (signed-reg))) + (:arg-types signed-num signed-num) + (:note "inline (signed-byte 32) comparison")) + +(define-vop (fast-conditional-c/signed fast-conditional/signed) + (:args (x :scs (signed-reg))) + (:arg-types signed-num (:constant (signed-byte 11))) + (:info target not-p y)) + +(define-vop (fast-conditional/unsigned fast-conditional) + (:args (x :scs (unsigned-reg)) + (y :scs (unsigned-reg))) + (:arg-types unsigned-num unsigned-num) + (:note "inline (unsigned-byte 32) comparison")) + +(define-vop (fast-conditional-c/unsigned fast-conditional/unsigned) + (:args (x :scs (unsigned-reg))) + (:arg-types unsigned-num (:constant (signed-byte 11))) + (:info target not-p y)) + + +(defmacro define-conditional-vop (translate signed-cond unsigned-cond) + `(progn + ,@(mapcar #'(lambda (suffix cost signed imm) + (unless (and (member suffix '(/fixnum -c/fixnum)) + (eq translate 'eql)) + `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)" + translate suffix)) + ,(intern + (format nil "~:@(FAST-CONDITIONAL~A~)" + suffix))) + (:translate ,translate) + (:generator ,cost + (inst ,(if imm 'bci 'bc) + ,(if signed signed-cond unsigned-cond) + not-p + ,(if (eq suffix '-c/fixnum) + '(fixnumize y) + 'y) + x + target))))) + '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned) + '(3 2 5 4 5 4) + '(t t t t nil nil) + '(nil t nil t nil t)))) + +;; We switch < and > because the immediate has to come first. + +(define-conditional-vop < :> :>>) +(define-conditional-vop > :< :<<) + +;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a +;;; known fixnum. +;;; +(define-conditional-vop eql := :=) + +;;; These versions specify a fixnum restriction on their first arg. We have +;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on +;;; the first arg and a higher cost. The reason for doing this is to prevent +;;; fixnum specific operations from being used on word integers, spuriously +;;; consing the argument. +;;; +(define-vop (fast-eql/fixnum fast-conditional) + (:args (x :scs (any-reg descriptor-reg)) + (y :scs (any-reg))) + (:arg-types tagged-num tagged-num) + (:note "inline fixnum comparison") + (:translate eql) + (:generator 3 + (inst bc := not-p x y target))) +;;; +(define-vop (generic-eql/fixnum fast-eql/fixnum) + (:arg-types * tagged-num) + (:variant-cost 7)) + +(define-vop (fast-eql-c/fixnum fast-conditional/fixnum) + (:args (x :scs (any-reg descriptor-reg))) + (:arg-types tagged-num (:constant (signed-byte 9))) + (:info target not-p y) + (:translate eql) + (:generator 2 + (inst bci := not-p (fixnumize y) x target))) +;;; +(define-vop (generic-eql-c/fixnum fast-eql-c/fixnum) + (:arg-types * (:constant (signed-byte 9))) + (:variant-cost 6)) + + +;;;; 32-bit logical operations + +(define-vop (32bit-logical) + (:args (x :scs (unsigned-reg)) + (y :scs (unsigned-reg))) + (:arg-types unsigned-num unsigned-num) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num) + (:policy :fast-safe)) + +(define-vop (32bit-logical-not 32bit-logical) + (:translate 32bit-logical-not) + (:args (x :scs (unsigned-reg))) + (:arg-types unsigned-num) + (:generator 1 + (inst uaddcm zero-tn x r))) + +(define-vop (32bit-logical-and 32bit-logical) + (:translate 32bit-logical-and) + (:generator 1 + (inst and x y r))) + +(deftransform 32bit-logical-nand ((x y) (* *)) + '(32bit-logical-not (32bit-logical-and x y))) + +(define-vop (32bit-logical-or 32bit-logical) + (:translate 32bit-logical-or) + (:generator 1 + (inst or x y r))) + +(deftransform 32bit-logical-nor ((x y) (* *)) + '(32bit-logical-not (32bit-logical-or x y))) + +(define-vop (32bit-logical-xor 32bit-logical) + (:translate 32bit-logical-xor) + (:generator 1 + (inst xor x y r))) + +(deftransform 32bit-logical-eqv ((x y) (* *)) + '(32bit-logical-not (32bit-logical-xor x y))) + +(deftransform 32bit-logical-andc1 ((x y) (* *)) + '(32bit-logical-and (32bit-logical-not x) y)) + +(define-vop (32bit-logical-andc2 32bit-logical) + (:translate 32bit-logical-andc2) + (:generator 1 + (inst andcm x y r))) + +(deftransform 32bit-logical-orc1 ((x y) (* *)) + '(32bit-logical-or (32bit-logical-not x) y)) + +(deftransform 32bit-logical-orc2 ((x y) (* *)) + '(32bit-logical-or x (32bit-logical-not y))) + + +(define-vop (shift-towards-someplace) + (:policy :fast-safe) + (:args (num :scs (unsigned-reg)) + (amount :scs (signed-reg))) + (:arg-types unsigned-num tagged-num) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num)) + +(define-vop (shift-towards-start shift-towards-someplace) + (:translate shift-towards-start) + (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) + (:note "SHIFT-TOWARDS-START") + (:generator 1 + (inst subi 31 amount temp) + (inst mtctl temp :sar) + (inst zdep num :variable 32 r))) + +(define-vop (shift-towards-end shift-towards-someplace) + (:translate shift-towards-end) + (:note "SHIFT-TOWARDS-END") + (:generator 1 + (inst mtctl amount :sar) + (inst shd zero-tn num :variable r))) + + + +;;;; Bignum stuff. + +(define-vop (bignum-length get-header-data) + (:translate sb!bignum::%bignum-length) + (:policy :fast-safe)) + +(define-vop (bignum-set-length set-header-data) + (:translate sb!bignum::%bignum-set-length) + (:policy :fast-safe)) + +(define-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag + (unsigned-reg) unsigned-num sb!bignum::%bignum-ref) + +(define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag + (unsigned-reg) unsigned-num sb!bignum::%bignum-set) + +(define-vop (digit-0-or-plus) + (:translate sb!bignum::%digit-0-or-plusp) + (:policy :fast-safe) + (:args (digit :scs (unsigned-reg))) + (:arg-types unsigned-num) + (:conditional) + (:info target not-p) + (:effects) + (:affected) + (:generator 1 + (inst bc :>= not-p digit zero-tn target))) + +(define-vop (add-w/carry) + (:translate sb!bignum::%add-with-carry) + (:policy :fast-safe) + (:args (a :scs (unsigned-reg)) + (b :scs (unsigned-reg)) + (c :scs (unsigned-reg))) + (:arg-types unsigned-num unsigned-num positive-fixnum) + (:results (result :scs (unsigned-reg)) + (carry :scs (unsigned-reg))) + (:result-types unsigned-num positive-fixnum) + (:generator 3 + (inst addi -1 c zero-tn) + (inst addc a b result) + (inst addc zero-tn zero-tn carry))) + +(define-vop (sub-w/borrow) + (:translate sb!bignum::%subtract-with-borrow) + (:policy :fast-safe) + (:args (a :scs (unsigned-reg)) + (b :scs (unsigned-reg)) + (c :scs (unsigned-reg))) + (:arg-types unsigned-num unsigned-num positive-fixnum) + (:results (result :scs (unsigned-reg)) + (borrow :scs (unsigned-reg))) + (:result-types unsigned-num positive-fixnum) + (:generator 4 + (inst addi -1 c zero-tn) + (inst subb a b result) + (inst addc zero-tn zero-tn borrow))) + +(define-vop (bignum-mult) + (:translate sb!bignum::%multiply) + (:policy :fast-safe) + (:args (x-arg :scs (unsigned-reg) :target x) + (y-arg :scs (unsigned-reg) :target y)) + (:arg-types unsigned-num unsigned-num) + (:temporary (:scs (signed-reg) :from (:argument 0)) x) + (:temporary (:scs (signed-reg) :from (:argument 1)) y) + (:temporary (:scs (signed-reg)) tmp) + (:results (hi :scs (unsigned-reg)) + (lo :scs (unsigned-reg))) + (:result-types unsigned-num unsigned-num) + (:generator 3 + ;; Make sure X is less then Y. + (inst comclr x-arg y-arg tmp :<<) + (inst xor x-arg y-arg tmp) + (inst xor x-arg tmp x) + (inst xor y-arg tmp y) + + ;; Blow out of here if the result is zero. + (inst li 0 hi) + (inst comb := x zero-tn done) + (inst li 0 lo) + (inst li 0 tmp) + + LOOP + (inst comb :ev x zero-tn next-bit) + (inst srl x 1 x) + (inst add lo y lo) + (inst addc hi tmp hi) + NEXT-BIT + (inst add y y y) + (inst comb :<> x zero-tn loop) + (inst addc tmp tmp tmp) + + DONE)) + +(define-source-transform sb!bignum:%multiply-and-add (x y carry &optional (extra 0)) + #+nil ;; This would be greate if it worked, but it doesn't. + (if (eql extra 0) + `(multiple-value-call #'sb!bignum::%dual-word-add + (sb!bignum:%multiply ,x ,y) + (values ,carry)) + `(multiple-value-call #'sb!bignum::%dual-word-add + (multiple-value-call #'sb!bignum::%dual-word-add + (sb!bignum:%multiply ,x ,y) + (values ,carry)) + (values ,extra))) + (let ((hi (gensym "HI-")) + (lo (gensym "LO-"))) + (if (eql extra 0) + `(multiple-value-bind (,hi ,lo) (sb!bignum:%multiply ,x ,y) + (sb!bignum::%dual-word-add ,hi ,lo ,carry)) + `(multiple-value-bind (,hi ,lo) (sb!bignum:%multiply ,x ,y) + (multiple-value-bind + (,hi ,lo) + (sb!bignum::%dual-word-add ,hi ,lo ,carry) + (sb!bignum::%dual-word-add ,hi ,lo ,extra)))))) + +(defknown sb!bignum::%dual-word-add + (sb!bignum:bignum-element-type sb!bignum:bignum-element-type sb!bignum:bignum-element-type) + (values sb!bignum:bignum-element-type sb!bignum:bignum-element-type) + (flushable movable)) + +(define-vop (dual-word-add) + (:policy :fast-safe) + (:translate sb!bignum::%dual-word-add) + (:args (hi :scs (unsigned-reg) :to (:result 1)) + (lo :scs (unsigned-reg)) + (extra :scs (unsigned-reg))) + (:arg-types unsigned-num unsigned-num unsigned-num) + (:results (hi-res :scs (unsigned-reg) :from (:result 1)) + (lo-res :scs (unsigned-reg) :from (:result 0))) + (:result-types unsigned-num unsigned-num) + (:affected) + (:effects) + (:generator 3 + (inst add lo extra lo-res) + (inst addc hi zero-tn hi-res))) + +(define-vop (bignum-lognot) + (:translate sb!bignum::%lognot) + (:policy :fast-safe) + (:args (x :scs (unsigned-reg))) + (:arg-types unsigned-num) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 1 + (inst uaddcm zero-tn x r))) + +(define-vop (fixnum-to-digit) + (:translate sb!bignum::%fixnum-to-digit) + (:policy :fast-safe) + (:args (fixnum :scs (signed-reg))) + (:arg-types tagged-num) + (:results (digit :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 1 + (move fixnum digit))) + +(define-vop (bignum-floor) + (:translate sb!bignum::%floor) + (:policy :fast-safe) + (:args (hi :scs (unsigned-reg) :to (:argument 1)) + (lo :scs (unsigned-reg) :to (:argument 0)) + (divisor :scs (unsigned-reg))) + (:arg-types unsigned-num unsigned-num unsigned-num) + (:temporary (:scs (unsigned-reg) :to (:argument 1)) temp) + (:results (quo :scs (unsigned-reg) :from (:argument 0)) + (rem :scs (unsigned-reg) :from (:argument 1))) + (:result-types unsigned-num unsigned-num) + (:generator 65 + (inst sub zero-tn divisor temp) + (inst ds zero-tn temp zero-tn) + (inst add lo lo quo) + (inst ds hi divisor rem) + (inst addc quo quo quo) + (dotimes (i 31) + (inst ds rem divisor rem) + (inst addc quo quo quo)) + (inst comclr rem zero-tn zero-tn :>=) + (inst add divisor rem rem))) + +(define-vop (signify-digit) + (:translate sb!bignum::%fixnum-digit-with-correct-sign) + (:policy :fast-safe) + (:args (digit :scs (unsigned-reg) :target res)) + (:arg-types unsigned-num) + (:results (res :scs (signed-reg))) + (:result-types signed-num) + (:generator 1 + (move digit res))) + +(define-vop (digit-lshr) + (:translate sb!bignum::%digit-logical-shift-right) + (:policy :fast-safe) + (:args (digit :scs (unsigned-reg)) + (count :scs (unsigned-reg))) + (:arg-types unsigned-num positive-fixnum) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 2 + (inst mtctl count :sar) + (inst shd zero-tn digit :variable result))) + +(define-vop (digit-ashr digit-lshr) + (:translate sb!bignum::%ashr) + (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) + (:generator 1 + (inst extrs digit 0 1 temp) + (inst mtctl count :sar) + (inst shd temp digit :variable result))) + +(define-vop (digit-ashl digit-ashr) + (:translate sb!bignum::%ashl) + (:generator 1 + (inst subi 31 count temp) + (inst mtctl temp :sar) + (inst zdep digit :variable 32 result))) + + +;;;; Static functions. + +(define-static-fun two-arg-gcd (x y) :translate gcd) +(define-static-fun two-arg-lcm (x y) :translate lcm) + +(define-static-fun two-arg-* (x y) :translate *) +(define-static-fun two-arg-/ (x y) :translate /) + +(define-static-fun %negate (x) :translate %negate) + +(define-static-fun two-arg-and (x y) :translate logand) +(define-static-fun two-arg-ior (x y) :translate logior) +(define-static-fun two-arg-xor (x y) :translate logxor) diff --git a/src/compiler/hppa/array.lisp b/src/compiler/hppa/array.lisp new file mode 100644 index 0000000..38a68e9 --- /dev/null +++ b/src/compiler/hppa/array.lisp @@ -0,0 +1,472 @@ +(in-package "SB!VM") + + +;;;; Allocator for the array header. + +(define-vop (make-array-header) + (:translate make-array-header) + (:policy :fast-safe) + (:args (type :scs (any-reg)) + (rank :scs (any-reg))) + (:arg-types tagged-num tagged-num) + (:temporary (:scs (descriptor-reg) :to (:result 0) :target result) header) + (:temporary (:scs (non-descriptor-reg) :type random) ndescr) + (:results (result :scs (descriptor-reg))) + (:generator 0 + (pseudo-atomic () + (inst move alloc-tn header) + (inst dep other-pointer-lowtag 31 3 header) + (inst addi (* (1+ array-dimensions-offset) n-word-bytes) rank ndescr) + (inst dep 0 31 3 ndescr) + (inst add alloc-tn ndescr alloc-tn) + (inst addi (fixnumize (1- array-dimensions-offset)) rank ndescr) + (inst sll ndescr n-widetag-bits ndescr) + (inst or ndescr type ndescr) + (inst srl ndescr 2 ndescr) + (storew ndescr header 0 other-pointer-lowtag)) + (move header result))) + + +;;;; Additional accessors and setters for the array header. + +(defknown sb!impl::%array-dimension (t index) index + (flushable)) +(defknown sb!impl::%set-array-dimension (t index index) index + ()) + +(define-full-reffer %array-dimension * + array-dimensions-offset other-pointer-lowtag + (any-reg) positive-fixnum sb!impl::%array-dimension) + +(define-full-setter %set-array-dimension * + array-dimensions-offset other-pointer-lowtag + (any-reg) positive-fixnum sb!impl::%set-array-dimension) + + +(defknown sb!impl::%array-rank (t) index (flushable)) + +(define-vop (array-rank-vop) + (:translate sb!impl::%array-rank) + (:policy :fast-safe) + (:args (x :scs (descriptor-reg))) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 6 + (loadw res x 0 other-pointer-lowtag) + (inst srl res n-widetag-bits res) + (inst addi (- (1- array-dimensions-offset)) res res))) + + + +;;;; Bounds checking routine. + + +(define-vop (check-bound) + (:translate %check-bound) + (:policy :fast-safe) + (:args (array :scs (descriptor-reg)) + (bound :scs (any-reg descriptor-reg)) + (index :scs (any-reg descriptor-reg) :target result)) + (:results (result :scs (any-reg descriptor-reg))) + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (let ((error (generate-error-code vop invalid-array-index-error + array bound index))) + (inst bc :>= nil index bound error)) + (move index result))) + + +;;;; Accessors/Setters + +;;; Variants built on top of word-index-ref, etc. I.e. those vectors whos +;;; elements are represented in integer registers and are built out of +;;; 8, 16, or 32 bit elements. + +(macrolet ((def-full-data-vector-frobs (type element-type &rest scs) + `(progn + (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type + vector-data-offset other-pointer-lowtag ,scs ,element-type + data-vector-ref) + (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type + vector-data-offset other-pointer-lowtag ,scs ,element-type + data-vector-set))) + + (def-partial-data-vector-frobs + (type element-type size signed &rest scs) + `(progn + (define-partial-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type + ,size ,signed vector-data-offset other-pointer-lowtag ,scs + ,element-type data-vector-ref) + (define-partial-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type + ,size vector-data-offset other-pointer-lowtag ,scs + ,element-type data-vector-set)))) + + (def-full-data-vector-frobs simple-vector * descriptor-reg any-reg) + + (def-partial-data-vector-frobs simple-string base-char :byte nil base-char-reg) + + (def-partial-data-vector-frobs simple-array-unsigned-byte-8 positive-fixnum + :byte nil unsigned-reg signed-reg) + + (def-partial-data-vector-frobs simple-array-unsigned-byte-16 positive-fixnum + :short nil unsigned-reg signed-reg) + + (def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num + unsigned-reg) + + (def-partial-data-vector-frobs simple-array-signed-byte-8 tagged-num + :byte t signed-reg) + + (def-partial-data-vector-frobs simple-array-signed-byte-16 tagged-num + :short t signed-reg) + + (def-full-data-vector-frobs simple-array-signed-byte-30 tagged-num any-reg) + + (def-full-data-vector-frobs simple-array-signed-byte-32 signed-num signed-reg)) + + +;;; Integer vectors whos elements are smaller than a byte. I.e. bit, 2-bit, +;;; and 4-bit vectors. +;;; + +(macrolet ((def-small-data-vector-frobs (type bits) + (let* ((elements-per-word (floor n-word-bits bits)) + (bit-shift (1- (integer-length elements-per-word)))) + `(progn + (define-vop (,(symbolicate 'data-vector-ref/ type)) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (unsigned-reg))) + (:arg-types ,type positive-fixnum) + (:results (result :scs (unsigned-reg) :from (:argument 0))) + (:result-types positive-fixnum) + (:temporary (:scs (non-descriptor-reg)) temp) + (:temporary (:scs (interior-reg)) lip) + (:generator 20 + (inst srl index ,bit-shift temp) + (inst sh2add temp object lip) + (loadw result lip vector-data-offset other-pointer-lowtag) + (inst zdep index ,(- 32 (integer-length bits)) ,bit-shift temp) + ,@(unless (= bits 1) + `((inst addi ,(1- bits) temp temp))) + (inst mtctl temp :sar) + (inst extru result :variable ,bits result))) + (define-vop (,(symbolicate 'data-vector-ref-c/ type)) + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:arg-types ,type (:constant index)) + (:info index) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 15 + (multiple-value-bind (word extra) (floor index ,elements-per-word) + (let ((offset (- (* (+ word vector-data-offset) n-word-bytes) + other-pointer-lowtag))) + (cond ((typep offset '(signed-byte 14)) + (inst ldw offset object result)) + (t + (inst ldil (ldb (byte 21 11) offset) temp) + (inst ldw (ldb (byte 11 0) offset) temp result)))) + (inst extru result (+ (* extra ,bits) ,(1- bits)) ,bits result)))) + (define-vop (,(symbolicate 'data-vector-set/ type)) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (unsigned-reg)) + (value :scs (unsigned-reg zero immediate) :target result)) + (:arg-types ,type positive-fixnum positive-fixnum) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:temporary (:scs (non-descriptor-reg)) temp old) + (:temporary (:scs (interior-reg)) lip) + (:generator 25 + (inst srl index ,bit-shift temp) + (inst sh2add temp object lip) + (loadw old lip vector-data-offset other-pointer-lowtag) + (inst zdep index ,(- 32 (integer-length bits)) ,bit-shift temp) + ,@(unless (= bits 1) + `((inst addi ,(1- bits) temp temp))) + (inst mtctl temp :sar) + (inst dep (sc-case value (immediate (tn-value value)) (t value)) + :variable ,bits old) + (storew old lip vector-data-offset other-pointer-lowtag) + (sc-case value + (immediate + (inst li (tn-value value) result)) + (t + (move value result))))) + (define-vop (,(symbolicate 'data-vector-set-c/ type)) + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (value :scs (unsigned-reg zero immediate) :target result)) + (:arg-types ,type + (:constant index) + positive-fixnum) + (:info index) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:temporary (:scs (non-descriptor-reg)) old) + (:temporary (:scs (interior-reg)) lip) + (:generator 20 + (multiple-value-bind (word extra) (floor index ,elements-per-word) + (let ((offset (- (* (+ word vector-data-offset) n-word-bytes) + other-pointer-lowtag))) + (cond ((typep offset '(signed-byte 14)) + (inst ldw offset object old)) + (t + (inst move object lip) + (inst addil (ldb (byte 21 11) offset) lip) + (inst ldw (ldb (byte 11 0) offset) lip old))) + (inst dep (sc-case value + (immediate (tn-value value)) + (t value)) + (+ (* extra ,bits) ,(1- bits)) + ,bits + old) + (if (typep offset '(signed-byte 14)) + (inst stw old offset object) + (inst stw old (ldb (byte 11 0) offset) lip))) + (sc-case value + (immediate + (inst li (tn-value value) result)) + (t + (move value result)))))))))) + (def-small-data-vector-frobs simple-bit-vector 1) + (def-small-data-vector-frobs simple-array-unsigned-byte-2 2) + (def-small-data-vector-frobs simple-array-unsigned-byte-4 4)) + +;;; And the float variants. +;;; + +(define-vop (data-vector-ref/simple-array-single-float) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to (:argument 1)) + (index :scs (any-reg) :to (:argument 0) :target offset)) + (:arg-types simple-array-single-float positive-fixnum) + (:results (value :scs (single-reg))) + (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) offset) + (:result-types single-float) + (:generator 5 + (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) + index offset) + (inst fldx offset object value))) + +(define-vop (data-vector-set/simple-array-single-float) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to (:argument 1)) + (index :scs (any-reg) :to (:argument 0) :target offset) + (value :scs (single-reg) :target result)) + (:arg-types simple-array-single-float positive-fixnum single-float) + (:results (result :scs (single-reg))) + (:result-types single-float) + (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) offset) + (:generator 5 + (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) + index offset) + (inst fstx value offset object) + (unless (location= result value) + (inst funop :copy value result)))) + +(define-vop (data-vector-ref/simple-array-double-float) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to (:argument 1)) + (index :scs (any-reg) :to (:argument 0) :target offset)) + (:arg-types simple-array-double-float positive-fixnum) + (:results (value :scs (double-reg))) + (:result-types double-float) + (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) offset) + (:generator 7 + (inst sll index 1 offset) + (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) + offset offset) + (inst fldx offset object value))) + +(define-vop (data-vector-set/simple-array-double-float) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to (:argument 1)) + (index :scs (any-reg) :to (:argument 0) :target offset) + (value :scs (double-reg) :target result)) + (:arg-types simple-array-double-float positive-fixnum double-float) + (:results (result :scs (double-reg))) + (:result-types double-float) + (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) offset) + (:generator 20 + (inst sll index 1 offset) + (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) + offset offset) + (inst fstx value offset object) + (unless (location= result value) + (inst funop :copy value result)))) + + +;;; Complex float arrays. + +(define-vop (data-vector-ref/simple-array-complex-single-float) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (index :scs (any-reg))) + (:arg-types simple-array-complex-single-float positive-fixnum) + (:results (value :scs (complex-single-reg))) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset) + (:result-types complex-single-float) + (:generator 5 + (inst sll index 1 offset) + (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) + offset offset) + (let ((real-tn (complex-single-reg-real-tn value))) + (inst fldx offset object real-tn)) + (let ((imag-tn (complex-single-reg-imag-tn value))) + (inst addi n-word-bytes offset offset) + (inst fldx offset object imag-tn)))) + +(define-vop (data-vector-set/simple-array-complex-single-float) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (index :scs (any-reg)) + (value :scs (complex-single-reg) :target result)) + (:arg-types simple-array-complex-single-float positive-fixnum + complex-single-float) + (:results (result :scs (complex-single-reg))) + (:result-types complex-single-float) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset) + (:generator 5 + (inst sll index 1 offset) + (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) + offset offset) + (let ((value-real (complex-single-reg-real-tn value)) + (result-real (complex-single-reg-real-tn result))) + (inst fstx value-real offset object) + (unless (location= result-real value-real) + (inst funop :copy value-real result-real))) + (let ((value-imag (complex-single-reg-imag-tn value)) + (result-imag (complex-single-reg-imag-tn result))) + (inst addi n-word-bytes offset offset) + (inst fstx value-imag offset object) + (unless (location= result-imag value-imag) + (inst funop :copy value-imag result-imag))))) + +(define-vop (data-vector-ref/simple-array-complex-double-float) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (index :scs (any-reg))) + (:arg-types simple-array-complex-double-float positive-fixnum) + (:results (value :scs (complex-double-reg))) + (:result-types complex-double-float) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset) + (:generator 7 + (inst sll index 2 offset) + (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) + offset offset) + (let ((real-tn (complex-double-reg-real-tn value))) + (inst fldx offset object real-tn)) + (let ((imag-tn (complex-double-reg-imag-tn value))) + (inst addi (* 2 n-word-bytes) offset offset) + (inst fldx offset object imag-tn)))) + +(define-vop (data-vector-set/simple-array-complex-double-float) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (index :scs (any-reg)) + (value :scs (complex-double-reg) :target result)) + (:arg-types simple-array-complex-double-float positive-fixnum + complex-double-float) + (:results (result :scs (complex-double-reg))) + (:result-types complex-double-float) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset) + (:generator 20 + (inst sll index 2 offset) + (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) + offset offset) + (let ((value-real (complex-double-reg-real-tn value)) + (result-real (complex-double-reg-real-tn result))) + (inst fstx value-real offset object) + (unless (location= result-real value-real) + (inst funop :copy value-real result-real))) + (let ((value-imag (complex-double-reg-imag-tn value)) + (result-imag (complex-double-reg-imag-tn result))) + (inst addi (* 2 n-word-bytes) offset offset) + (inst fstx value-imag offset object) + (unless (location= result-imag value-imag) + (inst funop :copy value-imag result-imag))))) + + +;;; These VOPs are used for implementing float slots in structures (whose raw +;;; data is an unsigned-32 vector. +;;; +(define-vop (raw-ref-single data-vector-ref/simple-array-single-float) + (:translate %raw-ref-single) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum)) +;;; +(define-vop (raw-set-single data-vector-set/simple-array-single-float) + (:translate %raw-set-single) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum single-float)) +;;; +(define-vop (raw-ref-double data-vector-ref/simple-array-double-float) + (:translate %raw-ref-double) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum)) +;;; +(define-vop (raw-set-double data-vector-set/simple-array-double-float) + (:translate %raw-set-double) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum double-float)) + +(define-vop (raw-ref-complex-single + data-vector-ref/simple-array-complex-single-float) + (:translate %raw-ref-complex-single) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum)) +;;; +(define-vop (raw-set-complex-single + data-vector-set/simple-array-complex-single-float) + (:translate %raw-set-complex-single) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum + complex-single-float)) +;;; +(define-vop (raw-ref-complex-double + data-vector-ref/simple-array-complex-double-float) + (:translate %raw-ref-complex-double) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum)) +;;; +(define-vop (raw-set-complex-double + data-vector-set/simple-array-complex-double-float) + (:translate %raw-set-complex-double) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum + complex-double-float)) + +;;; These vops are useful for accessing the bits of a vector irrespective of +;;; what type of vector it is. +;;; + +(define-full-reffer raw-bits * 0 other-pointer-lowtag (unsigned-reg) unsigned-num + %raw-bits) +(define-full-setter set-raw-bits * 0 other-pointer-lowtag (unsigned-reg) + unsigned-num %set-raw-bits) + + + +;;;; Misc. Array VOPs. + +(define-vop (get-vector-subtype get-header-data)) +(define-vop (set-vector-subtype set-header-data)) + diff --git a/src/compiler/hppa/backend-parms.lisp b/src/compiler/hppa/backend-parms.lisp new file mode 100644 index 0000000..01ac9d0 --- /dev/null +++ b/src/compiler/hppa/backend-parms.lisp @@ -0,0 +1,7 @@ +(in-package "SB!VM") + +(def!constant +backend-fasl-file-implementation+ :hppa) +(setf *backend-register-save-penalty* 3) +(setf *backend-byte-order* :big-endian) +(setf *backend-page-size* 4096) + diff --git a/src/compiler/hppa/c-call.lisp b/src/compiler/hppa/c-call.lisp new file mode 100644 index 0000000..15484f2 --- /dev/null +++ b/src/compiler/hppa/c-call.lisp @@ -0,0 +1,165 @@ +(in-package "SB!VM") + +(defun my-make-wired-tn (prim-type-name sc-name offset) + (make-wired-tn (primitive-type-or-lose prim-type-name) + (sc-number-or-lose sc-name) + offset)) + +(defstruct arg-state + (args 0)) + +(defstruct (arg-info + (:constructor make-arg-info (offset prim-type reg-sc stack-sc))) + offset + prim-type + reg-sc + stack-sc) + +(define-alien-type-method (integer :arg-tn) (type state) + (let ((args (arg-state-args state))) + (setf (arg-state-args state) (1+ args)) + (if (alien-integer-type-signed type) + (make-arg-info args 'signed-byte-32 'signed-reg 'signed-stack) + (make-arg-info args 'unsigned-byte-32 'unsigned-reg 'unsigned-stack)))) + +(define-alien-type-method (system-area-pointer :arg-tn) (type state) + (declare (ignore type)) + (let ((args (arg-state-args state))) + (setf (arg-state-args state) (1+ args)) + (make-arg-info args 'system-area-pointer 'sap-reg 'sap-stack))) + +(define-alien-type-method (single-float :arg-tn) (type state) + (declare (ignore type)) + (let ((args (arg-state-args state))) + (setf (arg-state-args state) (1+ args)) + (make-arg-info args 'single-float 'single-reg 'single-stack))) + +(define-alien-type-method (double-float :arg-tn) (type state) + (declare (ignore type)) + (let ((args (logior (1+ (arg-state-args state)) 1))) + (setf (arg-state-args state) (1+ args)) + (make-arg-info args 'double-float 'double-reg 'double-stack))) + +(define-alien-type-method (integer :result-tn) (type) + (if (alien-integer-type-signed type) + (my-make-wired-tn 'signed-byte-32 'signed-reg nl4-offset) + (my-make-wired-tn 'unsigned-byte-32 'unsigned-reg nl4-offset))) + +(define-alien-type-method (system-area-pointer :result-tn) (type) + (declare (ignore type)) + (my-make-wired-tn 'system-area-pointer 'sap-reg nl4-offset)) + +(define-alien-type-method (single-float :result-tn) (type) + (declare (ignore type)) + (my-make-wired-tn 'single-float 'single-reg 4)) + +(define-alien-type-method (double-float :result-tn) (type) + (declare (ignore type)) + (my-make-wired-tn 'double-float 'double-reg 4)) + +(define-alien-type-method (values :result-tn) (type) + (let ((values (alien-values-type-values type))) + (when values + (assert (null (cdr values))) + (invoke-alien-type-method :result-tn (car values))))) + +(defun make-arg-tns (type) + (let* ((state (make-arg-state)) + (args (mapcar #'(lambda (arg-type) + (invoke-alien-type-method :arg-tn arg-type state)) + (alien-fun-type-arg-types type))) + ;; We need 8 words of cruft, and we need to round up to a multiple + ;; of 16 words. + (frame-size (logandc2 (+ (arg-state-args state) 8 15) 15))) + (values + (mapcar #'(lambda (arg) + (declare (type arg-info arg)) + (let ((offset (arg-info-offset arg)) + (prim-type (arg-info-prim-type arg))) + (cond ((>= offset 4) + (my-make-wired-tn prim-type (arg-info-stack-sc arg) + (- frame-size offset 8 1))) + ((or (eq prim-type 'single-float) + (eq prim-type 'double-float)) + (my-make-wired-tn prim-type (arg-info-reg-sc arg) + (+ offset 4))) + (t + (my-make-wired-tn prim-type (arg-info-reg-sc arg) + (- nl0-offset offset)))))) + args) + (* frame-size n-word-bytes)))) + +(!def-vm-support-routine make-call-out-tns (type) + (declare (type alien-fun-type type)) + (multiple-value-bind + (arg-tns stack-size) + (make-arg-tns type) + (values (make-normal-tn *fixnum-primitive-type*) + stack-size + arg-tns + (invoke-alien-type-method + :result-tn + (alien-fun-type-result-type type))))) + + +(define-vop (foreign-symbol-address) + (:translate foreign-symbol-address) + (:policy :fast-safe) + (:args) + (:arg-types (:constant simple-string)) + (:info foreign-symbol) + (:results (res :scs (sap-reg))) + (:result-types system-area-pointer) + (:generator 2 + (inst li (make-fixup foreign-symbol :foreign) res))) + +(define-vop (call-out) + (:args (function :scs (sap-reg) :target cfunc) + (args :more t)) + (:results (results :more t)) + (:ignore args results) + (:save-p t) + (:temporary (:sc any-reg :offset cfunc-offset + :from (:argument 0) :to (:result 0)) cfunc) + (:temporary (:scs (any-reg) :to (:result 0)) temp) + (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) + (:vop-var vop) + (:generator 0 + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (store-stack-tn nfp-save cur-nfp)) + (move function cfunc) + (let ((fixup (make-fixup "call_into_c" :foreign))) + (inst ldil fixup temp) + (inst ble fixup c-text-space temp :nullify t)) + (inst nop) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save))))) + + +(define-vop (alloc-number-stack-space) + (:info amount) + (:results (result :scs (sap-reg any-reg))) + (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) + (:generator 0 + (move nsp-tn result) + (unless (zerop amount) + (let ((delta (logandc2 (+ amount 63) 63))) + (cond ((< delta (ash 1 10)) + (inst addi delta nsp-tn nsp-tn)) + (t + (inst li delta temp) + (inst add temp nsp-tn nsp-tn))))))) + +(define-vop (dealloc-number-stack-space) + (:info amount) + (:policy :fast-safe) + (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) + (:generator 0 + (unless (zerop amount) + (let ((delta (- (logandc2 (+ amount 63) 63)))) + (cond ((<= (- (ash 1 10)) delta) + (inst addi delta nsp-tn nsp-tn)) + (t + (inst li delta temp) + (inst add temp nsp-tn nsp-tn))))))) diff --git a/src/compiler/hppa/call.lisp b/src/compiler/hppa/call.lisp new file mode 100644 index 0000000..041deaa --- /dev/null +++ b/src/compiler/hppa/call.lisp @@ -0,0 +1,1220 @@ +(in-package "SB!VM") + + +;;;; Interfaces to IR2 conversion: + +;;; Standard-Argument-Location -- Interface +;;; +;;; Return a wired TN describing the N'th full call argument passing +;;; location. +;;; +(!def-vm-support-routine standard-arg-location (n) + (declare (type unsigned-byte n)) + (if (< n register-arg-count) + (make-wired-tn *backend-t-primitive-type* + register-arg-scn + (elt *register-arg-offsets* n)) + (make-wired-tn *backend-t-primitive-type* + control-stack-arg-scn n))) + + +;;; Make-Return-PC-Passing-Location -- Interface +;;; +;;; Make a passing location TN for a local call return PC. If standard is +;;; true, then use the standard (full call) location, otherwise use any legal +;;; location. Even in the non-standard case, this may be restricted by a +;;; desire to use a subroutine call instruction. +;;; +(!def-vm-support-routine make-return-pc-passing-location (standard) + (if standard + (make-wired-tn *backend-t-primitive-type* register-arg-scn lra-offset) + (make-restricted-tn *backend-t-primitive-type* register-arg-scn))) + +;;; Make-Old-FP-Passing-Location -- Interface +;;; +;;; Similar to Make-Return-PC-Passing-Location, but makes a location to pass +;;; Old-FP in. This is (obviously) wired in the standard convention, but is +;;; totally unrestricted in non-standard conventions, since we can always fetch +;;; it off of the stack using the arg pointer. +;;; +(!def-vm-support-routine make-old-fp-passing-location (standard) + (if standard + (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ocfp-offset) + (make-normal-tn *fixnum-primitive-type*))) + +;;; Make-Old-FP-Save-Location, Make-Return-PC-Save-Location -- Interface +;;; +;;; Make the TNs used to hold Old-FP and Return-PC within the current +;;; function. We treat these specially so that the debugger can find them at a +;;; known location. +;;; +(!def-vm-support-routine make-old-fp-save-location (env) + (specify-save-tn + (physenv-debug-live-tn (make-normal-tn *fixnum-primitive-type*) env) + (make-wired-tn *fixnum-primitive-type* + control-stack-arg-scn + ocfp-save-offset))) +;;; +(!def-vm-support-routine make-return-pc-save-location (env) + (specify-save-tn + (physenv-debug-live-tn (make-normal-tn *backend-t-primitive-type*) env) + (make-wired-tn *backend-t-primitive-type* + control-stack-arg-scn + lra-save-offset))) + +;;; Make-Arg-Count-Location -- Interface +;;; +;;; Make a TN for the standard argument count passing location. We only +;;; need to make the standard location, since a count is never passed when we +;;; are using non-standard conventions. +;;; +(!def-vm-support-routine make-arg-count-location () + (make-wired-tn *fixnum-primitive-type* immediate-arg-scn nargs-offset)) + + +;;; MAKE-NFP-TN -- Interface +;;; +;;; Make a TN to hold the number-stack frame pointer. This is allocated +;;; once per component, and is component-live. +;;; +(!def-vm-support-routine make-nfp-tn () + (component-live-tn + (make-wired-tn *fixnum-primitive-type* immediate-arg-scn nfp-offset))) + +;;; MAKE-STACK-POINTER-TN () +;;; +(!def-vm-support-routine make-stack-pointer-tn () + (make-normal-tn *fixnum-primitive-type*)) + +;;; MAKE-NUMBER-STACK-POINTER-TN () +;;; +(!def-vm-support-routine make-number-stack-pointer-tn () + (make-normal-tn *fixnum-primitive-type*)) + +;;; Make-Unknown-Values-Locations -- Interface +;;; +;;; Return a list of TNs that can be used to represent an unknown-values +;;; continuation within a function. +;;; +(!def-vm-support-routine make-unknown-values-locations () + (list (make-stack-pointer-tn) + (make-normal-tn *fixnum-primitive-type*))) + + +;;; Select-Component-Format -- Interface +;;; +;;; This function is called by the Entry-Analyze phase, allowing +;;; VM-dependent initialization of the IR2-Component structure. We push +;;; placeholder entries in the Constants to leave room for additional +;;; noise in the code object header. +;;; +(!def-vm-support-routine select-component-format (component) + (declare (type component component)) + (dotimes (i code-constants-offset) + (vector-push-extend nil + (ir2-component-constants (component-info component)))) + (values)) + + +;;;; Frame hackery: + +;;; BYTES-NEEDED-FOR-NON-DESCRIPTOR-STACK-FRAME -- internal +;;; +;;; Return the number of bytes needed for the current non-descriptor stack. +;;; We have to allocate multiples of 64 bytes. +;;; +(defun bytes-needed-for-non-descriptor-stack-frame () + (logandc2 (+ (* (sb-allocated-size 'non-descriptor-stack) n-word-bytes) 63) + 63)) + +;;; Used for setting up the Old-FP in local call. +;;; +(define-vop (current-fp) + (:results (val :scs (any-reg))) + (:generator 1 + (move cfp-tn val))) + +;;; Used for computing the caller's NFP for use in known-values return. Only +;;; works assuming there is no variable size stuff on the nstack. +;;; +(define-vop (compute-old-nfp) + (:results (val :scs (any-reg))) + (:vop-var vop) + (:generator 1 + (let ((nfp (current-nfp-tn vop))) + (when nfp + (inst addi (- (bytes-needed-for-non-descriptor-stack-frame)) + nfp val))))) + +(define-vop (xep-allocate-frame) + (:info start-lab copy-more-arg-follows) + (:ignore copy-more-arg-follows) + (:vop-var vop) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 1 + ;; Make sure the function is aligned, and drop a label pointing to this + ;; function header. + (align n-lowtag-bits) + (trace-table-entry trace-table-fun-prologue) + (emit-label start-lab) + ;; Allocate function header. + (inst fun-header-word) + (dotimes (i (1- simple-fun-code-offset)) + (inst word 0)) + ;; The start of the actual code. + ;; Fix CODE, cause the function object was passed in. + (let ((entry-point (gen-label))) + (emit-label entry-point) + (inst compute-code-from-fn lip-tn entry-point temp code-tn)) + ;; Build our stack frames. + (inst addi (* n-word-bytes (sb-allocated-size 'control-stack)) + cfp-tn csp-tn) + (let ((nfp (current-nfp-tn vop))) + (when nfp + (move nsp-tn nfp) + (inst addi (bytes-needed-for-non-descriptor-stack-frame) + nsp-tn nsp-tn))) + (trace-table-entry trace-table-normal))) + +(define-vop (allocate-frame) + (:results (res :scs (any-reg)) + (nfp :scs (any-reg))) + (:info callee) + (:generator 2 + (move csp-tn res) + (inst addi (* n-word-bytes (sb-allocated-size 'control-stack)) + csp-tn csp-tn) + (when (ir2-physenv-number-stack-p callee) + (move nsp-tn nfp) + (inst addi (bytes-needed-for-non-descriptor-stack-frame) + nsp-tn nsp-tn)))) + +;;; Allocate a partial frame for passing stack arguments in a full call. Nargs +;;; is the number of arguments passed. If no stack arguments are passed, then +;;; we don't have to do anything. +;;; +(define-vop (allocate-full-call-frame) + (:info nargs) + (:results (res :scs (any-reg))) + (:generator 2 + (when (> nargs register-arg-count) + (move csp-tn res) + (inst addi (* nargs n-word-bytes) csp-tn csp-tn)))) + + +;;; Default-Unknown-Values -- Internal +;;; +;;; Emit code needed at the return-point from an unknown-values call for a +;;; fixed number of values. Values is the head of the TN-Ref list for the +;;; locations that the values are to be received into. Nvals is the number of +;;; values that are to be received (should equal the length of Values). +;;; +;;; Move-Temp is a Descriptor-Reg TN used as a temporary. +;;; +;;; This code exploits the fact that in the unknown-values convention, a +;;; single value return returns at the return PC + 8, whereas a return of other +;;; than one value returns directly at the return PC. +;;; +;;; If 0 or 1 values are expected, then we just emit an instruction to reset +;;; the SP (which will only be executed when other than 1 value is returned.) +;;; +;;; In the general case, we have to do three things: +;;; -- Default unsupplied register values. This need only be done when a +;;; single value is returned, since register values are defaulted by the +;;; called in the non-single case. +;;; -- Default unsupplied stack values. This needs to be done whenever there +;;; are stack values. +;;; -- Reset SP. This must be done whenever other than 1 value is returned, +;;; regardless of the number of values desired. +;;; +;;; The general-case code looks like this: +#| + b regs-defaulted ; Skip if MVs + nop + + move a1 null-tn ; Default register values + ... + loadi nargs 1 ; Force defaulting of stack values + move old-fp csp ; Set up args for SP resetting + +regs-defaulted + subu temp nargs register-arg-count + + bltz temp default-value-7 ; jump to default code + addu temp temp -1 + loadw move-temp old-fp-tn 6 ; Move value to correct location. + store-stack-tn val4-tn move-temp + + bltz temp default-value-8 + addu temp temp -1 + loadw move-temp old-fp-tn 7 + store-stack-tn val5-tn move-temp + + ... + +defaulting-done + move sp old-fp ; Reset SP. + + + +default-value-7 + store-stack-tn val4-tn null-tn ; Nil out 7'th value. (first on stack) + +default-value-8 + store-stack-tn val5-tn null-tn ; Nil out 8'th value. + + ... + + br defaulting-done + nop +|# +;;; +(defun default-unknown-values (vop values nvals move-temp temp lra-label) + (declare (type (or tn-ref null) values) + (type unsigned-byte nvals) (type tn move-temp temp)) + (cond + ((<= nvals 1) + (assemble () + ;; Note that this is a single-value return point. This is actually + ;; the multiple-value entry point for a single desired value, but + ;; the code location has to be here, or the debugger backtrace + ;; gets confused. + (note-this-location vop :single-value-return) + (move ocfp-tn csp-tn) + (inst compute-code-from-lra code-tn lra-label temp code-tn))) + ((<= nvals register-arg-count) + (assemble () + ;; Note that this is an unknown-values return point. + (note-this-location vop :unknown-return) + ;; Branch off to the MV case. + (inst b regs-defaulted :nullify t) + + ;; Default any unsupplied values. + (do ((val (tn-ref-across values) (tn-ref-across val))) + ((null val)) + (inst move null-tn (tn-ref-tn val) + (if (tn-ref-across val) + :never + :tr))) + + REGS-DEFAULTED + + ;; Clear the stack. Note: the last move in the single value reg + ;; defaulting nullifies this, so this only happens in the mv case. + (move ocfp-tn csp-tn) + + ;; Fix CODE. + (inst compute-code-from-lra code-tn lra-label temp code-tn))) + (t + (collect ((defaults)) + (assemble (nil nil :labels (default-stack-vals)) + ;; Note that this is an unknown-values return point. + (note-this-location vop :unknown-return) + ;; Branch off to the MV case. + (inst b regs-defaulted :nullify t) + + ;; Default any unsupplied register values. + (do ((i 1 (1+ i)) + (val (tn-ref-across values) (tn-ref-across val))) + ((= i register-arg-count)) + (inst move null-tn (tn-ref-tn val))) + (inst b default-stack-vals) + (move ocfp-tn csp-tn) + + REGS-DEFAULTED + + (do ((i register-arg-count (1+ i)) + (val (do ((i 0 (1+ i)) + (val values (tn-ref-across val))) + ((= i register-arg-count) val)) + (tn-ref-across val))) + ((null val)) + + (let ((default-lab (gen-label)) + (tn (tn-ref-tn val))) + (defaults (cons default-lab tn)) + (inst bci :>= nil (fixnumize i) nargs-tn default-lab) + (loadw move-temp ocfp-tn i) + (store-stack-tn tn move-temp))) + + DEFAULTING-DONE + (move ocfp-tn csp-tn) + (inst compute-code-from-lra code-tn lra-label temp code-tn) + + (let ((defaults (defaults))) + (assert defaults) + (assemble (*elsewhere*) + (trace-table-entry trace-table-call-site) + DEFAULT-STACK-VALS + (do ((remaining defaults (cdr remaining))) + ((null remaining)) + (let ((def (car remaining))) + (emit-label (car def)) + (when (null (cdr remaining)) + (inst b defaulting-done)) + (store-stack-tn (cdr def) null-tn))) + (trace-table-entry trace-table-normal))))))) + (values)) + + +;;;; Unknown values receiving: + +;;; Receive-Unknown-Values -- Internal +;;; +;;; Emit code needed at the return point for an unknown-values call for an +;;; arbitrary number of values. +;;; +;;; We do the single and non-single cases with no shared code: there doesn't +;;; seem to be any potential overlap, and receiving a single value is more +;;; important efficiency-wise. +;;; +;;; When there is a single value, we just push it on the stack, returning +;;; the old SP and 1. +;;; +;;; When there is a variable number of values, we move all of the argument +;;; registers onto the stack, and return Args and Nargs. +;;; +;;; Args and Nargs are TNs wired to the named locations. We must +;;; explicitly allocate these TNs, since their lifetimes overlap with the +;;; results Start and Count (also, it's nice to be able to target them). +;;; +(defun receive-unknown-values (args nargs start count lra-label temp) + (declare (type tn args nargs start count temp)) + (assemble (nil nil :labels (variable-values)) + (inst b variable-values :nullify t) + + (inst compute-code-from-lra code-tn lra-label temp code-tn) + (inst move csp-tn start) + (inst stwm (first register-arg-tns) n-word-bytes csp-tn) + (inst li (fixnumize 1) count) + + DONE + + (assemble (*elsewhere*) + (trace-table-entry trace-table-call-site) + VARIABLE-VALUES + (inst compute-code-from-lra code-tn lra-label temp code-tn) + (do ((arg register-arg-tns (rest arg)) + (i 0 (1+ i))) + ((null arg)) + (storew (first arg) args i)) + (move args start) + (move nargs count) + (inst b done :nullify t) + (trace-table-entry trace-table-normal))) + (values)) + +;;; VOP that can be inherited by unknown values receivers. The main thing this +;;; handles is allocation of the result temporaries. +;;; +(define-vop (unknown-values-receiver) + (:results (start :scs (any-reg)) + (count :scs (any-reg))) + (:temporary (:sc descriptor-reg :offset ocfp-offset + :from :eval :to (:result 0)) + values-start) + (:temporary (:sc any-reg :offset nargs-offset + :from :eval :to (:result 1)) + nvals) + (:temporary (:scs (non-descriptor-reg)) temp)) + + + +;;;; Local call with unknown values convention return: + +;;; Non-TR local call for a fixed number of values passed according to the +;;; unknown values convention. +;;; +;;; Args are the argument passing locations, which are specified only to +;;; terminate their lifetimes in the caller. +;;; +;;; Values are the return value locations (wired to the standard passing +;;; locations). +;;; +;;; Save is the save info, which we can ignore since saving has been done. +;;; Return-PC is the TN that the return PC should be passed in. +;;; Target is a continuation pointing to the start of the called function. +;;; Nvals is the number of values received. +;;; +;;; Note: we can't use normal load-tn allocation for the fixed args, since all +;;; registers may be tied up by the more operand. Instead, we use +;;; MAYBE-LOAD-STACK-TN. +;;; +(define-vop (call-local) + (:args (cfp) + (nfp) + (args :more t)) + (:results (values :more t)) + (:save-p t) + (:move-args :local-call) + (:info arg-locs callee target nvals) + (:vop-var vop) + (:temporary (:scs (descriptor-reg) :from :eval) move-temp) + (:temporary (:scs (non-descriptor-reg)) temp) + (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) + (:temporary (:sc any-reg :offset ocfp-offset :from :eval) ocfp) + (:ignore arg-locs args ocfp) + (:generator 5 + (trace-table-entry trace-table-call-site) + (let ((label (gen-label)) + (cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (store-stack-tn nfp-save cur-nfp)) + (let ((callee-nfp (callee-nfp-tn callee))) + (when callee-nfp + (maybe-load-stack-tn callee-nfp nfp))) + (maybe-load-stack-tn cfp-tn cfp) + (inst compute-lra-from-code code-tn label temp + (callee-return-pc-tn callee)) + (note-this-location vop :call-site) + (inst b target :nullify t) + (emit-return-pc label) + (default-unknown-values vop values nvals move-temp temp label) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save))) + (trace-table-entry trace-table-normal))) + +;;; Non-TR local call for a variable number of return values passed according +;;; to the unknown values convention. The results are the start of the values +;;; glob and the number of values received. +;;; +;;; Note: we can't use normal load-tn allocation for the fixed args, since all +;;; registers may be tied up by the more operand. Instead, we use +;;; MAYBE-LOAD-STACK-TN. +;;; +(define-vop (multiple-call-local unknown-values-receiver) + (:args (cfp) + (nfp) + (args :more t)) + (:save-p t) + (:move-args :local-call) + (:info save callee target) + (:ignore args save) + (:vop-var vop) + (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) + (:generator 20 + (trace-table-entry trace-table-call-site) + (let ((label (gen-label)) + (cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (store-stack-tn nfp-save cur-nfp)) + (let ((callee-nfp (callee-nfp-tn callee))) + (when callee-nfp + (maybe-load-stack-tn callee-nfp nfp))) + (maybe-load-stack-tn cfp-tn cfp) + (inst compute-lra-from-code code-tn label temp + (callee-return-pc-tn callee)) + (note-this-location vop :call-site) + (inst b target :nullify t) + (emit-return-pc label) + (note-this-location vop :unknown-return) + (receive-unknown-values values-start nvals start count label temp) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save))) + (trace-table-entry trace-table-normal))) + + +;;;; Local call with known values return: + +;;; Non-TR local call with known return locations. Known-value return works +;;; just like argument passing in local call. +;;; +;;; Note: we can't use normal load-tn allocation for the fixed args, since all +;;; registers may be tied up by the more operand. Instead, we use +;;; MAYBE-LOAD-STACK-TN. +;;; +(define-vop (known-call-local) + (:args (cfp) + (nfp) + (args :more t)) + (:results (res :more t)) + (:move-args :local-call) + (:save-p t) + (:info save callee target) + (:ignore args res save) + (:vop-var vop) + (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 5 + (trace-table-entry trace-table-call-site) + (let ((label (gen-label)) + (cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (store-stack-tn nfp-save cur-nfp)) + (let ((callee-nfp (callee-nfp-tn callee))) + (when callee-nfp + (maybe-load-stack-tn callee-nfp nfp))) + (maybe-load-stack-tn cfp-tn cfp) + (inst compute-lra-from-code code-tn label temp + (callee-return-pc-tn callee)) + (note-this-location vop :call-site) + (inst b target :nullify t) + (emit-return-pc label) + (note-this-location vop :known-return) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save))) + (trace-table-entry trace-table-normal))) + +;;; Return from known values call. We receive the return locations as +;;; arguments to terminate their lifetimes in the returning function. We +;;; restore FP and CSP and jump to the Return-PC. +;;; +;;; Note: we can't use normal load-tn allocation for the fixed args, since all +;;; registers may be tied up by the more operand. Instead, we use +;;; MAYBE-LOAD-STACK-TN. +;;; +(define-vop (known-return) + (:args (old-fp :target old-fp-temp) + (return-pc :target return-pc-temp) + (vals :more t)) + (:temporary (:sc any-reg :from (:argument 0)) old-fp-temp) + (:temporary (:sc descriptor-reg :from (:argument 1)) return-pc-temp) + (:temporary (:scs (interior-reg)) lip) + (:move-args :known-return) + (:info val-locs) + (:ignore val-locs vals) + (:vop-var vop) + (:generator 6 + (trace-table-entry trace-table-fun-epilogue) + (maybe-load-stack-tn old-fp-temp old-fp) + (maybe-load-stack-tn return-pc-temp return-pc) + (move cfp-tn csp-tn) + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (move cur-nfp nsp-tn))) + (inst addi (- n-word-bytes other-pointer-lowtag) return-pc-temp lip) + (inst bv lip) + (move old-fp-temp cfp-tn) + (trace-table-entry trace-table-normal))) + + +;;;; Full call: +;;; +;;; There is something of a cross-product effect with full calls. Different +;;; versions are used depending on whether we know the number of arguments or +;;; the name of the called function, and whether we want fixed values, unknown +;;; values, or a tail call. +;;; +;;; In full call, the arguments are passed creating a partial frame on the +;;; stack top and storing stack arguments into that frame. On entry to the +;;; callee, this partial frame is pointed to by FP. If there are no stack +;;; arguments, we don't bother allocating a partial frame, and instead set FP +;;; to SP just before the call. + +;;; Define-Full-Call -- Internal +;;; +;;; This macro helps in the definition of full call VOPs by avoiding code +;;; replication in defining the cross-product VOPs. +;;; +;;; Name is the name of the VOP to define. +;;; +;;; Named is true if the first argument is a symbol whose global function +;;; definition is to be called. +;;; +;;; Return is either :Fixed, :Unknown or :Tail: +;;; -- If :Fixed, then the call is for a fixed number of values, returned in +;;; the standard passing locations (passed as result operands). +;;; -- If :Unknown, then the result values are pushed on the stack, and the +;;; result values are specified by the Start and Count as in the +;;; unknown-values continuation representation. +;;; -- If :Tail, then do a tail-recursive call. No values are returned. +;;; The Old-Fp and Return-PC are passed as the second and third arguments. +;;; +;;; In non-tail calls, the pointer to the stack arguments is passed as the last +;;; fixed argument. If Variable is false, then the passing locations are +;;; passed as a more arg. Variable is true if there are a variable number of +;;; arguments passed on the stack. Variable cannot be specified with :Tail +;;; return. TR variable argument call is implemented separately. +;;; +;;; In tail call with fixed arguments, the passing locations are passed as a +;;; more arg, but there is no new-FP, since the arguments have been set up in +;;; the current frame. +;;; +(macrolet ((define-full-call (name named return variable) + (assert (not (and variable (eq return :tail)))) + `(define-vop (,name + ,@(when (eq return :unknown) + '(unknown-values-receiver))) + (:args + ,@(unless (eq return :tail) + '((new-fp :scs (any-reg) :to :eval))) + + ,(if named + '(fdefn :target fdefn-pass) + '(arg-fun :target lexenv)) + + ,@(when (eq return :tail) + '((ocfp :target ocfp-pass) + (lra :target lra-pass))) + + ,@(unless variable '((args :more t :scs (descriptor-reg))))) + + ,@(when (eq return :fixed) + '((:results (values :more t)))) + + (:save-p ,(if (eq return :tail) :compute-only t)) + + ,@(unless (or (eq return :tail) variable) + '((:move-args :full-call))) + + (:vop-var vop) + (:info ,@(unless (or variable (eq return :tail)) '(arg-locs)) + ,@(unless variable '(nargs)) + ,@(when (eq return :fixed) '(nvals))) + + (:ignore + ,@(unless (or variable (eq return :tail)) '(arg-locs)) + ,@(unless variable '(args))) + + (:temporary (:sc descriptor-reg + :offset ocfp-offset + ,@(when (eq return :tail) + '(:from (:argument 1))) + ,@(unless (eq return :fixed) + '(:to :eval))) + ocfp-pass) + + (:temporary (:sc descriptor-reg + :offset lra-offset + ,@(when (eq return :tail) + '(:from (:argument 2))) + :to :eval) + lra-pass) + + ,@(if named + `((:temporary (:sc descriptor-reg :offset fdefn-offset + :from (:argument ,(if (eq return :tail) 0 1)) + :to :eval) + fdefn-pass)) + + `((:temporary (:sc descriptor-reg :offset lexenv-offset + :from (:argument ,(if (eq return :tail) 0 1)) + :to :eval) + lexenv) + (:temporary (:scs (descriptor-reg) + :from (:argument ,(if (eq return :tail) 2 1)) + :to :eval) + function))) + + (:temporary (:sc any-reg :offset nargs-offset :to :eval) + nargs-pass) + + ,@(when variable + (mapcar #'(lambda (name offset) + `(:temporary (:sc descriptor-reg + :offset ,offset + :to :eval) + ,name)) + register-arg-names *register-arg-offsets*)) + ,@(when (eq return :fixed) + '((:temporary (:scs (descriptor-reg) :from :eval) move-temp))) + + ,@(unless (eq return :tail) + '((:temporary (:scs (non-descriptor-reg)) temp) + (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save))) + + (:temporary (:scs (interior-reg) :type interior) lip) + + (:generator ,(+ (if named 5 0) + (if variable 19 1) + (if (eq return :tail) 0 10) + 15 + (if (eq return :unknown) 25 0)) + (trace-table-entry trace-table-call-site) + (let* ((cur-nfp (current-nfp-tn vop)) + ,@(unless (eq return :tail) + '((lra-label (gen-label)))) + (filler + (list :load-nargs + ,@(if (eq return :tail) + '((unless (location= ocfp ocfp-pass) + :load-ocfp) + (unless (location= lra lra-pass) + :load-lra) + (when cur-nfp + :frob-nfp)) + '((when cur-nfp + :frob-nfp) + :comp-lra + :save-fp + :load-fp))))) + (labels + ((do-next-filler () + (when filler + (ecase (pop filler) + ((nil) (do-next-filler)) + (:load-nargs + ,@(if variable + `((inst sub csp-tn new-fp nargs-pass) + ,@(let ((index -1)) + (mapcar #'(lambda (name) + `(loadw ,name new-fp + ,(incf index))) + register-arg-names))) + '((inst li (fixnumize nargs) nargs-pass)))) + ,@(if (eq return :tail) + '((:load-ocfp + (sc-case ocfp + (any-reg + (inst move ocfp ocfp-pass)) + (control-stack + (loadw ocfp-pass cfp-tn (tn-offset ocfp))))) + (:load-lra + (sc-case lra + (descriptor-reg + (inst move lra lra-pass)) + (control-stack + (loadw lra-pass cfp-tn (tn-offset lra))))) + (:frob-nfp + (inst move cur-nfp nsp-tn))) + `((:frob-nfp + (store-stack-tn nfp-save cur-nfp)) + (:comp-lra + (inst compute-lra-from-code + code-tn lra-label temp lra-pass)) + (:save-fp + (inst move cfp-tn ocfp-pass)) + (:load-fp + ,(if variable + '(move new-fp cfp-tn) + '(if (> nargs register-arg-count) + (move new-fp cfp-tn) + (move csp-tn cfp-tn)))))))))) + + ,@(if named + `((sc-case fdefn + (descriptor-reg (move fdefn fdefn-pass)) + (control-stack + (loadw fdefn-pass cfp-tn (tn-offset fdefn)) + (do-next-filler)) + (constant + (loadw fdefn-pass code-tn (tn-offset fdefn) + other-pointer-lowtag) + (do-next-filler))) + (loadw lip fdefn-pass fdefn-raw-addr-slot + other-pointer-lowtag) + (do-next-filler)) + `((sc-case arg-fun + (descriptor-reg (move arg-fun lexenv)) + (control-stack + (loadw lexenv cfp-tn (tn-offset arg-fun)) + (do-next-filler)) + (constant + (loadw lexenv code-tn (tn-offset arg-fun) + other-pointer-lowtag) + (do-next-filler))) + (loadw function lexenv closure-fun-slot + fun-pointer-lowtag) + (do-next-filler) + (inst addi (- (ash simple-fun-code-offset word-shift) + fun-pointer-lowtag) + function lip))) + (loop + (cond ((null filler) + (return)) + ((null (car filler)) + (pop filler)) + ((null (cdr filler)) + (return)) + (t + (do-next-filler)))) + + (note-this-location vop :call-site) + (inst bv lip :nullify (null filler)) + (do-next-filler)) + + ,@(ecase return + (:fixed + '((emit-return-pc lra-label) + (default-unknown-values vop values nvals + move-temp temp lra-label) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save)))) + (:unknown + '((emit-return-pc lra-label) + (note-this-location vop :unknown-return) + (receive-unknown-values values-start nvals start count + lra-label temp) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save)))) + (:tail))) + (trace-table-entry trace-table-normal))))) + + (define-full-call call nil :fixed nil) + (define-full-call call-named t :fixed nil) + (define-full-call multiple-call nil :unknown nil) + (define-full-call multiple-call-named t :unknown nil) + (define-full-call tail-call nil :tail nil) + (define-full-call tail-call-named t :tail nil) + + (define-full-call call-variable nil :fixed t) + (define-full-call multiple-call-variable nil :unknown t)) + + +;;; Defined separately, since needs special code that BLT's the arguments +;;; down. +;;; +(define-vop (tail-call-variable) + (:args (args-arg :scs (any-reg) :target args) + (function-arg :scs (descriptor-reg) :target lexenv) + (old-fp-arg :scs (any-reg) :target old-fp) + (lra-arg :scs (descriptor-reg) :target lra)) + + (:temporary (:sc any-reg :offset nl0-offset :from (:argument 0)) args) + (:temporary (:sc any-reg :offset lexenv-offset :from (:argument 1)) lexenv) + (:temporary (:sc any-reg :offset ocfp-offset :from (:argument 2)) old-fp) + (:temporary (:sc any-reg :offset lra-offset :from (:argument 3)) lra) + (:temporary (:scs (any-reg) :from (:argument 3)) tmp) + + (:vop-var vop) + + (:generator 75 + + ;; Move these into the passing locations if they are not already there. + (move args-arg args) + (move function-arg lexenv) + (move old-fp-arg old-fp) + (move lra-arg lra) + + ;; Clear the number stack if anything is there. + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (inst move cur-nfp nsp-tn))) + + ;; And jump to the assembly-routine that does the bliting. + (let ((fixup (make-fixup 'tail-call-variable :assembly-routine))) + (inst ldil fixup tmp) + (inst be fixup lisp-heap-space tmp :nullify t)))) + + +;;;; Unknown values return: + +;;; Return a single value using the unknown-values convention. +;;; +(define-vop (return-single) + (:args (old-fp :scs (any-reg)) + (return-pc :scs (descriptor-reg)) + (value)) + (:ignore value) + (:vop-var vop) + (:generator 6 + ;; Clear the number stack. + (trace-table-entry trace-table-fun-epilogue) + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (inst move cur-nfp nsp-tn))) + ;; Clear the control stack, and restore the frame pointer. + (move cfp-tn csp-tn) + (move old-fp cfp-tn) + ;; Out of here. + (lisp-return return-pc :offset 1) + (trace-table-entry trace-table-normal))) + +;;; Do unknown-values return of a fixed number of values. The Values are +;;; required to be set up in the standard passing locations. Nvals is the +;;; number of values returned. +;;; +;;; If returning a single value, then deallocate the current frame, restore +;;; FP and jump to the single-value entry at Return-PC + 8. +;;; +;;; If returning other than one value, then load the number of values returned, +;;; NIL out unsupplied values registers, restore FP and return at Return-PC. +;;; When there are stack values, we must initialize the argument pointer to +;;; point to the beginning of the values block (which is the beginning of the +;;; current frame.) +;;; +(define-vop (return) + (:args + (old-fp :scs (any-reg)) + (return-pc :scs (descriptor-reg) :to (:eval 1)) + (values :more t)) + (:ignore values) + (:info nvals) + (:temporary (:sc descriptor-reg :offset a0-offset :from (:eval 0)) a0) + (:temporary (:sc descriptor-reg :offset a1-offset :from (:eval 0)) a1) + (:temporary (:sc descriptor-reg :offset a2-offset :from (:eval 0)) a2) + (:temporary (:sc descriptor-reg :offset a3-offset :from (:eval 0)) a3) + (:temporary (:sc descriptor-reg :offset a4-offset :from (:eval 0)) a4) + (:temporary (:sc descriptor-reg :offset a5-offset :from (:eval 0)) a5) + (:temporary (:sc any-reg :offset nargs-offset) nargs) + (:temporary (:sc any-reg :offset ocfp-offset) val-ptr) + (:vop-var vop) + (:generator 6 + ;; Clear the number stack. + (trace-table-entry trace-table-fun-epilogue) + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (inst move cur-nfp nsp-tn))) + ;; Establish the values pointer and values count. + (move cfp-tn val-ptr) + (inst li (fixnumize nvals) nargs) + ;; restore the frame pointer and clear as much of the control + ;; stack as possible. + (move old-fp cfp-tn) + (inst addi (* nvals n-word-bytes) val-ptr csp-tn) + ;; pre-default any argument register that need it. + (when (< nvals register-arg-count) + (dolist (reg (subseq (list a0 a1 a2 a3 a4 a5) nvals)) + (move null-tn reg))) + ;; And away we go. + (lisp-return return-pc) + (trace-table-entry trace-table-normal))) + +;;; Do unknown-values return of an arbitrary number of values (passed on the +;;; stack.) We check for the common case of a single return value, and do that +;;; inline using the normal single value return convention. Otherwise, we +;;; branch off to code that calls an assembly-routine. +;;; +(define-vop (return-multiple) + (:args + (old-fp-arg :scs (any-reg) :to (:eval 1)) + (lra-arg :scs (descriptor-reg) :to (:eval 1)) + (vals-arg :scs (any-reg) :target vals) + (nvals-arg :scs (any-reg) :target nvals)) + + (:temporary (:sc any-reg :offset nl1-offset :from (:argument 0)) old-fp) + (:temporary (:sc descriptor-reg :offset lra-offset :from (:argument 1)) lra) + (:temporary (:sc any-reg :offset nl0-offset :from (:argument 2)) vals) + (:temporary (:sc any-reg :offset nargs-offset :from (:argument 3)) nvals) + (:temporary (:sc descriptor-reg :offset a0-offset) a0) + (:temporary (:scs (any-reg) :from (:eval 0)) tmp) + + (:vop-var vop) + (:node-var node) + + (:generator 13 + (trace-table-entry trace-table-fun-epilogue) + ;; Clear the number stack. + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (inst move cur-nfp nsp-tn))) + + (unless (policy node (> space speed)) + ;; Check for the single case. + (inst comib :<> (fixnumize 1) nvals-arg not-single) + (loadw a0 vals-arg) + + ;; Return with one value. + (move cfp-tn csp-tn) + (move old-fp-arg cfp-tn) + (lisp-return lra-arg :offset 1)) + + ;; Nope, not the single case. + NOT-SINGLE + (move old-fp-arg old-fp) + (move lra-arg lra) + (move vals-arg vals) + (move nvals-arg nvals) + (let ((fixup (make-fixup 'return-multiple :assembly-routine))) + (inst ldil fixup tmp) + (inst be fixup lisp-heap-space tmp :nullify t)) + (trace-table-entry trace-table-normal))) + + + +;;;; XEP hackery: + +;;; We don't need to do anything special for regular functions. +;;; +(define-vop (setup-environment) + (:info label) + (:ignore label) + (:generator 0 + ;; Don't bother doing anything. + )) + +;;; Get the lexical environment from it's passing location. +;;; +(define-vop (setup-closure-environment) + (:temporary (:sc descriptor-reg :offset lexenv-offset :target closure + :to (:result 0)) + lexenv) + (:results (closure :scs (descriptor-reg))) + (:info label) + (:ignore label) + (:generator 6 + ;; Get result. + (move lexenv closure))) + +;;; Copy a more arg from the argument area to the end of the current frame. +;;; Fixed is the number of non-more arguments. +;;; +(define-vop (copy-more-arg) + (:temporary (:sc any-reg :offset nl0-offset) result) + (:temporary (:sc any-reg :offset nl1-offset) count) + (:temporary (:sc any-reg :offset nl2-offset) src) + (:temporary (:sc any-reg :offset nl3-offset) dst) + (:temporary (:sc descriptor-reg :offset l0-offset) temp) + (:info fixed) + (:generator 20 + ;; Figure out how many things we are going to copy. + (unless (zerop fixed) + (inst addi (- (fixnumize fixed)) nargs-tn count)) + + ;; Blow out of here if is nothing to copy. + (inst comb :<= (if (zerop fixed) nargs-tn count) zero-tn done :nullify t) + + (when (< fixed register-arg-count) + ;; Save a pointer to the results so we can fill in register args. + ;; We don't need this if there are more fixed args than reg args. + (move csp-tn result)) + + ;; Allocate the space on the stack. + (inst add csp-tn (if (zerop fixed) nargs-tn count) csp-tn) + + (when (< fixed register-arg-count) + ;; We must stop when we run out of stack args, not when we run out of + ;; args in general. + (inst addi (fixnumize (- register-arg-count)) nargs-tn count) + ;; Everything of interest in registers. + (inst comb :<= count zero-tn do-regs)) + ;; Initialize dst to be end of stack. + (move csp-tn dst) + + ;; Initialize src to be end of args. + (inst add cfp-tn nargs-tn src) + + LOOP + ;; *--dst = *--src, --count + (inst ldwm (- n-word-bytes) src temp) + (inst addib :> (fixnumize -1) count loop) + (inst stwm temp (- n-word-bytes) dst) + + DO-REGS + (when (< fixed register-arg-count) + ;; Now we have to deposit any more args that showed up in registers. + ;; We know there is at least one more arg, otherwise we would have + ;; branched to done up at the top. + (inst addi (fixnumize (- fixed)) nargs-tn count) + (do ((i fixed (1+ i))) + ((>= i register-arg-count)) + ;; Is this the last one? + (inst addib :<= (fixnumize -1) count done) + ;; Store it relative to the pointer saved at the start. + (storew (nth i register-arg-tns) result (- i fixed)))) + DONE)) + +;;; More args are stored consequtively on the stack, starting immediately at +;;; the context pointer. The context pointer is not typed, so the lowtag is 0. +;;; +(define-full-reffer more-arg * 0 0 (descriptor-reg any-reg) * %more-arg) + + +;;; Turn more arg (context, count) into a list. +;;; +(define-vop (listify-rest-args) + (:args (context-arg :target context :scs (descriptor-reg)) + (count-arg :target count :scs (any-reg))) + (:arg-types * tagged-num) + (:temporary (:scs (any-reg) :from (:argument 0)) context) + (:temporary (:scs (any-reg) :from (:argument 1)) count) + (:temporary (:scs (descriptor-reg) :from :eval) temp) + (:temporary (:scs (non-descriptor-reg) :from :eval) dst) + (:results (result :scs (descriptor-reg))) + (:translate %listify-rest-args) + (:policy :safe) + (:generator 20 + (move context-arg context) + (move count-arg count) + ;; Check to see if there are any arguments. + (inst comb := count zero-tn done) + (move null-tn result) + + ;; We need to do this atomically. + (pseudo-atomic () + (assemble () + ;; Allocate a cons (2 words) for each item. + (inst move alloc-tn result) + (inst dep list-pointer-lowtag 31 3 result) + (move result dst) + (inst sll count 1 temp) + (inst add alloc-tn temp alloc-tn) + + LOOP + ;; Grab one value and stash it in the car of this cons. + (inst ldwm n-word-bytes context temp) + (storew temp dst 0 list-pointer-lowtag) + + ;; Dec count, and if != zero, go back for more. + (inst addi (* 2 n-word-bytes) dst dst) + (inst addib :> (fixnumize -1) count loop :nullify t) + (storew dst dst -1 list-pointer-lowtag) + + ;; NIL out the last cons. + (storew null-tn dst -1 list-pointer-lowtag) + ;; Clear out dst, because it points past the last cons. + (move null-tn dst))) + DONE)) + +;;; Return the location and size of the more arg glob created by Copy-More-Arg. +;;; Supplied is the total number of arguments supplied (originally passed in +;;; NARGS.) Fixed is the number of non-rest arguments. +;;; +;;; We must duplicate some of the work done by Copy-More-Arg, since at that +;;; time the environment is in a pretty brain-damaged state, preventing this +;;; info from being returned as values. What we do is compute +;;; supplied - fixed, and return a pointer that many words below the current +;;; stack top. +;;; + +;;; WTF? FIXME -- CSR +;;;(setf (info function source-transform 'c::%more-arg-context) nil) +;;; +(define-vop (more-arg-context) + (:policy :fast-safe) + (:translate sb!c::%more-arg-context) + (:args (supplied :scs (any-reg))) + (:arg-types tagged-num (:constant fixnum)) + (:info fixed) + (:results (context :scs (descriptor-reg)) + (count :scs (any-reg))) + (:result-types t tagged-num) + (:note "more-arg-context") + (:generator 5 + (inst addi (fixnumize (- fixed)) supplied count) + (inst sub csp-tn count context))) + + +;;; Signal wrong argument count error if Nargs isn't = to Count. +;;; +(define-vop (verify-arg-count) + (:policy :fast-safe) + (:translate sb!c::%verify-arg-count) + (:args (nargs :scs (any-reg))) + (:arg-types positive-fixnum (:constant t)) + (:info count) + (:vop-var vop) + (:save-p :compute-only) + (:generator 3 + (let ((err-lab + (generate-error-code vop invalid-arg-count-error nargs))) + (cond ((zerop count) + (inst bc :<> nil nargs zero-tn err-lab)) + (t + (inst bci :<> nil (fixnumize count) nargs err-lab)))))) + +;;; Signal an argument count error. +;;; +(macrolet ((frob (name error translate &rest args) + `(define-vop (,name) + ,@(when translate + `((:policy :fast-safe) + (:translate ,translate))) + (:args ,@(mapcar #'(lambda (arg) + `(,arg :scs (any-reg descriptor-reg))) + args)) + (:vop-var vop) + (:save-p :compute-only) + (:generator 1000 + (error-call vop ,error ,@args))))) + (frob arg-count-error invalid-arg-count-error + sb!c::%arg-count-error nargs) + (frob type-check-error object-not-type-error sb!c::%type-check-error + object type) + (frob layout-invalid-error layout-invalid-error sb!c::%layout-invalid-error + object layout) + (frob odd-key-args-error odd-key-args-error + sb!c::%odd-key-args-error) + (frob unknown-key-arg-error unknown-key-arg-error + sb!c::%unknown-key-arg-error key) + (frob nil-fun-returned-error nil-fun-returned-error nil fun)) diff --git a/src/compiler/hppa/cell.lisp b/src/compiler/hppa/cell.lisp new file mode 100644 index 0000000..50df91a --- /dev/null +++ b/src/compiler/hppa/cell.lisp @@ -0,0 +1,253 @@ +(in-package "SB!VM") + + +;;;; Data object ref/set stuff. + +(define-vop (slot) + (:args (object :scs (descriptor-reg))) + (:info name offset lowtag) + (:ignore name) + (:results (result :scs (descriptor-reg any-reg))) + (:generator 1 + (loadw result object offset lowtag))) + +(define-vop (set-slot) + (:args (object :scs (descriptor-reg)) + (value :scs (descriptor-reg any-reg))) + (:info name offset lowtag) + (:ignore name) + (:results) + (:generator 1 + (storew value object offset lowtag))) + + + +;;;; Symbol hacking VOPs: + +;;; The compiler likes to be able to directly SET symbols. +;;; +(define-vop (set cell-set) + (:variant symbol-value-slot other-pointer-lowtag)) + +;;; Do a cell ref with an error check for being unbound. +;;; +(define-vop (checked-cell-ref) + (:args (object :scs (descriptor-reg) :target obj-temp)) + (:results (value :scs (descriptor-reg any-reg))) + (:policy :fast-safe) + (:vop-var vop) + (:save-p :compute-only) + (:temporary (:type random :scs (non-descriptor-reg)) temp) + (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp)) + +;;; With Symbol-Value, we check that the value isn't the trap object. So +;;; Symbol-Value of NIL is NIL. +;;; +(define-vop (symbol-value checked-cell-ref) + (:translate symbol-value) + (:generator 9 + (move object obj-temp) + (loadw value obj-temp symbol-value-slot other-pointer-lowtag) + (let ((err-lab (generate-error-code vop unbound-symbol-error obj-temp))) + (inst li unbound-marker-widetag temp) + (inst bc := nil value temp err-lab)))) + +;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell is bound. +(define-vop (boundp-frob) + (:args (object :scs (descriptor-reg))) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:temporary (:scs (descriptor-reg)) value) + (:temporary (:type random :scs (non-descriptor-reg)) temp)) + +(define-vop (boundp boundp-frob) + (:translate boundp) + (:generator 9 + (loadw value object symbol-value-slot other-pointer-lowtag) + (inst li unbound-marker-widetag temp) + (inst bc :<> not-p value temp target))) + +(define-vop (fast-symbol-value cell-ref) + (:variant symbol-value-slot other-pointer-lowtag) + (:policy :fast) + (:translate symbol-value)) + + + +;;;; Fdefinition (fdefn) objects. + +(define-vop (fdefn-fun cell-ref) + (:variant fdefn-fun-slot other-pointer-lowtag)) + +(define-vop (safe-fdefn-fun) + (:args (object :scs (descriptor-reg) :target obj-temp)) + (:results (value :scs (descriptor-reg any-reg))) + (:vop-var vop) + (:save-p :compute-only) + (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp) + (:generator 10 + (move obj-temp object) + (loadw value obj-temp fdefn-fun-slot other-pointer-lowtag) + (let ((err-lab (generate-error-code vop undefined-fun-error obj-temp))) + (inst bc := nil value null-tn err-lab)))) + +(define-vop (set-fdefn-fun) + (:policy :fast-safe) + (:translate (setf fdefn-fun)) + (:args (function :scs (descriptor-reg) :target result) + (fdefn :scs (descriptor-reg))) + (:temporary (:scs (interior-reg)) lip) + (:temporary (:scs (non-descriptor-reg)) type) + (:results (result :scs (descriptor-reg))) + (:generator 38 + (load-type type function (- fun-pointer-lowtag)) + (inst addi (- simple-fun-header-widetag) type type) + (inst comb := type zero-tn normal-fn) + (inst addi (- (ash simple-fun-code-offset word-shift) fun-pointer-lowtag) + function lip) + (inst li (make-fixup "closure_tramp" :foreign) lip) + NORMAL-FN + (storew function fdefn fdefn-fun-slot other-pointer-lowtag) + (storew lip fdefn fdefn-raw-addr-slot other-pointer-lowtag) + (move function result))) + +(define-vop (fdefn-makunbound) + (:policy :fast-safe) + (:translate fdefn-makunbound) + (:args (fdefn :scs (descriptor-reg) :target result)) + (:temporary (:scs (non-descriptor-reg)) temp) + (:results (result :scs (descriptor-reg))) + (:generator 38 + (storew null-tn fdefn fdefn-fun-slot other-pointer-lowtag) + (inst li (make-fixup "undefined_tramp" :foreign) temp) + (storew temp fdefn fdefn-raw-addr-slot other-pointer-lowtag) + (move fdefn result))) + + + +;;;; Binding and Unbinding. + +;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and +;;; the symbol on the binding stack and stuff the new value into the +;;; symbol. + +(define-vop (bind) + (:args (val :scs (any-reg descriptor-reg)) + (symbol :scs (descriptor-reg))) + (:temporary (:scs (descriptor-reg)) temp) + (:generator 5 + (loadw temp symbol symbol-value-slot other-pointer-lowtag) + (inst addi (* binding-size n-word-bytes) bsp-tn bsp-tn) + (storew temp bsp-tn (- binding-value-slot binding-size)) + (storew symbol bsp-tn (- binding-symbol-slot binding-size)) + (storew val symbol symbol-value-slot other-pointer-lowtag))) + +(define-vop (unbind) + (:temporary (:scs (descriptor-reg)) symbol value) + (:generator 0 + (loadw symbol bsp-tn (- binding-symbol-slot binding-size)) + (loadw value bsp-tn (- binding-value-slot binding-size)) + (storew value symbol symbol-value-slot other-pointer-lowtag) + (storew zero-tn bsp-tn (- binding-symbol-slot binding-size)) + (inst addi (- (* binding-size n-word-bytes)) bsp-tn bsp-tn))) + +(define-vop (unbind-to-here) + (:args (where :scs (descriptor-reg any-reg))) + (:temporary (:scs (descriptor-reg)) symbol value) + (:generator 0 + (inst comb := where bsp-tn done :nullify t) + (loadw symbol bsp-tn (- binding-symbol-slot binding-size)) + + LOOP + (inst comb := symbol zero-tn skip) + (loadw value bsp-tn (- binding-value-slot binding-size)) + (storew value symbol symbol-value-slot other-pointer-lowtag) + (storew zero-tn bsp-tn (- binding-symbol-slot binding-size)) + + SKIP + (inst addi (* -2 n-word-bytes) bsp-tn bsp-tn) + (inst comb :<> where bsp-tn loop :nullify t) + (loadw symbol bsp-tn (- binding-symbol-slot binding-size)) + + DONE)) + + + +;;;; Closure indexing. + +(define-full-reffer closure-index-ref * + closure-info-offset fun-pointer-lowtag + (descriptor-reg any-reg) * %closure-index-ref) + +(define-full-setter set-funcallable-instance-info * + funcallable-instance-info-offset fun-pointer-lowtag + (descriptor-reg any-reg) * %set-funcallable-instance-info) + +(define-full-reffer funcallable-instance-info * + funcallable-instance-info-offset fun-pointer-lowtag + (descriptor-reg any-reg) * %funcallable-instance-info) + +(define-vop (funcallable-instance-lexenv cell-ref) + (:variant funcallable-instance-lexenv-slot fun-pointer-lowtag)) + + +(define-vop (closure-ref slot-ref) + (:variant closure-info-offset fun-pointer-lowtag)) + +(define-vop (closure-init slot-set) + (:variant closure-info-offset fun-pointer-lowtag)) + + + +;;;; Value Cell hackery. + +(define-vop (value-cell-ref cell-ref) + (:variant value-cell-value-slot other-pointer-lowtag)) + +(define-vop (value-cell-set cell-set) + (:variant value-cell-value-slot other-pointer-lowtag)) + + + +;;;; Instance hackery: + +(define-vop (instance-length) + (:policy :fast-safe) + (:translate %instance-length) + (:args (struct :scs (descriptor-reg))) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 4 + (loadw res struct 0 instance-pointer-lowtag) + (inst srl res n-widetag-bits res))) + +(define-vop (instance-ref slot-ref) + (:variant instance-slots-offset instance-pointer-lowtag) + (:policy :fast-safe) + (:translate %instance-ref) + (:arg-types instance (:constant index))) + +#+nil ; As per usual (cf sbcl-devel discussion about this VOP which + ; appears to return no values) +(define-vop (instance-set slot-set) + (:policy :fast-safe) + (:translate %instance-set) + (:variant instance-slots-offset instance-pointer-lowtag) + (:arg-types instance (:constant index) *)) + +(define-full-reffer instance-index-ref * instance-slots-offset + instance-pointer-lowtag (descriptor-reg any-reg) * %instance-ref) + +(define-full-setter instance-index-set * instance-slots-offset + instance-pointer-lowtag (descriptor-reg any-reg) * %instance-set) + + + +;;;; Code object frobbing. + +(define-full-reffer code-header-ref * 0 other-pointer-lowtag + (descriptor-reg any-reg) * code-header-ref) + +(define-full-setter code-header-set * 0 other-pointer-lowtag + (descriptor-reg any-reg) * code-header-set) diff --git a/src/compiler/hppa/char.lisp b/src/compiler/hppa/char.lisp new file mode 100644 index 0000000..469d896 --- /dev/null +++ b/src/compiler/hppa/char.lisp @@ -0,0 +1,120 @@ +(in-package "SB!VM") + + +;;;; Moves and coercions: + +;;; Move a tagged char to an untagged representation. +;;; +(define-vop (move-to-base-char) + (:args (x :scs (any-reg descriptor-reg))) + (:results (y :scs (base-char-reg))) + (:generator 1 + (inst srl x n-widetag-bits y))) +;;; +(define-move-vop move-to-base-char :move + (any-reg descriptor-reg) (base-char-reg)) + +;;; Move an untagged char to a tagged representation. +;;; +(define-vop (move-from-base-char) + (:args (x :scs (base-char-reg))) + (:results (y :scs (any-reg descriptor-reg))) + (:generator 1 + (inst sll x n-widetag-bits y) + (inst addi base-char-widetag y y))) +;;; +(define-move-vop move-from-base-char :move + (base-char-reg) (any-reg descriptor-reg)) + +;;; Move untagged base-char values. +;;; +(define-vop (base-char-move) + (:args (x :target y + :scs (base-char-reg) + :load-if (not (location= x y)))) + (:results (y :scs (base-char-reg) + :load-if (not (location= x y)))) + (:effects) + (:affected) + (:generator 0 + (move x y))) +;;; +(define-move-vop base-char-move :move + (base-char-reg) (base-char-reg)) + + +;;; Move untagged base-char arguments/return-values. +;;; +(define-vop (move-base-char-argument) + (:args (x :target y + :scs (base-char-reg)) + (fp :scs (any-reg) + :load-if (not (sc-is y base-char-reg)))) + (:results (y)) + (:generator 0 + (sc-case y + (base-char-reg + (move x y)) + (base-char-stack + (storew x fp (tn-offset y)))))) +;;; +(define-move-vop move-base-char-argument :move-arg + (any-reg base-char-reg) (base-char-reg)) + + +;;; Use standard MOVE-ARGUMENT + coercion to move an untagged base-char +;;; to a descriptor passing location. +;;; +(define-move-vop move-argument :move-arg + (base-char-reg) (any-reg descriptor-reg)) + + + +;;;; Other operations: + +(define-vop (char-code) + (:translate char-code) + (:policy :fast-safe) + (:args (ch :scs (base-char-reg) :target res)) + (:arg-types base-char) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 1 + (move ch res))) + +(define-vop (code-char) + (:translate code-char) + (:policy :fast-safe) + (:args (code :scs (unsigned-reg) :target res)) + (:arg-types positive-fixnum) + (:results (res :scs (base-char-reg))) + (:result-types base-char) + (:generator 1 + (move code res))) + + +;;; Comparison of base-chars. +;;; +(define-vop (base-char-compare) + (:args (x :scs (base-char-reg)) + (y :scs (base-char-reg))) + (:arg-types base-char base-char) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:note "inline comparison") + (:variant-vars cond) + (:generator 3 + (inst bc cond not-p x y target))) + +(define-vop (fast-char=/base-char base-char-compare) + (:translate char=) + (:variant :=)) + +(define-vop (fast-char/base-char base-char-compare) + (:translate char>) + (:variant :>>)) diff --git a/src/compiler/hppa/debug.lisp b/src/compiler/hppa/debug.lisp new file mode 100644 index 0000000..51f912a --- /dev/null +++ b/src/compiler/hppa/debug.lisp @@ -0,0 +1,121 @@ +(in-package "SB!VM") + + +(define-vop (debug-cur-sp) + (:translate current-sp) + (:policy :fast-safe) + (:results (res :scs (sap-reg))) + (:result-types system-area-pointer) + (:generator 1 + (move csp-tn res))) + +(define-vop (debug-cur-fp) + (:translate current-fp) + (:policy :fast-safe) + (:results (res :scs (sap-reg))) + (:result-types system-area-pointer) + (:generator 1 + (move cfp-tn res))) + +(define-vop (read-control-stack) + (:translate stack-ref) + (:policy :fast-safe) + (:args (object :scs (sap-reg)) + (offset :scs (any-reg))) + (:arg-types system-area-pointer positive-fixnum) + (:results (result :scs (descriptor-reg))) + (:result-types *) + (:generator 5 + (inst ldwx offset object result))) + +(define-vop (read-control-stack-c) + (:translate stack-ref) + (:policy :fast-safe) + (:args (object :scs (sap-reg))) + (:info offset) + (:arg-types system-area-pointer (:constant (signed-byte 12))) + (:results (result :scs (descriptor-reg))) + (:result-types *) + (:generator 4 + (inst ldw (* offset n-word-bytes) object result))) + +(define-vop (write-control-stack) + (:translate %set-stack-ref) + (:policy :fast-safe) + (:args (object :scs (sap-reg) :target sap) + (offset :scs (any-reg)) + (value :scs (descriptor-reg) :target result)) + (:arg-types system-area-pointer positive-fixnum *) + (:results (result :scs (descriptor-reg))) + (:result-types *) + (:temporary (:scs (sap-reg) :from (:argument 1)) sap) + (:generator 2 + (inst add object offset sap) + (inst stw value 0 sap) + (move value result))) + +(define-vop (write-control-stack-c) + (:translate %set-stack-ref) + (:policy :fast-safe) + (:args (sap :scs (sap-reg)) + (value :scs (descriptor-reg) :target result)) + (:info offset) + (:arg-types system-area-pointer (:constant (signed-byte 12)) *) + (:results (result :scs (descriptor-reg))) + (:result-types *) + (:generator 1 + (inst stw value (* offset n-word-bytes) sap) + (move value result))) + +(define-vop (code-from-mumble) + (:policy :fast-safe) + (:args (thing :scs (descriptor-reg) :to :save)) + (:results (code :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) temp) + (:variant-vars lowtag) + (:generator 5 + (loadw temp thing 0 lowtag) + (inst srl temp n-widetag-bits temp) + (inst comb := zero-tn temp done) + (move null-tn code) + (inst sll temp (1- (integer-length n-word-bytes)) temp) + (unless (= lowtag other-pointer-lowtag) + (inst addi (- lowtag other-pointer-lowtag) temp temp)) + (inst sub thing temp code) + DONE)) + +(define-vop (code-from-lra code-from-mumble) + (:translate lra-code-header) + (:variant other-pointer-lowtag)) + +(define-vop (code-from-fun code-from-mumble) + (:translate fun-code-header) + (:variant fun-pointer-lowtag)) + +(define-vop (make-lisp-obj) + (:policy :fast-safe) + (:translate make-lisp-obj) + (:args (value :scs (unsigned-reg) :target result)) + (:arg-types unsigned-num) + (:results (result :scs (descriptor-reg))) + (:generator 1 + (move value result))) + +(define-vop (get-lisp-obj-address) + (:policy :fast-safe) + (:translate get-lisp-obj-address) + (:args (thing :scs (descriptor-reg) :target result)) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 1 + (move thing result))) + +(define-vop (fun-word-offset) + (:policy :fast-safe) + (:translate fun-word-offset) + (:args (fun :scs (descriptor-reg))) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 5 + (loadw res fun 0 fun-pointer-lowtag) + (inst srl res n-widetag-bits res))) diff --git a/src/compiler/hppa/float.lisp b/src/compiler/hppa/float.lisp new file mode 100644 index 0000000..6a0fcf4 --- /dev/null +++ b/src/compiler/hppa/float.lisp @@ -0,0 +1,930 @@ +(in-package "SB!VM") + + +;;;; Move functions. + +(define-move-fun (load-fp-zero 1) (vop x y) + ((fp-single-zero) (single-reg) + (fp-double-zero) (double-reg)) + (inst funop :copy x y)) + +(defun ld-float (offset base r) + (cond ((< offset (ash 1 4)) + (inst flds offset base r)) + (t + (inst ldo offset zero-tn lip-tn) + (inst fldx lip-tn base r)))) + +(define-move-fun (load-float 1) (vop x y) + ((single-stack) (single-reg) + (double-stack) (double-reg)) + (let ((offset (* (tn-offset x) n-word-bytes))) + (ld-float offset (current-nfp-tn vop) y))) + +(defun str-float (x offset base) + (cond ((< offset (ash 1 4)) + (inst fsts x offset base)) + (t + (inst ldo offset zero-tn lip-tn) + (inst fstx x lip-tn base)))) + +(define-move-fun (store-float 1) (vop x y) + ((single-reg) (single-stack) + (double-reg) (double-stack)) + (let ((offset (* (tn-offset y) n-word-bytes))) + (str-float x offset (current-nfp-tn vop)))) + + +;;;; Move VOPs + +(define-vop (move-float) + (:args (x :scs (single-reg double-reg) + :target y + :load-if (not (location= x y)))) + (:results (y :scs (single-reg double-reg) + :load-if (not (location= x y)))) + (:note "float move") + (:generator 0 + (unless (location= y x) + (inst funop :copy x y)))) + +(define-move-vop move-float :move (single-reg) (single-reg)) +(define-move-vop move-float :move (double-reg) (double-reg)) + + +(define-vop (move-from-float) + (:args (x :to :save)) + (:results (y :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:variant-vars size type data) + (:note "float to pointer coercion") + (:generator 13 + (with-fixed-allocation (y ndescr type size)) + (inst fsts x (- (* data n-word-bytes) other-pointer-lowtag) y))) + +(macrolet ((frob (name sc &rest args) + `(progn + (define-vop (,name move-from-float) + (:args (x :scs (,sc) :to :save)) + (:variant ,@args)) + (define-move-vop ,name :move (,sc) (descriptor-reg))))) + (frob move-from-single single-reg + single-float-size single-float-widetag single-float-value-slot) + (frob move-from-double double-reg + double-float-size double-float-widetag double-float-value-slot)) + +(define-vop (move-to-float) + (:args (x :scs (descriptor-reg))) + (:results (y)) + (:variant-vars offset) + (:note "pointer to float coercion") + (:generator 2 + (inst flds (- (* offset n-word-bytes) other-pointer-lowtag) x y))) + +(macrolet ((frob (name sc offset) + `(progn + (define-vop (,name move-to-float) + (:results (y :scs (,sc))) + (:variant ,offset)) + (define-move-vop ,name :move (descriptor-reg) (,sc))))) + (frob move-to-single single-reg single-float-value-slot) + (frob move-to-double double-reg double-float-value-slot)) + + +(define-vop (move-float-argument) + (:args (x :scs (single-reg double-reg) :target y) + (nfp :scs (any-reg) + :load-if (not (sc-is y single-reg double-reg)))) + (:results (y)) + (:note "float argument move") + (:generator 1 + (sc-case y + ((single-reg double-reg) + (unless (location= x y) + (inst funop :copy x y))) + ((single-stack double-stack) + (let ((offset (* (tn-offset y) n-word-bytes))) + (str-float x offset nfp)))))) + +(define-move-vop move-float-argument :move-arg + (single-reg descriptor-reg) (single-reg)) +(define-move-vop move-float-argument :move-arg + (double-reg descriptor-reg) (double-reg)) + + +;;;; Complex float move functions + +(defun complex-single-reg-real-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg) + :offset (tn-offset x))) +(defun complex-single-reg-imag-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg) + :offset (1+ (tn-offset x)))) + +(defun complex-double-reg-real-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg) + :offset (tn-offset x))) +(defun complex-double-reg-imag-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg) + :offset (1+ (tn-offset x)))) + + +(define-move-fun (load-complex-single 2) (vop x y) + ((complex-single-stack) (complex-single-reg)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset x) n-word-bytes))) + (let ((real-tn (complex-single-reg-real-tn y))) + (ld-float offset nfp real-tn)) + (let ((imag-tn (complex-single-reg-imag-tn y))) + (ld-float (+ offset n-word-bytes) nfp imag-tn)))) + +(define-move-fun (store-complex-single 2) (vop x y) + ((complex-single-reg) (complex-single-stack)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset y) n-word-bytes))) + (let ((real-tn (complex-single-reg-real-tn x))) + (str-float real-tn offset nfp)) + (let ((imag-tn (complex-single-reg-imag-tn x))) + (str-float imag-tn (+ offset n-word-bytes) nfp)))) + + +(define-move-fun (load-complex-double 4) (vop x y) + ((complex-double-stack) (complex-double-reg)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset x) n-word-bytes))) + (let ((real-tn (complex-double-reg-real-tn y))) + (ld-float offset nfp real-tn)) + (let ((imag-tn (complex-double-reg-imag-tn y))) + (ld-float (+ offset (* 2 n-word-bytes)) nfp imag-tn)))) + +(define-move-fun (store-complex-double 4) (vop x y) + ((complex-double-reg) (complex-double-stack)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset y) n-word-bytes))) + (let ((real-tn (complex-double-reg-real-tn x))) + (str-float real-tn offset nfp)) + (let ((imag-tn (complex-double-reg-imag-tn x))) + (str-float imag-tn (+ offset (* 2 n-word-bytes)) nfp)))) + +;;; +;;; Complex float register to register moves. +;;; +(define-vop (complex-single-move) + (:args (x :scs (complex-single-reg) :target y + :load-if (not (location= x y)))) + (:results (y :scs (complex-single-reg) :load-if (not (location= x y)))) + (:note "complex single float move") + (:generator 0 + (unless (location= x y) + ;; Note the complex-float-regs are aligned to every second + ;; float register so there is not need to worry about overlap. + (let ((x-real (complex-single-reg-real-tn x)) + (y-real (complex-single-reg-real-tn y))) + (inst funop :copy x-real y-real)) + (let ((x-imag (complex-single-reg-imag-tn x)) + (y-imag (complex-single-reg-imag-tn y))) + (inst funop :copy x-imag y-imag))))) +;;; +(define-move-vop complex-single-move :move + (complex-single-reg) (complex-single-reg)) + +(define-vop (complex-double-move) + (:args (x :scs (complex-double-reg) + :target y :load-if (not (location= x y)))) + (:results (y :scs (complex-double-reg) :load-if (not (location= x y)))) + (:note "complex double float move") + (:generator 0 + (unless (location= x y) + ;; Note the complex-float-regs are aligned to every second + ;; float register so there is not need to worry about overlap. + (let ((x-real (complex-double-reg-real-tn x)) + (y-real (complex-double-reg-real-tn y))) + (inst funop :copy x-real y-real)) + (let ((x-imag (complex-double-reg-imag-tn x)) + (y-imag (complex-double-reg-imag-tn y))) + (inst funop :copy x-imag y-imag))))) +;;; +(define-move-vop complex-double-move :move + (complex-double-reg) (complex-double-reg)) + +;;; +;;; Move from a complex float to a descriptor register allocating a +;;; new complex float object in the process. +;;; +(define-vop (move-from-complex-single) + (:args (x :scs (complex-single-reg) :to :save)) + (:results (y :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:note "complex single float to pointer coercion") + (:generator 13 + (with-fixed-allocation (y ndescr complex-single-float-widetag + complex-single-float-size)) + (let ((real-tn (complex-single-reg-real-tn x))) + (inst fsts real-tn (- (* complex-single-float-real-slot n-word-bytes) + other-pointer-lowtag) + y)) + (let ((imag-tn (complex-single-reg-imag-tn x))) + (inst fsts imag-tn (- (* complex-single-float-imag-slot n-word-bytes) + other-pointer-lowtag) + y)))) +;;; +(define-move-vop move-from-complex-single :move + (complex-single-reg) (descriptor-reg)) + +(define-vop (move-from-complex-double) + (:args (x :scs (complex-double-reg) :to :save)) + (:results (y :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:note "complex double float to pointer coercion") + (:generator 13 + (with-fixed-allocation (y ndescr complex-double-float-widetag + complex-double-float-size)) + (let ((real-tn (complex-double-reg-real-tn x))) + (inst fsts real-tn (- (* complex-double-float-real-slot n-word-bytes) + other-pointer-lowtag) + y)) + (let ((imag-tn (complex-double-reg-imag-tn x))) + (inst fsts imag-tn (- (* complex-double-float-imag-slot n-word-bytes) + other-pointer-lowtag) + y)))) +;;; +(define-move-vop move-from-complex-double :move + (complex-double-reg) (descriptor-reg)) + +;;; +;;; Move from a descriptor to a complex float register +;;; +(define-vop (move-to-complex-single) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (complex-single-reg))) + (:note "pointer to complex float coercion") + (:generator 2 + (let ((real-tn (complex-single-reg-real-tn y))) + (inst flds (- (* complex-single-float-real-slot n-word-bytes) + other-pointer-lowtag) + x real-tn)) + (let ((imag-tn (complex-single-reg-imag-tn y))) + (inst flds (- (* complex-single-float-imag-slot n-word-bytes) + other-pointer-lowtag) + x imag-tn)))) +(define-move-vop move-to-complex-single :move + (descriptor-reg) (complex-single-reg)) + +(define-vop (move-to-complex-double) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (complex-double-reg))) + (:note "pointer to complex float coercion") + (:generator 2 + (let ((real-tn (complex-double-reg-real-tn y))) + (inst flds (- (* complex-double-float-real-slot n-word-bytes) + other-pointer-lowtag) + x real-tn)) + (let ((imag-tn (complex-double-reg-imag-tn y))) + (inst flds (- (* complex-double-float-imag-slot n-word-bytes) + other-pointer-lowtag) + x imag-tn)))) +(define-move-vop move-to-complex-double :move + (descriptor-reg) (complex-double-reg)) + +;;; +;;; Complex float move-argument vop +;;; +(define-vop (move-complex-single-float-argument) + (:args (x :scs (complex-single-reg) :target y) + (nfp :scs (any-reg) :load-if (not (sc-is y complex-single-reg)))) + (:results (y)) + (:note "float argument move") + (:generator 1 + (sc-case y + (complex-single-reg + (unless (location= x y) + (let ((x-real (complex-single-reg-real-tn x)) + (y-real (complex-single-reg-real-tn y))) + (inst funop :copy x-real y-real)) + (let ((x-imag (complex-single-reg-imag-tn x)) + (y-imag (complex-single-reg-imag-tn y))) + (inst funop :copy x-imag y-imag)))) + (complex-single-stack + (let ((offset (* (tn-offset y) n-word-bytes))) + (let ((real-tn (complex-single-reg-real-tn x))) + (str-float real-tn offset nfp)) + (let ((imag-tn (complex-single-reg-imag-tn x))) + (str-float imag-tn (+ offset n-word-bytes) nfp))))))) +;;; +(define-move-vop move-complex-single-float-argument :move-arg + (complex-single-reg descriptor-reg) (complex-single-reg)) + +(define-vop (move-complex-double-float-argument) + (:args (x :scs (complex-double-reg) :target y) + (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-reg)))) + (:results (y)) + (:note "float argument move") + (:generator 1 + (sc-case y + (complex-double-reg + (unless (location= x y) + (let ((x-real (complex-double-reg-real-tn x)) + (y-real (complex-double-reg-real-tn y))) + (inst funop :copy x-real y-real)) + (let ((x-imag (complex-double-reg-imag-tn x)) + (y-imag (complex-double-reg-imag-tn y))) + (inst funop :copy x-imag y-imag)))) + (complex-double-stack + (let ((offset (* (tn-offset y) n-word-bytes))) + (let ((real-tn (complex-double-reg-real-tn x))) + (str-float real-tn offset nfp)) + (let ((imag-tn (complex-double-reg-imag-tn x))) + (str-float imag-tn (+ offset (* 2 n-word-bytes)) nfp))))))) +;;; +(define-move-vop move-complex-double-float-argument :move-arg + (complex-double-reg descriptor-reg) (complex-double-reg)) + + +(define-move-vop move-argument :move-arg + (single-reg double-reg complex-single-reg complex-double-reg) + (descriptor-reg)) + + +;;;; Arithmetic VOPs. + +(define-vop (float-op) + (:args (x) (y)) + (:results (r)) + (:variant-vars operation) + (:policy :fast-safe) + (:note "inline float arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:node-var node) + (:generator 0 + (inst fbinop operation x y r) + (when (policy node (or (= debug 3) (> safety speed))) + (note-next-instruction vop :internal-error) + (inst fsts fp-single-zero-tn 0 csp-tn)))) + +(macrolet ((frob (name sc zero-sc ptype) + `(define-vop (,name float-op) + (:args (x :scs (,sc ,zero-sc)) + (y :scs (,sc ,zero-sc))) + (:results (r :scs (,sc))) + (:arg-types ,ptype ,ptype) + (:result-types ,ptype)))) + (frob single-float-op single-reg fp-single-zero single-float) + (frob double-float-op double-reg fp-double-zero double-float)) + +(macrolet ((frob (translate op sname scost dname dcost) + `(progn + (define-vop (,sname single-float-op) + (:translate ,translate) + (:variant ,op) + (:variant-cost ,scost)) + (define-vop (,dname double-float-op) + (:translate ,translate) + (:variant ,op) + (:variant-cost ,dcost))))) + (frob + :add +/single-float 2 +/double-float 2) + (frob - :sub -/single-float 2 -/double-float 2) + (frob * :mpy */single-float 4 */double-float 5) + (frob / :div //single-float 12 //double-float 19)) + + +(macrolet ((frob (name translate sc type inst) + `(define-vop (,name) + (:args (x :scs (,sc))) + (:results (y :scs (,sc))) + (:translate ,translate) + (:policy :fast-safe) + (:arg-types ,type) + (:result-types ,type) + (:note "inline float arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:node-var node) + (:generator 1 + ,inst + (when (policy node (or (= debug 3) (> safety speed))) + (note-next-instruction vop :internal-error) + (inst fsts fp-single-zero-tn 0 csp-tn)))))) + (frob abs/single-float abs single-reg single-float + (inst funop :abs x y)) + (frob abs/double-float abs double-reg double-float + (inst funop :abs x y)) + (frob %negate/single-float %negate single-reg single-float + (inst fbinop :sub fp-single-zero-tn x y)) + (frob %negate/double-float %negate double-reg double-float + (inst fbinop :sub fp-double-zero-tn x y))) + + +;;;; Comparison: + +(define-vop (float-compare) + (:args (x) (y)) + (:conditional) + (:info target not-p) + (:variant-vars condition complement) + (:policy :fast-safe) + (:note "inline float comparison") + (:vop-var vop) + (:save-p :compute-only) + (:generator 3 + ;; This is the condition to nullify the branch, so it is inverted. + (inst fcmp (if not-p condition complement) x y) + (note-next-instruction vop :internal-error) + (inst ftest) + (inst b target :nullify t))) + +(macrolet ((frob (name sc zero-sc ptype) + `(define-vop (,name float-compare) + (:args (x :scs (,sc ,zero-sc)) + (y :scs (,sc ,zero-sc))) + (:arg-types ,ptype ,ptype)))) + (frob single-float-compare single-reg fp-single-zero single-float) + (frob double-float-compare double-reg fp-double-zero double-float)) + +(macrolet ((frob (translate condition complement sname dname) + `(progn + (define-vop (,sname single-float-compare) + (:translate ,translate) + (:variant ,condition ,complement)) + (define-vop (,dname double-float-compare) + (:translate ,translate) + (:variant ,condition ,complement))))) + (frob < #b01001 #b10101 #b10001 #b01101 >/single-float >/double-float) + (frob = #b00101 #b11001 eql/single-float eql/double-float)) + + +;;;; Conversion: + +(macrolet ((frob (name translate from-sc from-type to-sc to-type) + `(define-vop (,name) + (:args (x :scs (,from-sc))) + (:results (y :scs (,to-sc))) + (:arg-types ,from-type) + (:result-types ,to-type) + (:policy :fast-safe) + (:note "inline float coercion") + (:translate ,translate) + (:vop-var vop) + (:save-p :compute-only) + (:node-var node) + (:generator 2 + (inst fcnvff x y) + (when (policy node (or (= debug 3) (> safety speed))) + (note-next-instruction vop :internal-error) + (inst fsts fp-single-zero-tn 0 csp-tn)))))) + (frob %single-float/double-float %single-float + double-reg double-float + single-reg single-float) + (frob %double-float/single-float %double-float + single-reg single-float + double-reg double-float)) + +(macrolet ((frob (name translate to-sc to-type) + `(define-vop (,name) + (:args (x :scs (signed-reg) + :load-if (not (sc-is x signed-stack)) + :target stack-temp)) + (:arg-types signed-num) + (:results (y :scs (,to-sc))) + (:result-types ,to-type) + (:policy :fast-safe) + (:note "inline float coercion") + (:translate ,translate) + (:vop-var vop) + (:save-p :compute-only) + (:node-var node) + (:temporary (:scs (signed-stack) :from (:argument 0)) + stack-temp) + (:temporary (:scs (single-reg) :to (:result 0) :target y) + fp-temp) + (:temporary (:scs (any-reg) :from (:argument 0) + :to (:result 0)) index) + (:generator 5 + (let* ((nfp (current-nfp-tn vop)) + (stack-tn + (sc-case x + (signed-stack + x) + (signed-reg + (storew x nfp (tn-offset stack-temp)) + stack-temp))) + (offset (* (tn-offset stack-tn) n-word-bytes))) + (cond ((< offset (ash 1 4)) + (inst flds offset nfp fp-temp)) + (t + (inst ldo offset zero-tn index) + (inst fldx index nfp fp-temp))) + (inst fcnvxf fp-temp y) + (when (policy node (or (= debug 3) (> safety speed))) + (note-next-instruction vop :internal-error) + (inst fsts fp-single-zero-tn 0 csp-tn))))))) + (frob %single-float/signed %single-float + single-reg single-float) + (frob %double-float/signed %double-float + double-reg double-float)) + + +(macrolet ((frob (trans from-sc from-type inst note) + `(define-vop (,(symbolicate trans "/" from-type)) + (:args (x :scs (,from-sc) + :target fp-temp)) + (:results (y :scs (signed-reg) + :load-if (not (sc-is y signed-stack)))) + (:arg-types ,from-type) + (:result-types signed-num) + (:translate ,trans) + (:policy :fast-safe) + (:note ,note) + (:vop-var vop) + (:save-p :compute-only) + (:temporary (:scs (single-reg) :from (:argument 0)) fp-temp) + (:temporary (:scs (signed-stack) :to (:result 0) :target y) + stack-temp) + (:temporary (:scs (any-reg) :from (:argument 0) + :to (:result 0)) index) + (:generator 3 + (let* ((nfp (current-nfp-tn vop)) + (stack-tn + (sc-case y + (signed-stack y) + (signed-reg stack-temp))) + (offset (* (tn-offset stack-tn) n-word-bytes))) + (inst ,inst x fp-temp) + (cond ((< offset (ash 1 4)) + (note-next-instruction vop :internal-error) + (inst fsts fp-temp offset nfp)) + (t + (inst ldo offset zero-tn index) + (note-next-instruction vop :internal-error) + (inst fstx fp-temp index nfp))) + (unless (eq y stack-tn) + (loadw y nfp (tn-offset stack-tn)))))))) + (frob %unary-round single-reg single-float fcnvfx "inline float round") + (frob %unary-round double-reg double-float fcnvfx "inline float round") + (frob %unary-truncate single-reg single-float fcnvfxt + "inline float truncate") + (frob %unary-truncate double-reg double-float fcnvfxt + "inline float truncate")) + + +(define-vop (make-single-float) + (:args (bits :scs (signed-reg) + :load-if (or (not (sc-is bits signed-stack)) + (sc-is res single-stack)) + :target res)) + (:results (res :scs (single-reg) + :load-if (not (sc-is bits single-stack)))) + (:arg-types signed-num) + (:result-types single-float) + (:translate make-single-float) + (:policy :fast-safe) + (:vop-var vop) + (:temporary (:scs (single-stack) :from (:argument 0) :to (:result 0)) temp) + (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index) + (:generator 2 + (let ((nfp (current-nfp-tn vop))) + (sc-case bits + (signed-reg + (sc-case res + (single-reg + (let ((offset (* (tn-offset temp) n-word-bytes))) + (inst stw bits offset nfp) + (cond ((< offset (ash 1 4)) + (inst flds offset nfp res)) + (t + (inst ldo offset zero-tn index) + (inst fldx index nfp res))))) + (single-stack + (inst stw bits (* (tn-offset res) n-word-bytes) nfp)))) + (signed-stack + (sc-case res + (single-reg + (let ((offset (* (tn-offset bits) n-word-bytes))) + (cond ((< offset (ash 1 4)) + (inst flds offset nfp res)) + (t + (inst ldo offset zero-tn index) + (inst fldx index nfp res))))))))))) + +(define-vop (make-double-float) + (:args (hi-bits :scs (signed-reg)) + (lo-bits :scs (unsigned-reg))) + (:results (res :scs (double-reg) + :load-if (not (sc-is res double-stack)))) + (:arg-types signed-num unsigned-num) + (:result-types double-float) + (:translate make-double-float) + (:policy :fast-safe) + (:temporary (:scs (double-stack) :to (:result 0)) temp) + (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index) + (:vop-var vop) + (:generator 2 + (let* ((nfp (current-nfp-tn vop)) + (stack-tn (sc-case res + (double-stack res) + (double-reg temp))) + (offset (* (tn-offset stack-tn) n-word-bytes))) + (inst stw hi-bits offset nfp) + (inst stw lo-bits (+ offset n-word-bytes) nfp) + (cond ((eq stack-tn res)) + ((< offset (ash 1 4)) + (inst flds offset nfp res)) + (t + (inst ldo offset zero-tn index) + (inst fldx index nfp res)))))) + + +(define-vop (single-float-bits) + (:args (float :scs (single-reg) + :load-if (not (sc-is float single-stack)))) + (:results (bits :scs (signed-reg) + :load-if (or (not (sc-is bits signed-stack)) + (sc-is float single-stack)))) + (:arg-types single-float) + (:result-types signed-num) + (:translate single-float-bits) + (:policy :fast-safe) + (:vop-var vop) + (:temporary (:scs (signed-stack) :from (:argument 0) :to (:result 0)) temp) + (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index) + (:generator 2 + (let ((nfp (current-nfp-tn vop))) + (sc-case float + (single-reg + (sc-case bits + (signed-reg + (let ((offset (* (tn-offset temp) n-word-bytes))) + (cond ((< offset (ash 1 4)) + (inst fsts float offset nfp)) + (t + (inst ldo offset zero-tn index) + (inst fstx float index nfp))) + (inst ldw offset nfp bits))) + (signed-stack + (let ((offset (* (tn-offset bits) n-word-bytes))) + (cond ((< offset (ash 1 4)) + (inst fsts float offset nfp)) + (t + (inst ldo offset zero-tn index) + (inst fstx float index nfp))))))) + (single-stack + (sc-case bits + (signed-reg + (inst ldw (* (tn-offset float) n-word-bytes) nfp bits)))))))) + +(define-vop (double-float-high-bits) + (:args (float :scs (double-reg) + :load-if (not (sc-is float double-stack)))) + (:results (hi-bits :scs (signed-reg) + :load-if (or (not (sc-is hi-bits signed-stack)) + (sc-is float double-stack)))) + (:arg-types double-float) + (:result-types signed-num) + (:translate double-float-high-bits) + (:policy :fast-safe) + (:vop-var vop) + (:temporary (:scs (signed-stack) :from (:argument 0) :to (:result 0)) temp) + (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index) + (:generator 2 + (let ((nfp (current-nfp-tn vop))) + (sc-case float + (double-reg + (sc-case hi-bits + (signed-reg + (let ((offset (* (tn-offset temp) n-word-bytes))) + (cond ((< offset (ash 1 4)) + (inst fsts float offset nfp :side 0)) + (t + (inst ldo offset zero-tn index) + (inst fstx float index nfp :side 0))) + (inst ldw offset nfp hi-bits))) + (signed-stack + (let ((offset (* (tn-offset hi-bits) n-word-bytes))) + (cond ((< offset (ash 1 4)) + (inst fsts float offset nfp :side 0)) + (t + (inst ldo offset zero-tn index) + (inst fstx float index nfp :side 0))))))) + (double-stack + (sc-case hi-bits + (signed-reg + (let ((offset (* (tn-offset float) n-word-bytes))) + (inst ldw offset nfp hi-bits))))))))) + +(define-vop (double-float-low-bits) + (:args (float :scs (double-reg) + :load-if (not (sc-is float double-stack)))) + (:results (lo-bits :scs (unsigned-reg) + :load-if (or (not (sc-is lo-bits unsigned-stack)) + (sc-is float double-stack)))) + (:arg-types double-float) + (:result-types unsigned-num) + (:translate double-float-low-bits) + (:policy :fast-safe) + (:vop-var vop) + (:temporary (:scs (unsigned-stack) :from (:argument 0) :to (:result 0)) temp) + (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index) + (:generator 2 + (let ((nfp (current-nfp-tn vop))) + (sc-case float + (double-reg + (sc-case lo-bits + (unsigned-reg + (let ((offset (* (tn-offset temp) n-word-bytes))) + (cond ((< offset (ash 1 4)) + (inst fsts float offset nfp :side 1)) + (t + (inst ldo offset zero-tn index) + (inst fstx float index nfp :side 1))) + (inst ldw offset nfp lo-bits))) + (unsigned-stack + (let ((offset (* (tn-offset lo-bits) n-word-bytes))) + (cond ((< offset (ash 1 4)) + (inst fsts float offset nfp :side 1)) + (t + (inst ldo offset zero-tn index) + (inst fstx float index nfp :side 1))))))) + (double-stack + (sc-case lo-bits + (unsigned-reg + (let ((offset (* (1+ (tn-offset float)) n-word-bytes))) + (inst ldw offset nfp lo-bits))))))))) + + + +;;;; Float mode hackery: + +(sb!xc:deftype float-modes () '(unsigned-byte 32)) +(defknown floating-point-modes () float-modes (flushable)) +(defknown ((setf floating-point-modes)) (float-modes) + float-modes) + +(define-vop (floating-point-modes) + (:results (res :scs (unsigned-reg) + :load-if (not (sc-is res unsigned-stack)))) + (:result-types unsigned-num) + (:translate floating-point-modes) + (:policy :fast-safe) + (:temporary (:scs (unsigned-stack) :to (:result 0)) temp) + (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index) + (:vop-var vop) + (:generator 3 + (let* ((nfp (current-nfp-tn vop)) + (stack-tn (sc-case res + (unsigned-stack res) + (unsigned-reg temp))) + (offset (* (tn-offset stack-tn) n-word-bytes))) + (cond ((< offset (ash 1 4)) + (inst fsts fp-single-zero-tn offset nfp)) + (t + (inst ldo offset zero-tn index) + (inst fstx fp-single-zero-tn index nfp))) + (unless (eq stack-tn res) + (inst ldw offset nfp res))))) + +(define-vop (set-floating-point-modes) + (:args (new :scs (unsigned-reg) + :load-if (not (sc-is new unsigned-stack)))) + (:results (res :scs (unsigned-reg))) + (:arg-types unsigned-num) + (:result-types unsigned-num) + (:translate (setf floating-point-modes)) + (:policy :fast-safe) + (:temporary (:scs (unsigned-stack) :from (:argument 0) :to (:result 0)) temp) + (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index) + (:vop-var vop) + (:generator 3 + (let* ((nfp (current-nfp-tn vop)) + (stack-tn (sc-case new + (unsigned-stack new) + (unsigned-reg temp))) + (offset (* (tn-offset stack-tn) n-word-bytes))) + (unless (eq new stack-tn) + (inst stw new offset nfp)) + (cond ((< offset (ash 1 4)) + (inst flds offset nfp fp-single-zero-tn)) + (t + (inst ldo offset zero-tn index) + (inst fldx index nfp fp-single-zero-tn))) + (inst ldw offset nfp res)))) + + +;;;; Complex float VOPs + +(define-vop (make-complex-single-float) + (:translate complex) + (:args (real :scs (single-reg) :target r) + (imag :scs (single-reg) :to :save)) + (:arg-types single-float single-float) + (:results (r :scs (complex-single-reg) :from (:argument 0) + :load-if (not (sc-is r complex-single-stack)))) + (:result-types complex-single-float) + (:note "inline complex single-float creation") + (:policy :fast-safe) + (:vop-var vop) + (:generator 5 + (sc-case r + (complex-single-reg + (let ((r-real (complex-single-reg-real-tn r))) + (unless (location= real r-real) + (inst funop :copy real r-real))) + (let ((r-imag (complex-single-reg-imag-tn r))) + (unless (location= imag r-imag) + (inst funop :copy imag r-imag)))) + (complex-single-stack + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset r) n-word-bytes))) + (str-float real offset nfp) + (str-float imag (+ offset n-word-bytes) nfp)))))) + +(define-vop (make-complex-double-float) + (:translate complex) + (:args (real :scs (double-reg) :target r) + (imag :scs (double-reg) :to :save)) + (:arg-types double-float double-float) + (:results (r :scs (complex-double-reg) :from (:argument 0) + :load-if (not (sc-is r complex-double-stack)))) + (:result-types complex-double-float) + (:note "inline complex double-float creation") + (:policy :fast-safe) + (:vop-var vop) + (:generator 5 + (sc-case r + (complex-double-reg + (let ((r-real (complex-double-reg-real-tn r))) + (unless (location= real r-real) + (inst funop :copy real r-real))) + (let ((r-imag (complex-double-reg-imag-tn r))) + (unless (location= imag r-imag) + (inst funop :copy imag r-imag)))) + (complex-double-stack + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset r) n-word-bytes))) + (str-float real offset nfp) + (str-float imag (+ offset (* 2 n-word-bytes)) nfp)))))) + + +(define-vop (complex-single-float-value) + (:args (x :scs (complex-single-reg) :target r + :load-if (not (sc-is x complex-single-stack)))) + (:arg-types complex-single-float) + (:results (r :scs (single-reg))) + (:result-types single-float) + (:variant-vars slot) + (:policy :fast-safe) + (:vop-var vop) + (:generator 3 + (sc-case x + (complex-single-reg + (let ((value-tn (ecase slot + (:real (complex-single-reg-real-tn x)) + (:imag (complex-single-reg-imag-tn x))))) + (unless (location= value-tn r) + (inst funop :copy value-tn r)))) + (complex-single-stack + (ld-float (* (+ (ecase slot (:real 0) (:imag 1)) (tn-offset x)) + n-word-bytes) + (current-nfp-tn vop) r))))) + +(define-vop (realpart/complex-single-float complex-single-float-value) + (:translate realpart) + (:note "complex single float realpart") + (:variant :real)) + +(define-vop (imagpart/complex-single-float complex-single-float-value) + (:translate imagpart) + (:note "complex single float imagpart") + (:variant :imag)) + +(define-vop (complex-double-float-value) + (:args (x :scs (complex-double-reg) :target r + :load-if (not (sc-is x complex-double-stack)))) + (:arg-types complex-double-float) + (:results (r :scs (double-reg))) + (:result-types double-float) + (:variant-vars slot) + (:policy :fast-safe) + (:vop-var vop) + (:generator 3 + (sc-case x + (complex-double-reg + (let ((value-tn (ecase slot + (:real (complex-double-reg-real-tn x)) + (:imag (complex-double-reg-imag-tn x))))) + (unless (location= value-tn r) + (inst funop :copy value-tn r)))) + (complex-double-stack + (ld-float (* (+ (ecase slot (:real 0) (:imag 2)) (tn-offset x)) + n-word-bytes) + (current-nfp-tn vop) r))))) + +(define-vop (realpart/complex-double-float complex-double-float-value) + (:translate realpart) + (:note "complex double float realpart") + (:variant :real)) + +(define-vop (imagpart/complex-double-float complex-double-float-value) + (:translate imagpart) + (:note "complex double float imagpart") + (:variant :imag)) diff --git a/src/compiler/hppa/insts.lisp b/src/compiler/hppa/insts.lisp new file mode 100644 index 0000000..4e03d54 --- /dev/null +++ b/src/compiler/hppa/insts.lisp @@ -0,0 +1,1510 @@ +(in-package "SB!VM") + +;;; (def-assembler-params +;;; :scheduler-p nil) +(eval-when (:compile-toplevel :load-toplevel :execute) + (setf sb!assem:*assem-scheduler-p* nil)) + + +;;;; Utility functions. + +(defun reg-tn-encoding (tn) + (declare (type tn tn)) + (sc-case tn + (null null-offset) + (zero zero-offset) + (t + (assert (eq (sb-name (sc-sb (tn-sc tn))) 'registers)) + (tn-offset tn)))) + +(defun fp-reg-tn-encoding (tn) + (declare (type tn tn)) + (sc-case tn + (fp-single-zero (values 0 nil)) + (single-reg (values (tn-offset tn) nil)) + (fp-double-zero (values 0 t)) + (double-reg (values (tn-offset tn) t)))) + +(defconstant-eqx compare-conditions + '(:never := :< :<= :<< :<<= :sv :od :tr :<> :>= :> :>>= :>> :nsv :ev) + #'equalp) + +(deftype compare-condition () + `(member nil ,@compare-conditions)) + +(defun compare-condition (cond) + (declare (type compare-condition cond)) + (if cond + (let ((result (or (position cond compare-conditions :test #'eq) + (error "Bogus Compare/Subtract condition: ~S" cond)))) + (values (ldb (byte 3 0) result) + (logbitp 3 result))) + (values 0 nil))) + +(defconstant-eqx add-conditions + '(:never := :< :<= :nuv :znv :sv :od :tr :<> :>= :> :uv :vnz :nsv :ev) + #'equalp) + +(deftype add-condition () + `(member nil ,@add-conditions)) + +(defun add-condition (cond) + (declare (type add-condition cond)) + (if cond + (let ((result (or (position cond add-conditions :test #'eq) + (error "Bogus Add condition: ~S" cond)))) + (values (ldb (byte 3 0) result) + (logbitp 3 result))) + (values 0 nil))) + +(defconstant-eqx logical-conditions + '(:never := :< :<= nil nil nil :od :tr :<> :>= :> nil nil nil :ev) + #'equalp) + +(deftype logical-condition () + `(member nil ,@(remove nil logical-conditions))) + +(defun logical-condition (cond) + (declare (type logical-condition cond)) + (if cond + (let ((result (or (position cond logical-conditions :test #'eq) + (error "Bogus Logical condition: ~S" cond)))) + (values (ldb (byte 3 0) result) + (logbitp 3 result))) + (values 0 nil))) + +(defconstant-eqx unit-conditions + '(:never nil :sbz :shz :sdc :sbc :shc :tr nil :nbz :nhz :ndc :nbc :nhc) + #'equalp) + +(deftype unit-condition () + `(member nil ,@(remove nil unit-conditions))) + +(defun unit-condition (cond) + (declare (type unit-condition cond)) + (if cond + (let ((result (or (position cond unit-conditions :test #'eq) + (error "Bogus Unit condition: ~S" cond)))) + (values (ldb (byte 3 0) result) + (logbitp 3 result))) + (values 0 nil))) + +(defconstant-eqx extract/deposit-conditions + '(:never := :< :od :tr :<> :>= :ev) + #'equalp) + +(deftype extract/deposit-condition () + `(member nil ,@extract/deposit-conditions)) + +(defun extract/deposit-condition (cond) + (declare (type extract/deposit-condition cond)) + (if cond + (or (position cond extract/deposit-conditions :test #'eq) + (error "Bogus Extract/Deposit condition: ~S" cond)) + 0)) + + +(defun space-encoding (space) + (declare (type (unsigned-byte 3) space)) + (dpb (ldb (byte 2 0) space) + (byte 2 1) + (ldb (byte 1 2) space))) + + +;;;; Initial disassembler setup. + +(setf sb!disassem:*disassem-inst-alignment-bytes* 4) + +(defvar *disassem-use-lisp-reg-names* t) + +(defparameter reg-symbols + (map 'vector + #'(lambda (name) + (cond ((null name) nil) + (t (make-symbol (concatenate 'string "$" name))))) + *register-names*)) + +(sb!disassem:define-arg-type reg + :printer #'(lambda (value stream dstate) + (declare (stream stream) (fixnum value)) + (let ((regname (aref reg-symbols value))) + (princ regname stream) + (sb!disassem:maybe-note-associated-storage-ref + value + 'registers + regname + dstate)))) + +(defparameter float-reg-symbols + (coerce + (loop for n from 0 to 31 collect (make-symbol (format nil "$F~d" n))) + 'vector)) + +(sb!disassem:define-arg-type fp-reg + :printer #'(lambda (value stream dstate) + (declare (stream stream) (fixnum value)) + (let ((regname (aref float-reg-symbols value))) + (princ regname stream) + (sb!disassem:maybe-note-associated-storage-ref + value + 'float-registers + regname + dstate)))) + +(sb!disassem:define-arg-type fp-fmt-0c + :printer #'(lambda (value stream dstate) + (declare (ignore dstate) (stream stream) (fixnum value)) + (ecase value + (0 (format stream "~A" '\,SGL)) + (1 (format stream "~A" '\,DBL)) + (3 (format stream "~A" '\,QUAD))))) + +(defun low-sign-extend (x n) + (let ((normal (dpb x (byte 1 (1- n)) (ldb (byte (1- n) 1) x)))) + (if (logbitp 0 x) + (logior (ash -1 (1- n)) normal) + normal))) + +(defun sign-extend (x n) + (if (logbitp (1- n) x) + (logior (ash -1 (1- n)) x) + x)) + +(defun assemble-bits (x list) + (let ((result 0) + (offset 0)) + (dolist (e (reverse list)) + (setf result (logior result (ash (ldb e x) offset))) + (incf offset (byte-size e))) + result)) + +(defmacro define-imx-decode (name bits) + `(sb!disassem:define-arg-type ,name + :printer #'(lambda (value stream dstate) + (declare (ignore dstate) (stream stream) (fixnum value)) + (format stream "~S" (low-sign-extend value ,bits))))) + +(define-imx-decode im5 5) +(define-imx-decode im11 11) +(define-imx-decode im14 14) + +(sb!disassem:define-arg-type im3 + :printer #'(lambda (value stream dstate) + (declare (ignore dstate) (stream stream) (fixnum value)) + (format stream "~S" (assemble-bits value `(,(byte 1 0) + ,(byte 2 1)))))) + +(sb!disassem:define-arg-type im21 + :printer #'(lambda (value stream dstate) + (declare (ignore dstate) (stream stream) (fixnum value)) + (format stream "~S" + (assemble-bits value `(,(byte 1 0) ,(byte 11 1) + ,(byte 2 14) ,(byte 5 16) + ,(byte 2 12)))))) + +(sb!disassem:define-arg-type cp + :printer #'(lambda (value stream dstate) + (declare (ignore dstate) (stream stream) (fixnum value)) + (format stream "~S" (- 31 value)))) + +(sb!disassem:define-arg-type clen + :printer #'(lambda (value stream dstate) + (declare (ignore dstate) (stream stream) (fixnum value)) + (format stream "~S" (- 32 value)))) + +(sb!disassem:define-arg-type compare-condition + :printer #("" \,= \,< \,<= \,<< \,<<= \,SV \,OD \,TR \,<> \,>= + \,> \,>>= \,>> \,NSV \,EV)) + +(sb!disassem:define-arg-type compare-condition-false + :printer #(\,TR \,<> \,>= \,> \,>>= \,>> \,NSV \,EV + "" \,= \,< \,<= \,<< \,<<= \,SV \,OD)) + +(sb!disassem:define-arg-type add-condition + :printer #("" \,= \,< \,<= \,NUV \,ZNV \,SV \,OD \,TR \,<> \,>= \,> \,UV + \,VNZ \,NSV \,EV)) + +(sb!disassem:define-arg-type add-condition-false + :printer #(\,TR \,<> \,>= \,> \,UV \,VNZ \,NSV \,EV + "" \,= \,< \,<= \,NUV \,ZNV \,SV \,OD)) + +(sb!disassem:define-arg-type logical-condition + :printer #("" \,= \,< \,<= "" "" "" \,OD \,TR \,<> \,>= \,> "" "" "" \,EV)) + +(sb!disassem:define-arg-type unit-condition + :printer #("" "" \,SBZ \,SHZ \,SDC \,SBC \,SHC \,TR "" \,NBZ \,NHZ \,NDC + \,NBC \,NHC)) + +(sb!disassem:define-arg-type extract/deposit-condition + :printer #("" \,= \,< \,OD \,TR \,<> \,>= \,EV)) + +(sb!disassem:define-arg-type extract/deposit-condition-false + :printer #(\,TR \,<> \,>= \,EV "" \,= \,< \,OD)) + +(sb!disassem:define-arg-type nullify + :printer #("" \,N)) + +(sb!disassem:define-arg-type fcmp-cond + :printer #(\FALSE? \FALSE \? \!<=> \= \=T \?= \!<> \!?>= \< \?< + \!>= \!?> \<= \?<= \!> \!?<= \> \?>\ \!<= \!?< \>= + \?>= \!< \!?= \<> \!= \!=T \!? \<=> \TRUE? \TRUE)) + +(sb!disassem:define-arg-type integer + :printer #'(lambda (value stream dstate) + (declare (ignore dstate) (stream stream) (fixnum value)) + (format stream "~S" value))) + +(sb!disassem:define-arg-type space + :printer #("" |1,| |2,| |3,|)) + + +;;;; Define-instruction-formats for disassembler. + +(sb!disassem:define-instruction-format + (load/store 32) + (op :field (byte 6 26)) + (b :field (byte 5 21) :type 'reg) + (t/r :field (byte 5 16) :type 'reg) + (s :field (byte 2 14) :type 'space) + (im14 :field (byte 14 0) :type 'im14)) + +(defconstant-eqx cmplt-index-print '((:cond ((u :constant 1) '\,S)) + (:cond ((m :constant 1) '\,M))) + #'equalp) + +(defconstant-eqx cmplt-disp-print '((:cond ((m :constant 1) + (:cond ((s :constant 0) '\,MA) + (t '\,MB))))) + #'equalp) + +(defconstant-eqx cmplt-store-print '((:cond ((s :constant 0) '\,B) + (t '\,E)) + (:cond ((m :constant 1) '\,M))) + #'equalp) + +(sb!disassem:define-instruction-format + (extended-load/store 32) + (op1 :field (byte 6 26) :value 3) + (b :field (byte 5 21) :type 'reg) + (x/im5/r :field (byte 5 16) :type 'reg) + (s :field (byte 2 14) :type 'space) + (u :field (byte 1 13)) + (op2 :field (byte 3 10)) + (ext4/c :field (byte 4 6)) + (m :field (byte 1 5)) + (t/im5 :field (byte 5 0) :type 'reg)) + +(sb!disassem:define-instruction-format + (ldil 32 :default-printer '(:name :tab im21 "," t)) + (op :field (byte 6 26)) + (t :field (byte 5 21) :type 'reg) + (im21 :field (byte 21 0) :type 'im21)) + +(sb!disassem:define-instruction-format + (branch17 32) + (op1 :field (byte 6 26)) + (t :field (byte 5 21) :type 'reg) + (w :fields `(,(byte 5 16) ,(byte 11 2) ,(byte 1 0)) + :use-label + #'(lambda (value dstate) + (declare (type sb!disassem:disassem-state dstate) (list value)) + (let ((x (logior (ash (first value) 12) (ash (second value) 1) + (third value)))) + (+ (ash (sign-extend + (assemble-bits x `(,(byte 1 0) ,(byte 5 12) ,(byte 1 1) + ,(byte 10 2))) 17) 2) + (sb!disassem:dstate-cur-addr dstate) 8)))) + (op2 :field (byte 3 13)) + (n :field (byte 1 1) :type 'nullify)) + +(sb!disassem:define-instruction-format + (branch12 32) + (op1 :field (byte 6 26)) + (r2 :field (byte 5 21) :type 'reg) + (r1 :field (byte 5 16) :type 'reg) + (w :fields `(,(byte 11 2) ,(byte 1 0)) + :use-label + #'(lambda (value dstate) + (declare (type sb!disassem:disassem-state dstate) (list value)) + (let ((x (logior (ash (first value) 1) (second value)))) + (+ (ash (sign-extend + (assemble-bits x `(,(byte 1 0) ,(byte 1 1) ,(byte 10 2))) + 12) 2) + (sb!disassem:dstate-cur-addr dstate) 8)))) + (c :field (byte 3 13)) + (n :field (byte 1 1) :type 'nullify)) + +(sb!disassem:define-instruction-format + (branch 32) + (op1 :field (byte 6 26)) + (t :field (byte 5 21) :type 'reg) + (x :field (byte 5 16) :type 'reg) + (op2 :field (byte 3 13)) + (x1 :field (byte 11 2)) + (n :field (byte 1 1) :type 'nullify) + (x2 :field (byte 1 0))) + +(sb!disassem:define-instruction-format + (r3-inst 32 :default-printer '(:name c :tab r1 "," r2 "," t)) + (r3 :field (byte 6 26) :value 2) + (r2 :field (byte 5 21) :type 'reg) + (r1 :field (byte 5 16) :type 'reg) + (c :field (byte 3 13)) + (f :field (byte 1 12)) + (op :field (byte 7 5)) + (t :field (byte 5 0) :type 'reg)) + +(sb!disassem:define-instruction-format + (imm-inst 32 :default-printer '(:name c :tab im11 "," r "," t)) + (op :field (byte 6 26)) + (r :field (byte 5 21) :type 'reg) + (t :field (byte 5 16) :type 'reg) + (c :field (byte 3 13)) + (f :field (byte 1 12)) + (o :field (byte 1 11)) + (im11 :field (byte 11 0) :type 'im11)) + +(sb!disassem:define-instruction-format + (extract/deposit-inst 32) + (op1 :field (byte 6 26)) + (r2 :field (byte 5 21) :type 'reg) + (r1 :field (byte 5 16) :type 'reg) + (c :field (byte 3 13) :type 'extract/deposit-condition) + (op2 :field (byte 3 10)) + (cp :field (byte 5 5) :type 'cp) + (t/clen :field (byte 5 0) :type 'clen)) + +(sb!disassem:define-instruction-format + (break 32 :default-printer '(:name :tab im13 "," im5)) + (op1 :field (byte 6 26) :value 0) + (im13 :field (byte 13 13)) + (q2 :field (byte 8 5) :value 0) + (im5 :field (byte 5 0))) + +(defun snarf-error-junk (sap offset &optional length-only) + (let* ((length (sb!sys:sap-ref-8 sap offset)) + (vector (make-array length :element-type '(unsigned-byte 8)))) + (declare (type sb!sys:system-area-pointer sap) + (type (unsigned-byte 8) length) + (type (simple-array (unsigned-byte 8) (*)) vector)) + (cond (length-only + (values 0 (1+ length) nil nil)) + (t + (sb!kernel:copy-from-system-area sap (* n-byte-bits (1+ offset)) + vector (* n-word-bits + vector-data-offset) + (* length n-byte-bits)) + (collect ((sc-offsets) + (lengths)) + (lengths 1) ; the length byte + (let* ((index 0) + (error-number (sb!c::read-var-integer vector index))) + (lengths index) + (loop + (when (>= index length) + (return)) + (let ((old-index index)) + (sc-offsets (sb!c::read-var-integer vector index)) + (lengths (- index old-index)))) + (values error-number + (1+ length) + (sc-offsets) + (lengths)))))))) + +(defun break-control (chunk inst stream dstate) + (declare (ignore inst)) + (flet ((nt (x) (if stream (sb!disassem:note x dstate)))) + (case (break-im5 chunk dstate) + (#.sb!vm:error-trap + (nt "Error trap") + (sb!disassem:handle-break-args #'snarf-error-junk stream dstate)) + (#.sb!vm:cerror-trap + (nt "Cerror trap") + (sb!disassem:handle-break-args #'snarf-error-junk stream dstate)) + (#.sb!vm:breakpoint-trap + (nt "Breakpoint trap")) + (#.sb!vm:pending-interrupt-trap + (nt "Pending interrupt trap")) + (#.sb!vm:halt-trap + (nt "Halt trap")) + (#.sb!vm:fun-end-breakpoint-trap + (nt "Function end breakpoint trap")) + ))) + +(sb!disassem:define-instruction-format + (system-inst 32) + (op1 :field (byte 6 26) :value 0) + (r1 :field (byte 5 21) :type 'reg) + (r2 :field (byte 5 16) :type 'reg) + (s :field (byte 3 13)) + (op2 :field (byte 8 5)) + (r3 :field (byte 5 0) :type 'reg)) + +(sb!disassem:define-instruction-format + (fp-load/store 32) + (op :field (byte 6 26)) + (b :field (byte 5 21) :type 'reg) + (x :field (byte 5 16) :type 'reg) + (s :field (byte 2 14) :type 'space) + (u :field (byte 1 13)) + (x1 :field (byte 1 12)) + (x2 :field (byte 2 10)) + (x3 :field (byte 1 9)) + (x4 :field (byte 3 6)) + (m :field (byte 1 5)) + (t :field (byte 5 0) :type 'fp-reg)) + +(sb!disassem:define-instruction-format + (fp-class-0-inst 32) + (op1 :field (byte 6 26)) + (r :field (byte 5 21) :type 'fp-reg) + (x1 :field (byte 5 16) :type 'fp-reg) + (op2 :field (byte 3 13)) + (fmt :field (byte 2 11) :type 'fp-fmt-0c) + (x2 :field (byte 2 9)) + (x3 :field (byte 3 6)) + (x4 :field (byte 1 5)) + (t :field (byte 5 0) :type 'fp-reg)) + +(sb!disassem:define-instruction-format + (fp-class-1-inst 32) + (op1 :field (byte 6 26)) + (r :field (byte 5 21) :type 'fp-reg) + (x1 :field (byte 4 17) :value 0) + (x2 :field (byte 2 15)) + (df :field (byte 2 13) :type 'fp-fmt-0c) + (sf :field (byte 2 11) :type 'fp-fmt-0c) + (x3 :field (byte 2 9) :value 1) + (x4 :field (byte 3 6) :value 0) + (x5 :field (byte 1 5) :value 0) + (t :field (byte 5 0) :type 'fp-reg)) + + + +;;;; Load and Store stuff. + +(define-bitfield-emitter emit-load/store 32 + (byte 6 26) + (byte 5 21) + (byte 5 16) + (byte 2 14) + (byte 14 0)) + + +(defun im14-encoding (segment disp) + (declare (type (or fixup (signed-byte 14)))) + (cond ((fixup-p disp) + (note-fixup segment :load disp) + (assert (or (null (fixup-offset disp)) (zerop (fixup-offset disp)))) + 0) + (t + (dpb (ldb (byte 13 0) disp) + (byte 13 1) + (ldb (byte 1 13) disp))))) + +(macrolet ((define-load-inst (name opcode) + `(define-instruction ,name (segment disp base reg) + (:declare (type tn reg base) + (type (or fixup (signed-byte 14)) disp)) + (:printer load/store ((op ,opcode) (s 0)) + '(:name :tab im14 "(" s b ")," t/r)) + (:emitter + (emit-load/store segment ,opcode + (reg-tn-encoding base) (reg-tn-encoding reg) 0 + (im14-encoding segment disp))))) + (define-store-inst (name opcode) + `(define-instruction ,name (segment reg disp base) + (:declare (type tn reg base) + (type (or fixup (signed-byte 14)) disp)) + (:printer load/store ((op ,opcode) (s 0)) + '(:name :tab t/r "," im14 "(" s b ")")) + (:emitter + (emit-load/store segment ,opcode + (reg-tn-encoding base) (reg-tn-encoding reg) 0 + (im14-encoding segment disp)))))) + (define-load-inst ldw #x12) + (define-load-inst ldh #x11) + (define-load-inst ldb #x10) + (define-load-inst ldwm #x13) + (define-load-inst ldo #x0D) + + (define-store-inst stw #x1A) + (define-store-inst sth #x19) + (define-store-inst stb #x18) + (define-store-inst stwm #x1B)) + +(define-bitfield-emitter emit-extended-load/store 32 + (byte 6 26) (byte 5 21) (byte 5 16) (byte 2 14) (byte 1 13) + (byte 3 10) (byte 4 6) (byte 1 5) (byte 5 0)) + +(macrolet ((define-load-indexed-inst (name opcode) + `(define-instruction ,name (segment index base reg &key modify scale) + (:declare (type tn reg base index) + (type (member t nil) modify scale)) + (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'reg) + (op2 0)) + `(:name ,@cmplt-index-print :tab x/im5/r + "(" s b ")" t/im5)) + (:emitter + (emit-extended-load/store + segment #x03 (reg-tn-encoding base) (reg-tn-encoding index) + 0 (if scale 1 0) 0 ,opcode (if modify 1 0) + (reg-tn-encoding reg)))))) + (define-load-indexed-inst ldwx 2) + (define-load-indexed-inst ldhx 1) + (define-load-indexed-inst ldbx 0) + (define-load-indexed-inst ldcwx 7)) + +(defun short-disp-encoding (segment disp) + (declare (type (or fixup (signed-byte 5)) disp)) + (cond ((fixup-p disp) + (note-fixup segment :load-short disp) + (assert (or (null (fixup-offset disp)) (zerop (fixup-offset disp)))) + 0) + (t + (dpb (ldb (byte 4 0) disp) + (byte 4 1) + (ldb (byte 1 4) disp))))) + +(macrolet ((define-load-short-inst (name opcode) + `(define-instruction ,name (segment base disp reg &key modify) + (:declare (type tn base reg) + (type (or fixup (signed-byte 5)) disp) + (type (member :before :after nil) modify)) + (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'im5) + (op2 4)) + `(:name ,@cmplt-disp-print :tab x/im5/r + "(" s b ")" t/im5)) + (:emitter + (multiple-value-bind + (m a) + (ecase modify + ((nil) (values 0 0)) + (:after (values 1 0)) + (:before (values 1 1))) + (emit-extended-load/store segment #x03 (reg-tn-encoding base) + (short-disp-encoding segment disp) + 0 a 4 ,opcode m + (reg-tn-encoding reg)))))) + (define-store-short-inst (name opcode) + `(define-instruction ,name (segment reg base disp &key modify) + (:declare (type tn reg base) + (type (or fixup (signed-byte 5)) disp) + (type (member :before :after nil) modify)) + (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'im5) + (op2 4)) + `(:name ,@cmplt-disp-print :tab x/im5/r + "," t/im5 "(" s b ")")) + (:emitter + (multiple-value-bind + (m a) + (ecase modify + ((nil) (values 0 0)) + (:after (values 1 0)) + (:before (values 1 1))) + (emit-extended-load/store segment #x03 (reg-tn-encoding base) + (short-disp-encoding segment disp) + 0 a 4 ,opcode m + (reg-tn-encoding reg))))))) + (define-load-short-inst ldws 2) + (define-load-short-inst ldhs 1) + (define-load-short-inst ldbs 0) + (define-load-short-inst ldcws 7) + + (define-store-short-inst stws 10) + (define-store-short-inst sths 9) + (define-store-short-inst stbs 8)) + +(define-instruction stbys (segment reg base disp where &key modify) + (:declare (type tn reg base) + (type (signed-byte 5) disp) + (type (member :begin :end) where) + (type (member t nil) modify)) + (:printer extended-load/store ((ext4/c #xC) (t/im5 nil :type 'im5) (op2 4)) + `(:name ,@cmplt-store-print :tab x/im5/r "," t/im5 "(" s b ")")) + (:emitter + (emit-extended-load/store segment #x03 (reg-tn-encoding base) + (reg-tn-encoding reg) 0 + (ecase where (:begin 0) (:end 1)) + 4 #xC (if modify 1 0) + (short-disp-encoding segment disp)))) + + +;;;; Immediate Instructions. + +(define-bitfield-emitter emit-ldil 32 + (byte 6 26) + (byte 5 21) + (byte 21 0)) + +(defun immed-21-encoding (segment value) + (declare (type (or fixup (signed-byte 21) (unsigned-byte 21)) value)) + (cond ((fixup-p value) + (note-fixup segment :hi value) + (assert (or (null (fixup-offset value)) (zerop (fixup-offset value)))) + 0) + (t + (logior (ash (ldb (byte 5 2) value) 16) + (ash (ldb (byte 2 7) value) 14) + (ash (ldb (byte 2 0) value) 12) + (ash (ldb (byte 11 9) value) 1) + (ldb (byte 1 20) value))))) + +(define-instruction ldil (segment value reg) + (:declare (type tn reg) + (type (or (signed-byte 21) (unsigned-byte 21) fixup) value)) + (:printer ldil ((op #x08))) + (:emitter + (emit-ldil segment #x08 (reg-tn-encoding reg) + (immed-21-encoding segment value)))) + +(define-instruction addil (segment value reg) + (:declare (type tn reg) + (type (or (signed-byte 21) (unsigned-byte 21) fixup) value)) + (:printer ldil ((op #x0A))) + (:emitter + (emit-ldil segment #x0A (reg-tn-encoding reg) + (immed-21-encoding segment value)))) + + +;;;; Branch instructions. + +(define-bitfield-emitter emit-branch 32 + (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) + (byte 11 2) (byte 1 1) (byte 1 0)) + +(defun label-relative-displacement (label posn &optional delta-if-after) + (declare (type label label) (type index posn)) + (ash (- (if delta-if-after + (label-position label posn delta-if-after) + (label-position label)) + (+ posn 8)) -2)) + +(defun decompose-branch-disp (segment disp) + (declare (type (or fixup (signed-byte 17)) disp)) + (cond ((fixup-p disp) + (note-fixup segment :branch disp) + (assert (or (null (fixup-offset disp)) (zerop (fixup-offset disp)))) + (values 0 0 0)) + (t + (values (ldb (byte 5 11) disp) + (dpb (ldb (byte 10 0) disp) + (byte 10 1) + (ldb (byte 1 10) disp)) + (ldb (byte 1 16) disp))))) + +(defun emit-relative-branch (segment opcode link sub-opcode target nullify) + (declare (type (unsigned-byte 6) opcode) + (type (unsigned-byte 5) link) + (type (unsigned-byte 1) sub-opcode) + (type label target) + (type (member t nil) nullify)) + (emit-back-patch segment 4 + #'(lambda (segment posn) + (let ((disp (label-relative-displacement target posn))) + (assert (<= (- (ash 1 16)) disp (1- (ash 1 16)))) + (multiple-value-bind + (w1 w2 w) + (decompose-branch-disp segment disp) + (emit-branch segment opcode link w1 sub-opcode w2 + (if nullify 1 0) w)))))) + +(define-instruction b (segment target &key nullify) + (:declare (type label target) (type (member t nil) nullify)) + (:emitter + (emit-relative-branch segment #x3A 0 0 target nullify))) + +(define-instruction bl (segment target reg &key nullify) + (:declare (type tn reg) (type label target) (type (member t nil) nullify)) + (:printer branch17 ((op1 #x3A) (op2 0)) '(:name n :tab w "," t)) + (:emitter + (emit-relative-branch segment #x3A (reg-tn-encoding reg) 0 target nullify))) + +(define-instruction gateway (segment target reg &key nullify) + (:declare (type tn reg) (type label target) (type (member t nil) nullify)) + (:printer branch17 ((op1 #x3A) (op2 1)) '(:name n :tab w "," t)) + (:emitter + (emit-relative-branch segment #x3A (reg-tn-encoding reg) 1 target nullify))) + +;;; BLR is useless because we have no way to generate the offset. + +(define-instruction bv (segment base &key nullify offset) + (:declare (type tn base) + (type (member t nil) nullify) + (type (or tn null) offset)) + (:printer branch ((op1 #x3A) (op2 6)) '(:name n :tab x "(" t ")")) + (:emitter + (emit-branch segment #x3A (reg-tn-encoding base) + (if offset (reg-tn-encoding offset) 0) + 6 0 (if nullify 1 0) 0))) + +(define-instruction be (segment disp space base &key nullify) + (:declare (type (or fixup (signed-byte 17)) disp) + (type tn base) + (type (unsigned-byte 3) space) + (type (member t nil) nullify)) + (:printer branch17 ((op1 #x38) (op2 nil :type 'im3)) + '(:name n :tab w "(" op2 "," t ")")) + (:emitter + (multiple-value-bind + (w1 w2 w) + (decompose-branch-disp segment disp) + (emit-branch segment #x38 (reg-tn-encoding base) w1 + (space-encoding space) w2 (if nullify 1 0) w)))) + +(define-instruction ble (segment disp space base &key nullify) + (:declare (type (or fixup (signed-byte 17)) disp) + (type tn base) + (type (unsigned-byte 3) space) + (type (member t nil) nullify)) + (:printer branch17 ((op1 #x39) (op2 nil :type 'im3)) + '(:name n :tab w "(" op2 "," t ")")) + (:emitter + (multiple-value-bind + (w1 w2 w) + (decompose-branch-disp segment disp) + (emit-branch segment #x39 (reg-tn-encoding base) w1 + (space-encoding space) w2 (if nullify 1 0) w)))) + +(defun emit-conditional-branch (segment opcode r2 r1 cond target nullify) + (emit-back-patch segment 4 + #'(lambda (segment posn) + (let ((disp (label-relative-displacement target posn))) + (assert (<= (- (ash 1 11)) disp (1- (ash 1 11)))) + (let ((w1 (logior (ash (ldb (byte 10 0) disp) 1) + (ldb (byte 1 10) disp))) + (w (ldb (byte 1 11) disp))) + (emit-branch segment opcode r2 r1 cond w1 (if nullify 1 0) w)))))) + +(defun im5-encoding (value) + (declare (type (signed-byte 5) value) + #+nil (values (unsigned-byte 5))) + (dpb (ldb (byte 4 0) value) + (byte 4 1) + (ldb (byte 1 4) value))) + +(macrolet ((define-branch-inst (r-name r-opcode i-name i-opcode cond-kind) + (let* ((conditional (symbolicate cond-kind "-CONDITION")) + (false-conditional (symbolicate conditional "-FALSE"))) + `(progn + (define-instruction ,r-name (segment cond r1 r2 target &key nullify) + (:declare (type ,conditional cond) + (type tn r1 r2) + (type label target) + (type (member t nil) nullify)) + (:printer branch12 ((op1 ,r-opcode) (c nil :type ',conditional)) + '(:name c n :tab r1 "," r2 "," w)) + ,@(unless (= r-opcode #x32) + `((:printer branch12 ((op1 ,(+ 2 r-opcode)) + (c nil :type ',false-conditional)) + '(:name c n :tab r1 "," r2 "," w)))) + (:emitter + (multiple-value-bind + (cond-encoding false) + (,conditional cond) + (emit-conditional-branch + segment (if false ,(+ r-opcode 2) ,r-opcode) + (reg-tn-encoding r2) (reg-tn-encoding r1) + cond-encoding target nullify)))) + (define-instruction ,i-name (segment cond imm reg target &key nullify) + (:declare (type ,conditional cond) + (type (signed-byte 5) imm) + (type tn reg) + (type (member t nil) nullify)) + (:printer branch12 ((op1 ,i-opcode) (r1 nil :type 'im5) + (c nil :type ',conditional)) + '(:name c n :tab r1 "," r2 "," w)) + ,@(unless (= r-opcode #x32) + `((:printer branch12 ((op1 ,(+ 2 i-opcode)) (r1 nil :type 'im5) + (c nil :type ',false-conditional)) + '(:name c n :tab r1 "," r2 "," w)))) + (:emitter + (multiple-value-bind + (cond-encoding false) + (,conditional cond) + (emit-conditional-branch + segment (if false (+ ,i-opcode 2) ,i-opcode) + (reg-tn-encoding reg) (im5-encoding imm) + cond-encoding target nullify)))))))) + (define-branch-inst movb #x32 movib #x33 extract/deposit) + (define-branch-inst comb #x20 comib #x21 compare) + (define-branch-inst addb #x28 addib #x29 add)) + +(define-instruction bb (segment cond reg posn target &key nullify) + (:declare (type (member t nil) cond nullify) + (type tn reg) + (type (or (member :variable) (unsigned-byte 5)) posn)) + (:printer branch12 ((op1 30) (c nil :type 'extract/deposit-condition)) + '('BVB c n :tab r1 "," w)) + (:emitter + (multiple-value-bind + (opcode posn-encoding) + (if (eq posn :variable) + (values #x30 0) + (values #x31 posn)) + (emit-conditional-branch segment opcode posn-encoding + (reg-tn-encoding reg) + (if cond 2 6) target nullify)))) + + +;;;; Computation Instructions + +(define-bitfield-emitter emit-r3-inst 32 + (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) + (byte 1 12) (byte 7 5) (byte 5 0)) + +(macrolet ((define-r3-inst (name cond-kind opcode) + `(define-instruction ,name (segment r1 r2 res &optional cond) + (:declare (type tn res r1 r2)) + (:printer r3-inst ((op ,opcode) (c nil :type ',(symbolicate + cond-kind + "-CONDITION")))) + ,@(when (= opcode #x12) + `((:printer r3-inst ((op ,opcode) (r2 0) + (c nil :type ',(symbolicate cond-kind + "-CONDITION"))) + `('COPY :tab r1 "," t)))) + (:emitter + (multiple-value-bind + (cond false) + (,(symbolicate cond-kind "-CONDITION") cond) + (emit-r3-inst segment #x02 (reg-tn-encoding r2) (reg-tn-encoding r1) + cond (if false 1 0) ,opcode + (reg-tn-encoding res))))))) + (define-r3-inst add add #x30) + (define-r3-inst addl add #x50) + (define-r3-inst addo add #x70) + (define-r3-inst addc add #x38) + (define-r3-inst addco add #x78) + (define-r3-inst sh1add add #x32) + (define-r3-inst sh1addl add #x52) + (define-r3-inst sh1addo add #x72) + (define-r3-inst sh2add add #x34) + (define-r3-inst sh2addl add #x54) + (define-r3-inst sh2addo add #x74) + (define-r3-inst sh3add add #x36) + (define-r3-inst sh3addl add #x56) + (define-r3-inst sh3addo add #x76) + (define-r3-inst sub compare #x20) + (define-r3-inst subo compare #x60) + (define-r3-inst subb compare #x28) + (define-r3-inst subbo compare #x68) + (define-r3-inst subt compare #x26) + (define-r3-inst subto compare #x66) + (define-r3-inst ds compare #x22) + (define-r3-inst comclr compare #x44) + (define-r3-inst or logical #x12) + (define-r3-inst xor logical #x14) + (define-r3-inst and logical #x10) + (define-r3-inst andcm logical #x00) + (define-r3-inst uxor unit #x1C) + (define-r3-inst uaddcm unit #x4C) + (define-r3-inst uaddcmt unit #x4E) + (define-r3-inst dcor unit #x5C) + (define-r3-inst idcor unit #x5E)) + +(define-bitfield-emitter emit-imm-inst 32 + (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) + (byte 1 12) (byte 1 11) (byte 11 0)) + +(defun im11-encoding (value) + (declare (type (signed-byte 11) value) + #+nil (values (unsigned-byte 11))) + (dpb (ldb (byte 10 0) value) + (byte 10 1) + (ldb (byte 1 10) value))) + +(macrolet ((define-imm-inst (name cond-kind opcode subcode) + `(define-instruction ,name (segment imm src dst &optional cond) + (:declare (type tn dst src) + (type (signed-byte 11) imm)) + (:printer imm-inst ((op ,opcode) (o ,subcode) + (c nil :type + ',(symbolicate cond-kind "-CONDITION")))) + (:emitter + (multiple-value-bind + (cond false) + (,(symbolicate cond-kind "-CONDITION") cond) + (emit-imm-inst segment ,opcode (reg-tn-encoding src) + (reg-tn-encoding dst) cond + (if false 1 0) ,subcode + (im11-encoding imm))))))) + (define-imm-inst addi add #x2D 0) + (define-imm-inst addio add #x2D 1) + (define-imm-inst addit add #x2C 0) + (define-imm-inst addito add #x2C 1) + (define-imm-inst subi compare #x25 0) + (define-imm-inst subio compare #x25 1) + (define-imm-inst comiclr compare #x24 0)) + +(define-bitfield-emitter emit-extract/deposit-inst 32 + (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) + (byte 3 10) (byte 5 5) (byte 5 0)) + +(define-instruction shd (segment r1 r2 count res &optional cond) + (:declare (type tn res r1 r2) + (type (or (member :variable) (integer 0 31)) count)) + (:printer extract/deposit-inst ((op1 #x34) (op2 2) (t/clen nil :type 'reg)) + '(:name c :tab r1 "," r2 "," cp "," t/clen)) + (:printer extract/deposit-inst ((op1 #x34) (op2 0) (t/clen nil :type 'reg)) + '('VSHD c :tab r1 "," r2 "," t/clen)) + (:emitter + (etypecase count + ((member :variable) + (emit-extract/deposit-inst segment #x34 + (reg-tn-encoding r2) (reg-tn-encoding r1) + (extract/deposit-condition cond) + 0 0 (reg-tn-encoding res))) + ((integer 0 31) + (emit-extract/deposit-inst segment #x34 + (reg-tn-encoding r2) (reg-tn-encoding r1) + (extract/deposit-condition cond) + 2 (- 31 count) + (reg-tn-encoding res)))))) + +(macrolet ((define-extract-inst (name opcode) + `(define-instruction ,name (segment src posn len res &optional cond) + (:declare (type tn res src) + (type (or (member :variable) (integer 0 31)) posn) + (type (integer 1 32) len)) + (:printer extract/deposit-inst ((op1 #x34) (cp nil :type 'integer) + (op2 ,opcode)) + '(:name c :tab r2 "," cp "," t/clen "," r1)) + (:printer extract/deposit-inst ((op1 #x34) (op2 ,(- opcode 2))) + '('V :name c :tab r2 "," t/clen "," r1)) + (:emitter + (etypecase posn + ((member :variable) + (emit-extract/deposit-inst segment #x34 (reg-tn-encoding src) + (reg-tn-encoding res) + (extract/deposit-condition cond) + ,(- opcode 2) 0 (- 32 len))) + ((integer 0 31) + (emit-extract/deposit-inst segment #x34 (reg-tn-encoding src) + (reg-tn-encoding res) + (extract/deposit-condition cond) + ,opcode posn (- 32 len)))))))) + (define-extract-inst extru 6) + (define-extract-inst extrs 7)) + +(macrolet ((define-deposit-inst (name opcode) + `(define-instruction ,name (segment src posn len res &optional cond) + (:declare (type tn res) + (type (or tn (signed-byte 5)) src) + (type (or (member :variable) (integer 0 31)) posn) + (type (integer 1 32) len)) + (:printer extract/deposit-inst ((op1 #x35) (op2 ,opcode)) + ',(let ((base '('VDEP c :tab r1 "," t/clen "," r2))) + (if (= opcode 0) (cons ''Z base) base))) + (:printer extract/deposit-inst ((op1 #x35) (op2 ,(+ 2 opcode))) + ',(let ((base '('DEP c :tab r1 "," cp "," t/clen "," r2))) + (if (= opcode 0) (cons ''Z base) base))) + (:printer extract/deposit-inst ((op1 #x35) (r1 nil :type 'im5) + (op2 ,(+ 4 opcode))) + ',(let ((base '('VDEPI c :tab r1 "," t/clen "," r2))) + (if (= opcode 0) (cons ''Z base) base))) + (:printer extract/deposit-inst ((op1 #x35) (r1 nil :type 'im5) + (op2 ,(+ 6 opcode))) + ',(let ((base '('DEPI c :tab r1 "," cp "," t/clen "," r2))) + (if (= opcode 0) (cons ''Z base) base))) + (:emitter + (multiple-value-bind + (opcode src-encoding) + (etypecase src + (tn + (values ,opcode (reg-tn-encoding src))) + ((signed-byte 5) + (values ,(+ opcode 4) (im5-encoding src)))) + (multiple-value-bind + (opcode posn-encoding) + (etypecase posn + ((member :variable) + (values opcode 0)) + ((integer 0 31) + (values (+ opcode 2) (- 31 posn)))) + (emit-extract/deposit-inst segment #x35 (reg-tn-encoding res) + src-encoding + (extract/deposit-condition cond) + opcode posn-encoding (- 32 len)))))))) + + (define-deposit-inst dep 1) + (define-deposit-inst zdep 0)) + + + +;;;; System Control Instructions. + +(define-bitfield-emitter emit-break 32 + (byte 6 26) (byte 13 13) (byte 8 5) (byte 5 0)) + +(define-instruction break (segment &optional (im5 0) (im13 0)) + (:declare (type (unsigned-byte 13) im13) + (type (unsigned-byte 5) im5)) + (:printer break () :default :control #'break-control) + (:emitter + (emit-break segment 0 im13 0 im5))) + +(define-bitfield-emitter emit-system-inst 32 + (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) (byte 8 5) (byte 5 0)) + +(define-instruction ldsid (segment res base &optional (space 0)) + (:declare (type tn res base) + (type (integer 0 3) space)) + (:printer system-inst ((op2 #x85) (c nil :type 'space) + (s nil :printer #(0 0 1 1 2 2 3 3))) + `(:name :tab "(" s r1 ")," r3)) + (:emitter + (emit-system-inst segment 0 (reg-tn-encoding base) 0 (ash space 1) #x85 + (reg-tn-encoding res)))) + +(define-instruction mtsp (segment reg space) + (:declare (type tn reg) (type (integer 0 7) space)) + (:printer system-inst ((op2 #xC1)) '(:name :tab r2 "," s)) + (:emitter + (emit-system-inst segment 0 0 (reg-tn-encoding reg) (space-encoding space) + #xC1 0))) + +(define-instruction mfsp (segment space reg) + (:declare (type tn reg) (type (integer 0 7) space)) + (:printer system-inst ((op2 #x25) (c nil :type 'space)) '(:name :tab s r3)) + (:emitter + (emit-system-inst segment 0 0 0 (space-encoding space) #x25 + (reg-tn-encoding reg)))) + +(deftype control-reg () + '(or (unsigned-byte 5) (member :sar))) + +(defun control-reg (reg) + (declare (type control-reg reg) + #+nil (values (unsigned-byte 32))) + (if (typep reg '(unsigned-byte 5)) + reg + (ecase reg + (:sar 11)))) + +(define-instruction mtctl (segment reg ctrl-reg) + (:declare (type tn reg) (type control-reg ctrl-reg)) + (:printer system-inst ((op2 #xC2)) '(:name :tab r2 "," r1)) + (:emitter + (emit-system-inst segment 0 (control-reg ctrl-reg) (reg-tn-encoding reg) + 0 #xC2 0))) + +(define-instruction mfctl (segment ctrl-reg reg) + (:declare (type tn reg) (type control-reg ctrl-reg)) + (:printer system-inst ((op2 #x45)) '(:name :tab r1 "," r3)) + (:emitter + (emit-system-inst segment 0 (control-reg ctrl-reg) 0 0 #x45 + (reg-tn-encoding reg)))) + + + +;;;; Floating point instructions. + +(define-bitfield-emitter emit-fp-load/store 32 + (byte 6 26) (byte 5 21) (byte 5 16) (byte 2 14) (byte 1 13) (byte 1 12) + (byte 2 10) (byte 1 9) (byte 3 6) (byte 1 5) (byte 5 0)) + +(define-instruction fldx (segment index base result &key modify scale side) + (:declare (type tn index base result) + (type (member t nil) modify scale) + (type (member nil 0 1) side)) + (:printer fp-load/store ((op #x0b) (x1 0) (x2 0) (x3 0)) + `('FLDDX ,@cmplt-index-print :tab x "(" s b ")" "," t)) + (:printer fp-load/store ((op #x09) (x1 0) (x2 0) (x3 0)) + `('FLDWX ,@cmplt-index-print :tab x "(" s b ")" "," t)) + (:emitter + (multiple-value-bind + (result-encoding double-p) + (fp-reg-tn-encoding result) + (when side + (assert double-p) + (setf double-p nil)) + (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base) + (reg-tn-encoding index) 0 (if scale 1 0) 0 0 0 + (or side 0) (if modify 1 0) result-encoding)))) + +(define-instruction fstx (segment value index base &key modify scale side) + (:declare (type tn index base value) + (type (member t nil) modify scale) + (type (member nil 0 1) side)) + (:printer fp-load/store ((op #x0b) (x1 0) (x2 0) (x3 1)) + `('FSTDX ,@cmplt-index-print :tab t "," x "(" s b ")")) + (:printer fp-load/store ((op #x09) (x1 0) (x2 0) (x3 1)) + `('FSTWX ,@cmplt-index-print :tab t "," x "(" s b ")")) + (:emitter + (multiple-value-bind + (value-encoding double-p) + (fp-reg-tn-encoding value) + (when side + (assert double-p) + (setf double-p nil)) + (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base) + (reg-tn-encoding index) 0 (if scale 1 0) 0 0 1 + (or side 0) (if modify 1 0) value-encoding)))) + +(define-instruction flds (segment disp base result &key modify side) + (:declare (type tn base result) + (type (signed-byte 5) disp) + (type (member :before :after nil) modify) + (type (member nil 0 1) side)) + (:printer fp-load/store ((op #x0b) (x nil :type 'im5) (x1 1) (x2 0) (x3 0)) + `('FLDDS ,@cmplt-disp-print :tab x "(" s b ")," t)) + (:printer fp-load/store ((op #x09) (x nil :type 'im5) (x1 1) (x2 0) (x3 0)) + `('FLDWS ,@cmplt-disp-print :tab x "(" s b ")," t)) + (:emitter + (multiple-value-bind + (result-encoding double-p) + (fp-reg-tn-encoding result) + (when side + (assert double-p) + (setf double-p nil)) + (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base) + (short-disp-encoding segment disp) 0 + (if (eq modify :before) 1 0) 1 0 0 + (or side 0) (if modify 1 0) result-encoding)))) + +(define-instruction fsts (segment value disp base &key modify side) + (:declare (type tn base value) + (type (signed-byte 5) disp) + (type (member :before :after nil) modify) + (type (member nil 0 1) side)) + (:printer fp-load/store ((op #x0b) (x nil :type 'im5) (x1 1) (x2 0) (x3 1)) + `('FSTDS ,@cmplt-disp-print :tab t "," x "(" s b ")")) + (:printer fp-load/store ((op #x09) (x nil :type 'im5) (x1 1) (x2 0) (x3 1)) + `('FSTWS ,@cmplt-disp-print :tab t "," x "(" s b ")")) + (:emitter + (multiple-value-bind + (value-encoding double-p) + (fp-reg-tn-encoding value) + (when side + (assert double-p) + (setf double-p nil)) + (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base) + (short-disp-encoding segment disp) 0 + (if (eq modify :before) 1 0) 1 0 1 + (or side 0) (if modify 1 0) value-encoding)))) + + +(define-bitfield-emitter emit-fp-class-0-inst 32 + (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) (byte 2 11) (byte 2 9) + (byte 3 6) (byte 1 5) (byte 5 0)) + +(define-bitfield-emitter emit-fp-class-1-inst 32 + (byte 6 26) (byte 5 21) (byte 4 17) (byte 2 15) (byte 2 13) (byte 2 11) + (byte 2 9) (byte 3 6) (byte 1 5) (byte 5 0)) + +;;; Note: classes 2 and 3 are similar enough to class 0 that we don't need +;;; seperate emitters. + +(defconstant-eqx funops '(:copy :abs :sqrt :rnd) + #'equalp) + +(deftype funop () + `(member ,@funops)) + +(define-instruction funop (segment op from to) + (:declare (type funop op) + (type tn from to)) + (:printer fp-class-0-inst ((op1 #x0C) (op2 2) (x2 0)) + '('FCPY fmt :tab r "," t)) + (:printer fp-class-0-inst ((op1 #x0C) (op2 3) (x2 0)) + '('FABS fmt :tab r "," t)) + (:printer fp-class-0-inst ((op1 #x0C) (op2 4) (x2 0)) + '('FSQRT fmt :tab r "," t)) + (:printer fp-class-0-inst ((op1 #x0C) (op2 5) (x2 0)) + '('FRND fmt :tab r "," t)) + (:emitter + (multiple-value-bind + (from-encoding from-double-p) + (fp-reg-tn-encoding from) + (multiple-value-bind + (to-encoding to-double-p) + (fp-reg-tn-encoding to) + (assert (eq from-double-p to-double-p)) + (emit-fp-class-0-inst segment #x0C from-encoding 0 + (+ 2 (or (position op funops) + (error "Bogus FUNOP: ~S" op))) + (if to-double-p 1 0) 0 0 0 to-encoding))))) + +(macrolet ((define-class-1-fp-inst (name subcode) + `(define-instruction ,name (segment from to) + (:declare (type tn from to)) + (:printer fp-class-1-inst ((op1 #x0C) (x2 ,subcode)) + '(:name sf df :tab r "," t)) + (:emitter + (multiple-value-bind + (from-encoding from-double-p) + (fp-reg-tn-encoding from) + (multiple-value-bind + (to-encoding to-double-p) + (fp-reg-tn-encoding to) + (emit-fp-class-1-inst segment #x0C from-encoding 0 ,subcode + (if to-double-p 1 0) (if from-double-p 1 0) + 1 0 0 to-encoding))))))) + + (define-class-1-fp-inst fcnvff 0) + (define-class-1-fp-inst fcnvxf 1) + (define-class-1-fp-inst fcnvfx 2) + (define-class-1-fp-inst fcnvfxt 3)) + +(define-instruction fcmp (segment cond r1 r2) + (:declare (type (unsigned-byte 5) cond) + (type tn r1 r2)) + (:printer fp-class-0-inst ((op1 #x0C) (op2 0) (x2 2) (t nil :type 'fcmp-cond)) + '(:name fmt t :tab r "," x1)) + (:emitter + (multiple-value-bind + (r1-encoding r1-double-p) + (fp-reg-tn-encoding r1) + (multiple-value-bind + (r2-encoding r2-double-p) + (fp-reg-tn-encoding r2) + (assert (eq r1-double-p r2-double-p)) + (emit-fp-class-0-inst segment #x0C r1-encoding r2-encoding 0 + (if r1-double-p 1 0) 2 0 0 cond))))) + +(define-instruction ftest (segment) + (:printer fp-class-0-inst ((op1 #x0c) (op2 1) (x2 2)) '(:name)) + (:emitter + (emit-fp-class-0-inst segment #x0C 0 0 1 0 2 0 1 0))) + +(defconstant-eqx fbinops '(:add :sub :mpy :div) + #'equalp) + +(deftype fbinop () + `(member ,@fbinops)) + +(define-instruction fbinop (segment op r1 r2 result) + (:declare (type fbinop op) + (type tn r1 r2 result)) + (:printer fp-class-0-inst ((op1 #x0C) (op2 0) (x2 3)) + '('FADD fmt :tab r "," x1 "," t)) + (:printer fp-class-0-inst ((op1 #x0C) (op2 1) (x2 3)) + '('FSUB fmt :tab r "," x1 "," t)) + (:printer fp-class-0-inst ((op1 #x0C) (op2 2) (x2 3)) + '('FMPY fmt :tab r "," x1 "," t)) + (:printer fp-class-0-inst ((op1 #x0C) (op2 3) (x2 3)) + '('FDIV fmt :tab r "," x1 "," t)) + (:emitter + (multiple-value-bind + (r1-encoding r1-double-p) + (fp-reg-tn-encoding r1) + (multiple-value-bind + (r2-encoding r2-double-p) + (fp-reg-tn-encoding r2) + (assert (eq r1-double-p r2-double-p)) + (multiple-value-bind + (result-encoding result-double-p) + (fp-reg-tn-encoding result) + (assert (eq r1-double-p result-double-p)) + (emit-fp-class-0-inst segment #x0C r1-encoding r2-encoding + (or (position op fbinops) + (error "Bogus FBINOP: ~S" op)) + (if r1-double-p 1 0) 3 0 0 + result-encoding)))))) + + + +;;;; Instructions built out of other insts. + +(define-instruction-macro move (src dst &optional cond) + `(inst or ,src zero-tn ,dst ,cond)) + +(define-instruction-macro nop (&optional cond) + `(inst or zero-tn zero-tn zero-tn ,cond)) + +(define-instruction li (segment value reg) + (:declare (type tn reg) + (type (or fixup (signed-byte 32) (unsigned-byte 32)) value)) + (:vop-var vop) + (:emitter + (assemble (segment vop) + (etypecase value + (fixup + (inst ldil value reg) + (inst ldo value reg reg)) + ((signed-byte 14) + (inst ldo value zero-tn reg)) + ((or (signed-byte 32) (unsigned-byte 32)) + (let ((hi (ldb (byte 21 11) value)) + (lo (ldb (byte 11 0) value))) + (inst ldil hi reg) + (unless (zerop lo) + (inst ldo lo reg reg)))))))) + +(define-instruction-macro sll (src count result &optional cond) + (once-only ((result result) (src src) (count count) (cond cond)) + `(inst zdep ,src (- 31 ,count) (- 32 ,count) ,result ,cond))) + +(define-instruction-macro sra (src count result &optional cond) + (once-only ((result result) (src src) (count count) (cond cond)) + `(inst extrs ,src (- 31 ,count) (- 32 ,count) ,result ,cond))) + +(define-instruction-macro srl (src count result &optional cond) + (once-only ((result result) (src src) (count count) (cond cond)) + `(inst extru ,src (- 31 ,count) (- 32 ,count) ,result ,cond))) + +(defun maybe-negate-cond (cond negate) + (if negate + (multiple-value-bind + (value negate) + (compare-condition cond) + (if negate + (nth value compare-conditions) + (nth (+ value 8) compare-conditions))) + cond)) + +(define-instruction bc (segment cond not-p r1 r2 target) + (:declare (type compare-condition cond) + (type (member t nil) not-p) + (type tn r1 r2) + (type label target)) + (:vop-var vop) + (:emitter + (emit-chooser segment 8 2 + #'(lambda (segment posn delta) + (let ((disp (label-relative-displacement target posn delta))) + (when (<= 0 disp (1- (ash 1 11))) + (assemble (segment vop) + (inst comb (maybe-negate-cond cond not-p) r1 r2 target + :nullify t)) + t))) + #'(lambda (segment posn) + (let ((disp (label-relative-displacement target posn))) + (assemble (segment vop) + (cond ((<= (- (ash 1 11)) disp (1- (ash 1 11))) + (inst comb (maybe-negate-cond cond not-p) r1 r2 target) + (inst nop)) + (t + (inst comclr r1 r2 zero-tn + (maybe-negate-cond cond (not not-p))) + (inst b target :nullify t))))))))) + +(define-instruction bci (segment cond not-p imm reg target) + (:declare (type compare-condition cond) + (type (member t nil) not-p) + (type (signed-byte 11) imm) + (type tn reg) + (type label target)) + (:vop-var vop) + (:emitter + (emit-chooser segment 8 2 + #'(lambda (segment posn delta-if-after) + (let ((disp (label-relative-displacement target posn delta-if-after))) + (when (and (<= 0 disp (1- (ash 1 11))) + (<= (- (ash 1 4)) imm (1- (ash 1 4)))) + (assemble (segment vop) + (inst comib (maybe-negate-cond cond not-p) imm reg target + :nullify t)) + t))) + #'(lambda (segment posn) + (let ((disp (label-relative-displacement target posn))) + (assemble (segment vop) + (cond ((and (<= (- (ash 1 11)) disp (1- (ash 1 11))) + (<= (- (ash 1 4)) imm (1- (ash 1 4)))) + (inst comib (maybe-negate-cond cond not-p) imm reg target) + (inst nop)) + (t + (inst comiclr imm reg zero-tn + (maybe-negate-cond cond (not not-p))) + (inst b target :nullify t))))))))) + + +;;;; Instructions to convert between code ptrs, functions, and lras. + +(defun emit-compute-inst (segment vop src label temp dst calc) + (emit-chooser + ;; We emit either 12 or 4 bytes, so we maintain 3 byte alignments. + segment 12 3 + #'(lambda (segment posn delta-if-after) + (let ((delta (funcall calc label posn delta-if-after))) + (when (<= (- (ash 1 10)) delta (1- (ash 1 10))) + (emit-back-patch segment 4 + #'(lambda (segment posn) + (assemble (segment vop) + (inst addi (funcall calc label posn 0) src + dst)))) + t))) + #'(lambda (segment posn) + (let ((delta (funcall calc label posn 0))) + ;; Note: if we used addil/ldo to do this in 2 instructions then the + ;; intermediate value would be tagged but pointing into space. + (assemble (segment vop) + (inst ldil (ldb (byte 21 11) delta) temp) + (inst ldo (ldb (byte 11 0) delta) temp temp) + (inst add src temp dst)))))) + +;; code = fn - header - label-offset + other-pointer-tag +(define-instruction compute-code-from-fn (segment src label temp dst) + (:declare (type tn src dst temp) + (type label label)) + (:vop-var vop) + (:emitter + (emit-compute-inst segment vop src label temp dst + #'(lambda (label posn delta-if-after) + (- other-pointer-lowtag + (label-position label posn delta-if-after) + (component-header-length)))))) + +;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag +(define-instruction compute-code-from-lra (segment src label temp dst) + (:declare (type tn src dst temp) + (type label label)) + (:vop-var vop) + (:emitter + (emit-compute-inst segment vop src label temp dst + #'(lambda (label posn delta-if-after) + (- (+ (label-position label posn delta-if-after) + (component-header-length))))))) + +;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag +(define-instruction compute-lra-from-code (segment src label temp dst) + (:declare (type tn src dst temp) + (type label label)) + (:vop-var vop) + (:emitter + (emit-compute-inst segment vop src label temp dst + #'(lambda (label posn delta-if-after) + (+ (label-position label posn delta-if-after) + (component-header-length)))))) + + +;;;; Data instructions. + +(define-instruction byte (segment byte) + (:emitter + (emit-byte segment byte))) + +(define-bitfield-emitter emit-halfword 16 + (byte 16 0)) + +(define-instruction halfword (segment halfword) + (:emitter + (emit-halfword segment halfword))) + +(define-bitfield-emitter emit-word 32 + (byte 32 0)) + +(define-instruction word (segment word) + (:emitter + (emit-word segment word))) + +(define-instruction fun-header-word (segment) + (:emitter + (emit-back-patch + segment 4 + #'(lambda (segment posn) + (emit-word segment + (logior simple-fun-header-widetag + (ash (+ posn (component-header-length)) + (- n-widetag-bits word-shift)))))))) + +(define-instruction lra-header-word (segment) + (:emitter + (emit-back-patch + segment 4 + #'(lambda (segment posn) + (emit-word segment + (logior return-pc-header-widetag + (ash (+ posn (component-header-length)) + (- n-widetag-bits word-shift)))))))) diff --git a/src/compiler/hppa/macros.lisp b/src/compiler/hppa/macros.lisp new file mode 100644 index 0000000..d66bdae --- /dev/null +++ b/src/compiler/hppa/macros.lisp @@ -0,0 +1,383 @@ +(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 loadw (result base &optional (offset 0) (lowtag 0)) + (once-only ((result result) (base base)) + `(inst ldw (- (ash ,offset word-shift) ,lowtag) ,base ,result))) + +(defmacro storew (value base &optional (offset 0) (lowtag 0)) + (once-only ((value value) (base base) (offset offset) (lowtag lowtag)) + `(inst stw ,value (- (ash ,offset word-shift) ,lowtag) ,base))) + +(defmacro load-symbol (reg symbol) + (once-only ((reg reg) (symbol symbol)) + `(inst addi (static-symbol-offset ,symbol) null-tn ,reg))) + +(defmacro load-symbol-value (reg symbol) + `(inst ldw + (+ (static-symbol-offset ',symbol) + (ash symbol-value-slot word-shift) + (- other-pointer-lowtag)) + null-tn + ,reg)) + +(defmacro store-symbol-value (reg symbol) + `(inst stw ,reg (+ (static-symbol-offset ',symbol) + (ash symbol-value-slot word-shift) + (- other-pointer-lowtag)) + null-tn)) + +(defmacro load-type (target source &optional (offset 0)) + "Loads the type bits of a pointer into target independent of + byte-ordering issues." + (ecase *backend-byte-order* + (:little-endian + `(inst ldb ,offset ,source ,target)) + (:big-endian + `(inst ldb (+ ,offset 3) ,source ,target)))) + +;;; Macros to handle the fact that we cannot use the machine native call and +;;; return instructions. + +(defmacro lisp-jump (function) + "Jump to the lisp function FUNCTION. LIP is an interior-reg temporary." + `(progn + (inst addi + (- (ash simple-fun-code-offset word-shift) fun-pointer-lowtag) + ,function + lip-tn) + (inst bv lip-tn) + (move ,function code-tn))) + +(defmacro lisp-return (return-pc &key (offset 0) (frob-code t)) + "Return to RETURN-PC." + `(progn + (inst addi (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag) + ,return-pc lip-tn) + (inst bv lip-tn ,@(unless frob-code '(:nullify t))) + ,@(when frob-code + `((move ,return-pc code-tn))))) + +(defmacro emit-return-pc (label) + "Emit a return-pc header word. LABEL is the label to use for this + return-pc." + `(progn + (align n-lowtag-bits) + (emit-label ,label) + (inst lra-header-word))) + + +;;;; Stack TN's + +;;; Load-Stack-TN, Store-Stack-TN -- Interface +;;; +;;; Move a stack TN to a register and vice-versa. +;;; +(defmacro load-stack-tn (reg stack) + `(let ((reg ,reg) + (stack ,stack)) + (let ((offset (tn-offset stack))) + (sc-case stack + ((control-stack) + (loadw reg cfp-tn offset)))))) + +(defmacro store-stack-tn (stack reg) + `(let ((stack ,stack) + (reg ,reg)) + (let ((offset (tn-offset stack))) + (sc-case stack + ((control-stack) + (storew reg cfp-tn offset)))))) + + +;;; MAYBE-LOAD-STACK-TN -- Interface +;;; +(defmacro maybe-load-stack-tn (reg reg-or-stack) + "Move the TN Reg-Or-Stack into Reg if it isn't already there." + (once-only ((n-reg reg) + (n-stack reg-or-stack)) + `(sc-case ,n-reg + ((any-reg descriptor-reg) + (sc-case ,n-stack + ((any-reg descriptor-reg) + (move ,n-stack ,n-reg)) + ((control-stack) + (loadw ,n-reg cfp-tn (tn-offset ,n-stack)))))))) + + +;;;; Storage allocation: + +(defmacro with-fixed-allocation ((result-tn temp-tn type-code size) + &body body) + "Do stuff to allocate an other-pointer object of fixed Size with a single + word header having the specified Type-Code. The result is placed in + Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used + by the body.) The body is placed inside the PSEUDO-ATOMIC, and presumably + initializes the object." + (once-only ((result-tn result-tn) (temp-tn temp-tn) + (type-code type-code) (size size)) + `(pseudo-atomic (:extra (pad-data-block ,size)) + (inst move alloc-tn ,result-tn) + (inst dep other-pointer-lowtag 31 3 ,result-tn) + (inst li (logior (ash (1- ,size) n-widetag-bits) ,type-code) ,temp-tn) + (storew ,temp-tn ,result-tn 0 other-pointer-lowtag) + ,@body))) + + +;;;; Error Code + +(defvar *adjustable-vectors* nil) + +(defmacro with-adjustable-vector ((var) &rest body) + `(let ((,var (or (pop *adjustable-vectors*) + (make-array 16 + :element-type '(unsigned-byte 8) + :fill-pointer 0 + :adjustable t)))) + (declare (type (vector (unsigned-byte 8) 16) ,var)) + (setf (fill-pointer ,var) 0) + (unwind-protect + (progn + ,@body) + (push ,var *adjustable-vectors*)))) + +(eval-when (compile load eval) + (defun emit-error-break (vop kind code values) + (let ((vector (gensym))) + `((let ((vop ,vop)) + (when vop + (note-this-location vop :internal-error))) + (inst break ,kind) + (with-adjustable-vector (,vector) + (write-var-integer (error-number-or-lose ',code) ,vector) + ,@(mapcar #'(lambda (tn) + `(let ((tn ,tn)) + (write-var-integer (make-sc-offset (sc-number + (tn-sc tn)) + (tn-offset tn)) + ,vector))) + values) + (inst byte (length ,vector)) + (dotimes (i (length ,vector)) + (inst byte (aref ,vector i)))) + (align word-shift))))) + +(defmacro error-call (vop error-code &rest values) + "Cause an error. ERROR-CODE is the error to cause." + (cons 'progn + (emit-error-break vop error-trap error-code values))) + + +(defmacro cerror-call (vop label error-code &rest values) + "Cause a continuable error. If the error is continued, execution resumes at + LABEL." + `(progn + (inst b ,label) + ,@(emit-error-break vop cerror-trap error-code values))) + +(defmacro generate-error-code (vop error-code &rest values) + "Generate-Error-Code Error-code Value* + Emit code for an error with the specified Error-Code and context Values." + `(assemble (*elsewhere*) + (let ((start-lab (gen-label))) + (emit-label start-lab) + (error-call ,vop ,error-code ,@values) + start-lab))) + +(defmacro generate-cerror-code (vop error-code &rest values) + "Generate-CError-Code Error-code Value* + Emit code for a continuable error with the specified Error-Code and + context Values. If the error is continued, execution resumes after + the GENERATE-CERROR-CODE form." + (let ((continue (gensym "CONTINUE-LABEL-")) + (error (gensym "ERROR-LABEL-"))) + `(let ((,continue (gen-label))) + (emit-label ,continue) + (assemble (*elsewhere*) + (let ((,error (gen-label))) + (emit-label ,error) + (cerror-call ,vop ,continue ,error-code ,@values) + ,error))))) + + + +;;; PSEUDO-ATOMIC -- Handy macro for making sequences look atomic. +;;; +(defmacro pseudo-atomic ((&key (extra 0)) &rest forms) + (let ((n-extra (gensym))) + `(let ((,n-extra ,extra)) + (inst addi 4 alloc-tn alloc-tn) + ,@forms + (inst addit (- ,n-extra 4) alloc-tn alloc-tn :od)))) + + + +;;;; Indexed references: + +(deftype load/store-index (scale lowtag min-offset + &optional (max-offset min-offset)) + `(integer ,(- (truncate (+ (ash 1 14) + (* min-offset n-word-bytes) + (- lowtag)) + scale)) + ,(truncate (- (+ (1- (ash 1 14)) lowtag) + (* max-offset n-word-bytes)) + scale))) + +(defmacro define-full-reffer (name type offset lowtag scs el-type + &optional translate) + `(progn + (define-vop (,name) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to (:eval 0)) + (index :scs (any-reg) :target temp)) + (:arg-types ,type tagged-num) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp) + (:results (value :scs ,scs)) + (:result-types ,el-type) + (:generator 5 + (inst addi (- (* ,offset n-word-bytes) ,lowtag) index temp) + (inst ldwx temp object value))) + (define-vop (,(symbolicate name "-C")) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:info index) + (:arg-types ,type + (:constant (load/store-index ,n-word-bytes ,(eval lowtag) + ,(eval offset)))) + (:results (value :scs ,scs)) + (:result-types ,el-type) + (:generator 4 + (inst ldw (- (* (+ ,offset index) n-word-bytes) ,lowtag) + object value))))) + +(defmacro define-full-setter (name type offset lowtag scs el-type + &optional translate) + `(progn + (define-vop (,name) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs ,scs :target result)) + (:arg-types ,type tagged-num ,el-type) + (:temporary (:scs (interior-reg)) lip) + (:results (result :scs ,scs)) + (:result-types ,el-type) + (:generator 2 + (inst add object index lip) + (inst stw value (- (* ,offset n-word-bytes) ,lowtag) lip) + (move value result))) + (define-vop (,(symbolicate name "-C")) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (value :scs ,scs)) + (:info index) + (:arg-types ,type + (:constant (load/store-index ,n-word-bytes ,(eval lowtag) + ,(eval offset))) + ,el-type) + (:results (result :scs ,scs)) + (:result-types ,el-type) + (:generator 1 + (inst stw value (- (* (+ ,offset index) n-word-bytes) ,lowtag) object) + (move value result))))) + + +(defmacro define-partial-reffer (name type size signed offset lowtag scs + el-type &optional translate) + (let ((scale (ecase size (:byte 1) (:short 2)))) + `(progn + (define-vop (,name) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to (:eval 0)) + (index :scs (unsigned-reg))) + (:arg-types ,type positive-fixnum) + (:results (value :scs ,scs)) + (:result-types ,el-type) + (:temporary (:scs (interior-reg)) lip) + (:generator 5 + (inst ,(ecase size (:byte 'add) (:short 'sh1add)) + index object lip) + (inst ,(ecase size (:byte 'ldb) (:short 'ldh)) + (- (* ,offset n-word-bytes) ,lowtag) lip value) + ,@(when signed + `((inst extrs value 31 ,(* scale n-byte-bits) value))))) + (define-vop (,(symbolicate name "-C")) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:info index) + (:arg-types ,type + (:constant (load/store-index ,scale + ,(eval lowtag) + ,(eval offset)))) + (:results (value :scs ,scs)) + (:result-types ,el-type) + (:generator 5 + (inst ,(ecase size (:byte 'ldb) (:short 'ldh)) + (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag) + object value) + ,@(when signed + `((inst extrs value 31 ,(* scale n-byte-bits) value)))))))) + +(defmacro define-partial-setter (name type size offset lowtag scs el-type + &optional translate) + (let ((scale (ecase size (:byte 1) (:short 2)))) + `(progn + (define-vop (,name) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (unsigned-reg)) + (value :scs ,scs :target result)) + (:arg-types ,type positive-fixnum ,el-type) + (:temporary (:scs (interior-reg)) lip) + (:results (result :scs ,scs)) + (:result-types ,el-type) + (:generator 5 + (inst ,(ecase size (:byte 'add) (:short 'sh1add)) + index object lip) + (inst ,(ecase size (:byte 'stb) (:short 'sth)) + value (- (* ,offset n-word-bytes) ,lowtag) lip) + (move value result))) + (define-vop (,(symbolicate name "-C")) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (value :scs ,scs :target result)) + (:info index) + (:arg-types ,type + (:constant (load/store-index ,scale + ,(eval lowtag) + ,(eval offset))) + ,el-type) + (:results (result :scs ,scs)) + (:result-types ,el-type) + (:generator 5 + (inst ,(ecase size (:byte 'stb) (:short 'sth)) + value + (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag) + object) + (move value result)))))) + diff --git a/src/compiler/hppa/memory.lisp b/src/compiler/hppa/memory.lisp new file mode 100644 index 0000000..8d7abd1 --- /dev/null +++ b/src/compiler/hppa/memory.lisp @@ -0,0 +1,44 @@ +(in-package "SB!VM") + +;;; Cell-Ref and Cell-Set are used to define VOPs like CAR, where the offset to +;;; be read or written is a property of the VOP used. Cell-Setf is similar to +;;; Cell-Set, but delivers the new value as the result. Cell-Setf-Function +;;; takes its arguments as if it were a setf function (new value first, as +;;; apposed to a setf macro, which takes the new value last). +;;; +(define-vop (cell-ref) + (:args (object :scs (descriptor-reg))) + (:results (value :scs (descriptor-reg any-reg))) + (:variant-vars offset lowtag) + (:policy :fast-safe) + (:generator 4 + (loadw value object offset lowtag))) +;;; +(define-vop (cell-set) + (:args (object :scs (descriptor-reg)) + (value :scs (descriptor-reg any-reg))) + (:variant-vars offset lowtag) + (:policy :fast-safe) + (:generator 1 + (storew value object offset lowtag))) + +;;; Slot-Ref and Slot-Set are used to define VOPs like Closure-Ref, where the +;;; offset is constant at compile time, but varies for different uses. We add +;;; in the stardard g-vector overhead. +;;; +(define-vop (slot-ref) + (:args (object :scs (descriptor-reg))) + (:results (value :scs (descriptor-reg any-reg))) + (:variant-vars base lowtag) + (:info offset) + (:generator 4 + (loadw value object (+ base offset) lowtag))) +;;; +(define-vop (slot-set) + (:args (object :scs (descriptor-reg)) + (value :scs (descriptor-reg any-reg))) + (:variant-vars base lowtag) + (:info offset) + (:generator 1 + (storew value object (+ base offset) lowtag))) + diff --git a/src/compiler/hppa/move.lisp b/src/compiler/hppa/move.lisp new file mode 100644 index 0000000..0ce19c1 --- /dev/null +++ b/src/compiler/hppa/move.lisp @@ -0,0 +1,290 @@ +(in-package "SB!VM") + +(define-move-fun (load-immediate 1) (vop x y) + ((null zero immediate) + (any-reg descriptor-reg)) + (let ((val (tn-value x))) + (etypecase val + (integer + (inst li (fixnumize val) y)) + (null + (move null-tn y)) + (symbol + (load-symbol y val)) + (character + (inst li (logior (ash (char-code val) n-widetag-bits) + base-char-widetag) + y))))) + +(define-move-fun (load-number 1) (vop x y) + ((immediate zero) + (signed-reg unsigned-reg)) + (let ((x (tn-value x))) + (inst li (if (>= x (ash 1 31)) (logior (ash -1 32) x) x) y))) + +(define-move-fun (load-base-char 1) (vop x y) + ((immediate) (base-char-reg)) + (inst li (char-code (tn-value x)) y)) + +(define-move-fun (load-system-area-pointer 1) (vop x y) + ((immediate) (sap-reg)) + (inst li (sap-int (tn-value x)) y)) + +(define-move-fun (load-constant 5) (vop x y) + ((constant) (descriptor-reg)) + (loadw y code-tn (tn-offset x) other-pointer-lowtag)) + +(define-move-fun (load-stack 5) (vop x y) + ((control-stack) (any-reg descriptor-reg)) + (load-stack-tn y x)) + +(define-move-fun (load-number-stack 5) (vop x y) + ((base-char-stack) (base-char-reg) + (sap-stack) (sap-reg) + (signed-stack) (signed-reg) + (unsigned-stack) (unsigned-reg)) + (let ((nfp (current-nfp-tn vop))) + (loadw y nfp (tn-offset x)))) + +(define-move-fun (store-stack 5) (vop x y) + ((any-reg descriptor-reg) (control-stack)) + (store-stack-tn y x)) + +(define-move-fun (store-number-stack 5) (vop x y) + ((base-char-reg) (base-char-stack) + (sap-reg) (sap-stack) + (signed-reg) (signed-stack) + (unsigned-reg) (unsigned-stack)) + (let ((nfp (current-nfp-tn vop))) + (storew x nfp (tn-offset y)))) + + +;;;; The Move VOP: +;;; +(define-vop (move) + (:args (x :target y + :scs (any-reg descriptor-reg) + :load-if (not (location= x y)))) + (:results (y :scs (any-reg descriptor-reg) + :load-if (not (location= x y)))) + (:effects) + (:affected) + (:generator 0 + (move x y))) + +(define-move-vop move :move + (any-reg descriptor-reg) + (any-reg descriptor-reg)) + +;;; Make Move the check VOP for T so that type check generation doesn't think +;;; it is a hairy type. This also allows checking of a few of the values in a +;;; continuation to fall out. +;;; +(primitive-type-vop move (:check) t) + +;;; The Move-Argument VOP is used for moving descriptor values into another +;;; frame for argument or known value passing. +;;; +(define-vop (move-argument) + (:args (x :target y + :scs (any-reg descriptor-reg)) + (fp :scs (any-reg) + :load-if (not (sc-is y any-reg descriptor-reg)))) + (:results (y)) + (:generator 0 + (sc-case y + ((any-reg descriptor-reg) + (move x y)) + (control-stack + (storew x fp (tn-offset y)))))) +;;; +(define-move-vop move-argument :move-arg + (any-reg descriptor-reg) + (any-reg descriptor-reg)) + + + +;;;; ILLEGAL-MOVE + +;;; This VOP exists just to begin the lifetime of a TN that couldn't be written +;;; legally due to a type error. An error is signalled before this VOP is +;;; so we don't need to do anything (not that there would be anything sensible +;;; to do anyway.) +;;; +(define-vop (illegal-move) + (:args (x) (type)) + (:results (y)) + (:ignore y) + (:vop-var vop) + (:save-p :compute-only) + (:generator 666 + (error-call vop object-not-type-error x type))) + + + +;;;; Moves and coercions: + +;;; These MOVE-TO-WORD VOPs move a tagged integer to a raw full-word +;;; representation. Similarly, the MOVE-FROM-WORD VOPs converts a raw integer +;;; to a tagged bignum or fixnum. + +;;; Arg is a fixnum, so just shift it. We need a type restriction because some +;;; possible arg SCs (control-stack) overlap with possible bignum arg SCs. +;;; +(define-vop (move-to-word/fixnum) + (:args (x :scs (any-reg descriptor-reg))) + (:results (y :scs (signed-reg unsigned-reg))) + (:arg-types tagged-num) + (:note "fixnum untagging") + (:generator 1 + (inst sra x 2 y))) +;;; +(define-move-vop move-to-word/fixnum :move + (any-reg descriptor-reg) (signed-reg unsigned-reg)) + +;;; Arg is a non-immediate constant, load it. +(define-vop (move-to-word-c) + (:args (x :scs (constant))) + (:results (y :scs (signed-reg unsigned-reg))) + (:note "constant load") + (:generator 1 + (inst li (tn-value x) y))) +;;; +(define-move-vop move-to-word-c :move + (constant) (signed-reg unsigned-reg)) + +;;; Arg is a fixnum or bignum, figure out which and load if necessary. +(define-vop (move-to-word/integer) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (signed-reg unsigned-reg))) + (:note "integer to untagged word coercion") + (:generator 3 + (inst extru x 31 2 zero-tn :<>) + (inst sra x 2 y :tr) + (loadw y x bignum-digits-offset other-pointer-lowtag))) +;;; +(define-move-vop move-to-word/integer :move + (descriptor-reg) (signed-reg unsigned-reg)) + +;;; Result is a fixnum, so we can just shift. We need the result type +;;; restriction because of the control-stack ambiguity noted above. +;;; +(define-vop (move-from-word/fixnum) + (:args (x :scs (signed-reg unsigned-reg))) + (:results (y :scs (any-reg descriptor-reg))) + (:result-types tagged-num) + (:note "fixnum tagging") + (:generator 1 + (inst sll x 2 y))) +;;; +(define-move-vop move-from-word/fixnum :move + (signed-reg unsigned-reg) (any-reg descriptor-reg)) + +;;; Result may be a bignum, so we have to check. Use a worst-case cost to make +;;; sure people know they may be number consing. +;;; +(define-vop (move-from-signed) + (:args (x :scs (signed-reg unsigned-reg) :to (:eval 1))) + (:results (y :scs (any-reg descriptor-reg) :from (:eval 0))) + (:temporary (:scs (non-descriptor-reg)) temp) + (:note "signed word to integer coercion") + (:generator 18 + ;; Extract the top three bits. + (inst extrs x 2 3 temp :=) + ;; Invert them (unless they are already zero). + (inst uaddcm zero-tn temp temp) + ;; If we are left with zero, it will fit in a fixnum. So branch around + ;; the bignum-construction, doing the shift in the delay slot. + (inst comb := temp zero-tn done) + (inst sll x 2 y) + ;; Make a single-digit bignum. + (with-fixed-allocation (y temp bignum-widetag (1+ bignum-digits-offset)) + (storew x y bignum-digits-offset other-pointer-lowtag)) + DONE)) +;;; +(define-move-vop move-from-signed :move + (signed-reg) (descriptor-reg)) + + +;;; Check for fixnum, and possibly allocate one or two word bignum result. Use +;;; a worst-case cost to make sure people know they may be number consing. +;;; +(define-vop (move-from-unsigned) + (:args (x :scs (signed-reg unsigned-reg) :to (:eval 1))) + (:results (y :scs (any-reg descriptor-reg) :from (:eval 0))) + (:temporary (:scs (non-descriptor-reg)) temp) + (:note "unsigned word to integer coercion") + (:generator 20 + ;; Grab the top three bits. + (inst extrs x 2 3 temp) + ;; If zero, it will fit as a fixnum. + (inst comib := 0 temp done) + (inst sll x 2 y) + ;; Make a bignum. + (pseudo-atomic (:extra (pad-data-block (1+ bignum-digits-offset))) + ;; Create the result pointer. + (inst move alloc-tn y) + (inst dep other-pointer-lowtag 31 3 y) + ;; Check the high bit, and skip the next instruction it it's 0. + (inst comclr x zero-tn zero-tn :>=) + ;; The high bit is set, so allocate enough space for a two-word bignum. + ;; We always skip the following instruction, so it is only executed + ;; when we want one word. + (inst addi (pad-data-block 1) alloc-tn alloc-tn :tr) + ;; Set up the header for one word. Use addi instead of li so we can + ;; skip the next instruction. + (inst addi (logior (ash 1 n-widetag-bits) bignum-widetag) zero-tn temp :tr) + ;; Set up the header for two words. + (inst li (logior (ash 2 n-widetag-bits) bignum-widetag) temp) + ;; Store the header and the data. + (storew temp y 0 other-pointer-lowtag) + (storew x y bignum-digits-offset other-pointer-lowtag)) + DONE)) +;;; +(define-move-vop move-from-unsigned :move + (unsigned-reg) (descriptor-reg)) + + +;;; Move untagged numbers. +;;; +(define-vop (word-move) + (:args (x :target y + :scs (signed-reg unsigned-reg) + :load-if (not (location= x y)))) + (:results (y :scs (signed-reg unsigned-reg) + :load-if (not (location= x y)))) + (:effects) + (:affected) + (:note "word integer move") + (:generator 0 + (move x y))) +;;; +(define-move-vop word-move :move + (signed-reg unsigned-reg) (signed-reg unsigned-reg)) + + +;;; Move untagged number arguments/return-values. +;;; +(define-vop (move-word-argument) + (:args (x :target y + :scs (signed-reg unsigned-reg)) + (fp :scs (any-reg) + :load-if (not (sc-is y sap-reg)))) + (:results (y)) + (:note "word integer argument move") + (:generator 0 + (sc-case y + ((signed-reg unsigned-reg) + (move x y)) + ((signed-stack unsigned-stack) + (storew x fp (tn-offset y)))))) +;;; +(define-move-vop move-word-argument :move-arg + (descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg)) + + +;;; Use standard MOVE-ARGUMENT + coercion to move an untagged number to a +;;; descriptor passing location. +;;; +(define-move-vop move-argument :move-arg + (signed-reg unsigned-reg) (any-reg descriptor-reg)) diff --git a/src/compiler/hppa/nlx.lisp b/src/compiler/hppa/nlx.lisp new file mode 100644 index 0000000..a9af920 --- /dev/null +++ b/src/compiler/hppa/nlx.lisp @@ -0,0 +1,258 @@ +(in-package "SB!VM") + +;;; MAKE-NLX-SP-TN -- Interface +;;; +;;; Make an environment-live stack TN for saving the SP for NLX entry. +;;; +(!def-vm-support-routine make-nlx-sp-tn (env) + (physenv-live-tn + (make-representation-tn *fixnum-primitive-type* immediate-arg-scn) + env)) + +;;; Make-NLX-Entry-Argument-Start-Location -- Interface +;;; +;;; Make a TN for the argument count passing location for a +;;; non-local entry. +;;; +(!def-vm-support-routine make-nlx-entry-arg-start-location () + (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ocfp-offset)) + + +;;; Save and restore dynamic environment. +;;; +;;; These VOPs are used in the reentered function to restore the appropriate +;;; dynamic environment. Currently we only save the Current-Catch and binding +;;; stack pointer. We don't need to save/restore the current unwind-protect, +;;; since unwind-protects are implicitly processed during unwinding. If there +;;; were any additional stacks, then this would be the place to restore the top +;;; pointers. + + +;;; Make-Dynamic-State-TNs -- Interface +;;; +;;; Return a list of TNs that can be used to snapshot the dynamic state for +;;; use with the Save/Restore-Dynamic-Environment VOPs. +;;; +(!def-vm-support-routine make-dynamic-state-tns () + (make-n-tns 4 *backend-t-primitive-type*)) + +(define-vop (save-dynamic-state) + (:results (catch :scs (descriptor-reg)) + (nfp :scs (descriptor-reg)) + (nsp :scs (descriptor-reg))) + (:vop-var vop) + (:generator 13 + (load-symbol-value catch *current-catch-block*) + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (move cur-nfp nfp))) + (move nsp-tn nsp))) + +(define-vop (restore-dynamic-state) + (:args (catch :scs (descriptor-reg)) + (nfp :scs (descriptor-reg)) + (nsp :scs (descriptor-reg))) + (:vop-var vop) + (:generator 10 + (store-symbol-value catch *current-catch-block*) + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (move nfp cur-nfp))) + (move nsp nsp-tn))) + +(define-vop (current-stack-pointer) + (:results (res :scs (any-reg descriptor-reg))) + (:generator 1 + (move csp-tn res))) + +(define-vop (current-binding-pointer) + (:results (res :scs (any-reg descriptor-reg))) + (:generator 1 + (move bsp-tn res))) + + +;;;; Unwind block hackery: + +;;; Compute the address of the catch block from its TN, then store into the +;;; block the current Fp, Env, Unwind-Protect, and the entry PC. +;;; +(define-vop (make-unwind-block) + (:args (tn)) + (:info entry-label) + (:results (block :scs (any-reg))) + (:temporary (:scs (descriptor-reg)) temp) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:generator 22 + (inst addi (* (tn-offset tn) n-word-bytes) cfp-tn block) + (load-symbol-value temp *current-unwind-protect-block*) + (storew temp block unwind-block-current-uwp-slot) + (storew cfp-tn block unwind-block-current-cont-slot) + (storew code-tn block unwind-block-current-code-slot) + (inst compute-lra-from-code code-tn entry-label ndescr temp) + (storew temp block catch-block-entry-pc-slot))) + +;;; Like Make-Unwind-Block, except that we also store in the specified tag, and +;;; link the block into the Current-Catch list. +;;; +(define-vop (make-catch-block) + (:args (tn) + (tag :scs (descriptor-reg))) + (:info entry-label) + (:results (block :scs (any-reg) :from (:argument 0))) + (:temporary (:scs (descriptor-reg)) temp) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:generator 44 + (inst addi (* (tn-offset tn) n-word-bytes) cfp-tn block) + (load-symbol-value temp *current-unwind-protect-block*) + (storew temp block catch-block-current-uwp-slot) + (storew cfp-tn block catch-block-current-cont-slot) + (storew code-tn block catch-block-current-code-slot) + (inst compute-lra-from-code code-tn entry-label ndescr temp) + (storew temp block catch-block-entry-pc-slot) + + (storew tag block catch-block-tag-slot) + (load-symbol-value temp *current-catch-block*) + (storew temp block catch-block-previous-catch-slot) + (store-symbol-value block *current-catch-block*))) + + +;;; Just set the current unwind-protect to TN's address. This instantiates an +;;; unwind block as an unwind-protect. +;;; +(define-vop (set-unwind-protect) + (:args (tn)) + (:temporary (:scs (descriptor-reg)) new-uwp) + (:generator 7 + (inst addi (* (tn-offset tn) n-word-bytes) cfp-tn new-uwp) + (store-symbol-value new-uwp *current-unwind-protect-block*))) + + +(define-vop (unlink-catch-block) + (:temporary (:scs (any-reg)) block) + (:policy :fast-safe) + (:translate %catch-breakup) + (:generator 17 + (load-symbol-value block *current-catch-block*) + (loadw block block catch-block-previous-catch-slot) + (store-symbol-value block *current-catch-block*))) + +(define-vop (unlink-unwind-protect) + (:temporary (:scs (any-reg)) block) + (:policy :fast-safe) + (:translate %unwind-protect-breakup) + (:generator 17 + (load-symbol-value block *current-unwind-protect-block*) + (loadw block block unwind-block-current-uwp-slot) + (store-symbol-value block *current-unwind-protect-block*))) + + +;;;; NLX entry VOPs: + + +(define-vop (nlx-entry) + (:args (sp) ; Note: we can't list an sc-restriction, 'cause any load vops + ; would be inserted before the LRA. + (start) + (count)) + (:results (values :more t)) + (:temporary (:scs (descriptor-reg)) move-temp) + (:info label nvals) + (:save-p :force-to-stack) + (:vop-var vop) + (:generator 30 + (emit-return-pc label) + (note-this-location vop :non-local-entry) + (cond ((zerop nvals)) + ((= nvals 1) + (inst comclr count zero-tn zero-tn :<>) + (inst move null-tn (tn-ref-tn values) :tr) + (loadw (tn-ref-tn values) start)) + (t + (collect ((defaults)) + (do ((i 0 (1+ i)) + (tn-ref values (tn-ref-across tn-ref))) + ((null tn-ref)) + (let ((default-lab (gen-label)) + (tn (tn-ref-tn tn-ref))) + (defaults (cons default-lab tn)) + + (inst bci := nil (fixnumize i) count default-lab) + (sc-case tn + ((descriptor-reg any-reg) + (loadw tn start i)) + (control-stack + (loadw move-temp start i) + (store-stack-tn tn move-temp))))) + + (let ((defaulting-done (gen-label))) + (emit-label defaulting-done) + + (assemble (*elsewhere*) + (do ((defs (defaults) (cdr defs))) + ((null defs)) + (let ((def (car defs))) + (emit-label (car def)) + (unless (cdr defs) + (inst b defaulting-done)) + (let ((tn (cdr def))) + (sc-case tn + ((descriptor-reg any-reg) + (move null-tn tn)) + (control-stack + (store-stack-tn tn null-tn))))))))))) + (load-stack-tn csp-tn sp))) + + +(define-vop (nlx-entry-multiple) + (:args (top :target dst) (start :target src) (count :target num)) + ;; Again, no SC restrictions for the args, 'cause the loading would + ;; happen before the entry label. + (:info label) + (:temporary (:scs (any-reg) :from (:argument 0)) dst) + (:temporary (:scs (any-reg) :from (:argument 1)) src) + (:temporary (:scs (any-reg) :from (:argument 2)) num) + (:temporary (:scs (descriptor-reg)) temp) + (:results (new-start) (new-count)) + (:save-p :force-to-stack) + (:vop-var vop) + (:generator 30 + (emit-return-pc label) + (note-this-location vop :non-local-entry) + + ;; Copy args. + (load-stack-tn dst top) + (move start src) + (move count num) + + ;; Establish results. + (sc-case new-start + (any-reg (move dst new-start)) + (control-stack (store-stack-tn new-start dst))) + (inst comb := num zero-tn done) + (sc-case new-count + (any-reg (inst move num new-count)) + (control-stack (store-stack-tn new-count num))) + ;; Load the first word. + (inst ldwm n-word-bytes src temp) + + ;; Copy stuff on stack. + LOOP + (inst stwm temp n-word-bytes dst) + (inst addib :<> (fixnumize -1) num loop :nullify t) + (inst ldwm n-word-bytes src temp) + + DONE + (inst move dst csp-tn))) + + +;;; This VOP is just to force the TNs used in the cleanup onto the stack. +;;; +(define-vop (uwp-entry) + (:info label) + (:save-p :force-to-stack) + (:results (block) (start) (count)) + (:ignore block start count) + (:vop-var vop) + (:generator 0 + (emit-return-pc label) + (note-this-location vop :non-local-entry))) diff --git a/src/compiler/hppa/parms.lisp b/src/compiler/hppa/parms.lisp new file mode 100644 index 0000000..3ebb8b2 --- /dev/null +++ b/src/compiler/hppa/parms.lisp @@ -0,0 +1,168 @@ +(in-package "SB!VM") + + +;;;; Machine Architecture parameters: + +(def!constant n-word-bits 32 + "Number of bits per word where a word holds one lisp descriptor.") + +(def!constant n-byte-bits 8 + "Number of bits per byte where a byte is the smallest addressable object.") + +(def!constant word-shift (1- (integer-length (/ n-word-bits n-byte-bits))) + "Number of bits to shift between word addresses and byte addresses.") + +(def!constant n-word-bytes (/ n-word-bits n-byte-bits) + "Number of bytes in a word.") + +(def!constant float-sign-shift 31) + +(def!constant single-float-bias 126) +(defconstant-eqx single-float-exponent-byte (byte 8 23) #'equal) +(defconstant-eqx single-float-significand-byte (byte 23 0) #'equal) +(def!constant single-float-normal-exponent-min 1) +(def!constant single-float-normal-exponent-max 254) +(def!constant single-float-hidden-bit (ash 1 23)) +(def!constant single-float-trapping-nan-bit (ash 1 22)) + +(def!constant double-float-bias 1022) +(defconstant-eqx double-float-exponent-byte (byte 11 20) #'equal) +(defconstant-eqx double-float-significand-byte (byte 20 0) #'equal) +(def!constant double-float-normal-exponent-min 1) +(def!constant double-float-normal-exponent-max #x7FE) +(def!constant double-float-hidden-bit (ash 1 20)) +(def!constant double-float-trapping-nan-bit (ash 1 19)) + +(def!constant single-float-digits + (+ (byte-size single-float-significand-byte) 1)) + +(def!constant double-float-digits + (+ (byte-size double-float-significand-byte) n-word-bits 1)) + +(def!constant float-inexact-trap-bit (ash 1 0)) +(def!constant float-underflow-trap-bit (ash 1 1)) +(def!constant float-overflow-trap-bit (ash 1 2)) +(def!constant float-divide-by-zero-trap-bit (ash 1 3)) +(def!constant float-invalid-trap-bit (ash 1 4)) + +(def!constant float-round-to-nearest 0) +(def!constant float-round-to-zero 1) +(def!constant float-round-to-positive 2) +(def!constant float-round-to-negative 3) + +(defconstant-eqx float-rounding-mode (byte 2 7) #'equal) +(defconstant-eqx float-sticky-bits (byte 5 27) #'equal) +(defconstant-eqx float-traps-byte (byte 5 0) #'equal) +(defconstant-eqx float-exceptions-byte (byte 5 27) #'equal) +(def!constant float-condition-bit (ash 1 26)) +(def!constant float-fast-bit 0) ; No fast mode on HPPA. + + + +;;;; Description of the target address space. + +;;; Where to put the different spaces. +;;; +(def!constant read-only-space-start #x20000000) +(def!constant read-only-space-end #x24000000) + +(def!constant binding-stack-start #x24000000) +(def!constant binding-stack-end #x24ff0000) + +(def!constant control-stack-start #x25000000) +(def!constant control-stack-end #x25ff0000) + +(def!constant static-space-start #x28000000) +(def!constant static-space-end #x2a000000) + +(def!constant dynamic-space-start #x30000000) +(def!constant dynamic-space-end #x37fff000) + +(def!constant dynamic-0-space-start #x30000000) +(def!constant dynamic-0-space-end #x37fff000) +(def!constant dynamic-1-space-start #x38000000) +(def!constant dynamic-1-space-end #x3ffff000) + +;;; FIXME: WTF are these for? + +;; The space-register holding the lisp heap. +(def!constant lisp-heap-space 5) + +;; The space-register holding the C text segment. +(def!constant c-text-space 4) + + +;;;; Other random constants. + +(defenum (:suffix -trap :start 8) + halt + pending-interrupt + error + cerror + breakpoint + fun-end-breakpoint + single-step-breakpoint) + +(defenum (:prefix trace-table-) + normal + call-site + fun-prologue + fun-epilogue) + + + +;;;; Static symbols. + +;;; These symbols are loaded into static space directly after NIL so +;;; that the system can compute their address by adding a constant +;;; amount to NIL. +;;; +;;; The fdefn objects for the static functions are loaded into static +;;; space directly after the static symbols. That way, the raw-addr +;;; can be loaded directly out of them by indirecting relative to NIL. +;;; +(defparameter *static-symbols* + '(t + + ;; The C startup code must fill these in. + *posix-argv* + + ;; Functions that the C code needs to call + sb!impl::maybe-gc + sb!kernel::internal-error + sb!kernel::control-stack-exhausted-error + sb!di::handle-breakpoint + sb!impl::fdefinition-object + + ;; Free Pointers. + *read-only-space-free-pointer* + *static-space-free-pointer* + *initial-dynamic-space-free-pointer* + + ;; Things needed for non-local-exit. + *current-catch-block* + *current-unwind-protect-block* + + ;; Interrupt Handling + *free-interrupt-context-index* + sb!unix::*interrupts-enabled* + sb!unix::*interrupt-pending* + )) + +(defparameter *static-funs* + '(length + sb!kernel:two-arg-+ + sb!kernel:two-arg-- + sb!kernel:two-arg-* + sb!kernel:two-arg-/ + sb!kernel:two-arg-< + sb!kernel:two-arg-> + sb!kernel:two-arg-= + eql + sb!kernel:%negate + sb!kernel:two-arg-and + sb!kernel:two-arg-ior + sb!kernel:two-arg-xor + sb!kernel:two-arg-gcd + sb!kernel:two-arg-lcm + )) diff --git a/src/compiler/hppa/pred.lisp b/src/compiler/hppa/pred.lisp new file mode 100644 index 0000000..894ff0b --- /dev/null +++ b/src/compiler/hppa/pred.lisp @@ -0,0 +1,25 @@ +(in-package "SB!VM") + + +;;;; The Branch VOP. + +;;; The unconditional branch, emitted when we can't drop through to the desired +;;; destination. Dest is the continuation we transfer control to. +;;; +(define-vop (branch) + (:info dest) + (:generator 5 + (inst b dest :nullify t))) + + +;;;; Conditional VOPs: + +(define-vop (if-eq) + (:args (x :scs (any-reg descriptor-reg zero null)) + (y :scs (any-reg descriptor-reg zero null))) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:translate eq) + (:generator 3 + (inst bc := not-p x y target))) diff --git a/src/compiler/hppa/sanctify.lisp b/src/compiler/hppa/sanctify.lisp new file mode 100644 index 0000000..2c8f9b0 --- /dev/null +++ b/src/compiler/hppa/sanctify.lisp @@ -0,0 +1,26 @@ +;;;; Do whatever is necessary to make the given code component +;;;; executable. + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; While most of SBCL is derived from the CMU CL system, the test +;;;; files (like this one) were written from scratch after the fork +;;;; from CMU CL. +;;;; +;;;; This software is in the public domain and is provided with +;;;; absolutely no warranty. See the COPYING and CREDITS files for +;;;; more information. + +(in-package :sb!vm) + +(defun sanctify-for-execution (component) + (without-gcing + (alien-funcall (extern-alien "sanctify_for_execution" + (function void + system-area-pointer + unsigned-long)) + (code-instructions component) + (* (code-header-ref component code-code-size-slot) + n-word-bytes))) + nil) diff --git a/src/compiler/hppa/sap.lisp b/src/compiler/hppa/sap.lisp new file mode 100644 index 0000000..48da088 --- /dev/null +++ b/src/compiler/hppa/sap.lisp @@ -0,0 +1,290 @@ +(in-package "SB!VM") + + +;;;; Moves and coercions: + +;;; Move a tagged SAP to an untagged representation. +;;; +(define-vop (move-to-sap) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (sap-reg))) + (:note "system area pointer indirection") + (:generator 1 + (loadw y x sap-pointer-slot other-pointer-lowtag))) + +;;; +(define-move-vop move-to-sap :move + (descriptor-reg) (sap-reg)) + + +;;; Move an untagged SAP to a tagged representation. +;;; +(define-vop (move-from-sap) + (:args (x :scs (sap-reg) :to (:eval 1))) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:results (y :scs (descriptor-reg) :from (:eval 0))) + (:note "system area pointer allocation") + (:generator 20 + (with-fixed-allocation (y ndescr sap-widetag sap-size) + (storew x y sap-pointer-slot other-pointer-lowtag)))) +;;; +(define-move-vop move-from-sap :move + (sap-reg) (descriptor-reg)) + + +;;; Move untagged sap values. +;;; +(define-vop (sap-move) + (:args (x :target y + :scs (sap-reg) + :load-if (not (location= x y)))) + (:results (y :scs (sap-reg) + :load-if (not (location= x y)))) + (:effects) + (:affected) + (:generator 0 + (move x y))) +;;; +(define-move-vop sap-move :move + (sap-reg) (sap-reg)) + + +;;; Move untagged sap arguments/return-values. +;;; +(define-vop (move-sap-argument) + (:args (x :target y + :scs (sap-reg)) + (fp :scs (any-reg) + :load-if (not (sc-is y sap-reg)))) + (:results (y)) + (:generator 0 + (sc-case y + (sap-reg + (move x y)) + (sap-stack + (storew x fp (tn-offset y)))))) +;;; +(define-move-vop move-sap-argument :move-arg + (descriptor-reg sap-reg) (sap-reg)) + + +;;; Use standard MOVE-ARGUMENT + coercion to move an untagged sap to a +;;; descriptor passing location. +;;; +(define-move-vop move-argument :move-arg + (sap-reg) (descriptor-reg)) + + + +;;;; SAP-INT and INT-SAP + +(define-vop (sap-int) + (:args (sap :scs (sap-reg) :target int)) + (:arg-types system-area-pointer) + (:results (int :scs (unsigned-reg))) + (:result-types unsigned-num) + (:translate sap-int) + (:policy :fast-safe) + (:generator 1 + (move sap int))) + +(define-vop (int-sap) + (:args (int :scs (unsigned-reg) :target sap)) + (:arg-types unsigned-num) + (:results (sap :scs (sap-reg))) + (:result-types system-area-pointer) + (:translate int-sap) + (:policy :fast-safe) + (:generator 1 + (move int sap))) + + + +;;;; POINTER+ and POINTER- + +(define-vop (pointer+) + (:translate sap+) + (:args (ptr :scs (sap-reg) :target res) + (offset :scs (signed-reg))) + (:arg-types system-area-pointer signed-num) + (:results (res :scs (sap-reg))) + (:result-types system-area-pointer) + (:policy :fast-safe) + (:generator 1 + (inst add ptr offset res))) + +(define-vop (pointer+-c) + (:translate sap+) + (:args (ptr :scs (sap-reg))) + (:info offset) + (:arg-types system-area-pointer (:constant (signed-byte 11))) + (:results (res :scs (sap-reg))) + (:result-types system-area-pointer) + (:policy :fast-safe) + (:generator 1 + (inst addi offset ptr res))) + +(define-vop (pointer-) + (:translate sap-) + (:args (ptr1 :scs (sap-reg)) + (ptr2 :scs (sap-reg))) + (:arg-types system-area-pointer system-area-pointer) + (:policy :fast-safe) + (:results (res :scs (signed-reg))) + (:result-types signed-num) + (:generator 1 + (inst sub ptr1 ptr2 res))) + + + +;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET + +(macrolet ((def-system-ref-and-set + (ref-name set-name sc type size &optional signed) + (let ((ref-name-c (symbolicate ref-name "-C")) + (set-name-c (symbolicate set-name "-C"))) + `(progn + (define-vop (,ref-name) + (:translate ,ref-name) + (:policy :fast-safe) + (:args (object :scs (sap-reg)) + (offset :scs (signed-reg))) + (:arg-types system-area-pointer signed-num) + (:results (result :scs (,sc))) + (:result-types ,type) + (:generator 5 + (inst ,(ecase size + (:byte 'ldbx) + (:short 'ldhx) + (:long 'ldwx) + (:float 'fldx)) + offset object result) + ,@(when (and signed (not (eq size :long))) + `((inst extrs result 31 ,(ecase size + (:byte 8) + (:short 16)) + result))))) + (define-vop (,ref-name-c) + (:translate ,ref-name) + (:policy :fast-safe) + (:args (object :scs (sap-reg))) + (:arg-types system-area-pointer + (:constant ,(if (eq size :float) + '(signed-byte 5) + '(signed-byte 14)))) + (:info offset) + (:results (result :scs (,sc))) + (:result-types ,type) + (:generator 4 + (inst ,(ecase size + (:byte 'ldb) + (:short 'ldh) + (:long 'ldw) + (:float 'flds)) + offset object result) + ,@(when (and signed (not (eq size :long))) + `((inst extrs result 31 ,(ecase size + (:byte 8) + (:short 16)) + result))))) + (define-vop (,set-name) + (:translate ,set-name) + (:policy :fast-safe) + (:args (object :scs (sap-reg) + ,@(unless (eq size :float) '(:target sap))) + (offset :scs (signed-reg)) + (value :scs (,sc) :target result)) + (:arg-types system-area-pointer signed-num ,type) + (:results (result :scs (,sc))) + (:result-types ,type) + ,@(unless (eq size :float) + '((:temporary (:scs (sap-reg) :from (:argument 0)) sap))) + (:generator 5 + ,@(if (eq size :float) + `((inst fstx value offset object) + (unless (location= value result) + (inst funop :copy value result))) + `((inst add object offset sap) + (inst ,(ecase size (:byte 'stb) (:short 'sth) (:long 'stw)) + value 0 sap) + (move value result))))) + (define-vop (,set-name-c) + (:translate ,set-name) + (:policy :fast-safe) + (:args (object :scs (sap-reg)) + (value :scs (,sc) :target result)) + (:arg-types system-area-pointer + (:constant ,(if (eq size :float) + '(signed-byte 5) + '(signed-byte 14))) + ,type) + (:info offset) + (:results (result :scs (,sc))) + (:result-types ,type) + (:generator 5 + ,@(if (eq size :float) + `((inst fsts value offset object) + (unless (location= value result) + (inst funop :copy value result))) + `((inst ,(ecase size (:byte 'stb) (:short 'sth) (:long 'stw)) + value offset object) + (move value result))))))))) + (def-system-ref-and-set sap-ref-8 %set-sap-ref-8 + unsigned-reg positive-fixnum :byte nil) + (def-system-ref-and-set signed-sap-ref-8 %set-signed-sap-ref-8 + signed-reg tagged-num :byte t) + (def-system-ref-and-set sap-ref-16 %set-sap-ref-16 + unsigned-reg positive-fixnum :short nil) + (def-system-ref-and-set signed-sap-ref-16 %set-signed-sap-ref-16 + signed-reg tagged-num :short t) + (def-system-ref-and-set sap-ref-32 %set-sap-ref-32 + unsigned-reg unsigned-num :long nil) + (def-system-ref-and-set signed-sap-ref-32 %set-signed-sap-ref-32 + signed-reg signed-num :long t) + (def-system-ref-and-set sap-ref-sap %set-sap-ref-sap + sap-reg system-area-pointer :long) + (def-system-ref-and-set sap-ref-single %set-sap-ref-single + single-reg single-float :float) + (def-system-ref-and-set sap-ref-double %set-sap-ref-double + double-reg double-float :float)) + + +;;; Noise to convert normal lisp data objects into SAPs. + +(define-vop (vector-sap) + (:translate vector-sap) + (:policy :fast-safe) + (:args (vector :scs (descriptor-reg))) + (:results (sap :scs (sap-reg))) + (:result-types system-area-pointer) + (:generator 2 + (inst addi + (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) + vector + sap))) + + +;;; Transforms for 64-bit SAP accessors. + +;;; FIXME: So these are now commented out on the SPARC, PPC and HPPA +;;; backends. Did they ever serve a purpose? Could they in future? -- +;;; CSR, 2002-08-10 +#| +(deftransform sap-ref-64 ((sap offset) (* *)) + '(logior (ash (sap-ref-32 sap offset) 32) + (sap-ref-32 sap (+ offset 4)))) + +(deftransform signed-sap-ref-64 ((sap offset) (* *)) + '(logior (ash (signed-sap-ref-32 sap offset) 32) + (sap-ref-32 sap (+ 4 offset)))) + +(deftransform %set-sap-ref-64 ((sap offset value) (* * *)) + '(progn + (%set-sap-ref-32 sap offset (ash value -32)) + (%set-sap-ref-32 sap (+ offset 4) (logand value #xffffffff)))) + +(deftransform %set-signed-sap-ref-64 ((sap offset value) (* * *)) + '(progn + (%set-signed-sap-ref-32 sap offset (ash value -32)) + (%set-sap-ref-32 sap (+ 4 offset) (logand value #xffffffff)))) +|# diff --git a/src/compiler/hppa/show.lisp b/src/compiler/hppa/show.lisp new file mode 100644 index 0000000..20b36f8 --- /dev/null +++ b/src/compiler/hppa/show.lisp @@ -0,0 +1,31 @@ +(in-package "SB!VM") + + +(define-vop (print) + (:args (object :scs (descriptor-reg) :target arg)) + (:results (result :scs (descriptor-reg))) + (:save-p t) + (:temporary (:sc non-descriptor-reg :offset cfunc-offset) cfunc) + (:temporary (:sc non-descriptor-reg :offset nl0-offset :from (:argument 0)) + arg) + (:temporary (:sc non-descriptor-reg :offset nl4-offset :to (:result 0)) + res) + (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) + (:temporary (:scs (non-descriptor-reg)) temp) + (:vop-var vop) + (:generator 0 + (let ((cur-nfp (current-nfp-tn vop))) + (move object arg) + (when cur-nfp + (store-stack-tn nfp-save cur-nfp)) + ;; Allocate 64 bytes, the minimum stack size. + (inst addi 64 nsp-tn nsp-tn) + (inst li (make-fixup "debug_print" :foreign) cfunc) + (let ((fixup (make-fixup "call_into_c" :foreign))) + (inst ldil fixup temp) + (inst ble fixup c-text-space temp :nullify t) + (inst nop)) + (inst addi -64 nsp-tn nsp-tn) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save)) + (move res result)))) diff --git a/src/compiler/hppa/static-fn.lisp b/src/compiler/hppa/static-fn.lisp new file mode 100644 index 0000000..8527975 --- /dev/null +++ b/src/compiler/hppa/static-fn.lisp @@ -0,0 +1,126 @@ +(in-package "SB!VM") + + +(define-vop (static-fun-template) + (:save-p t) + (:policy :safe) + (:variant-vars symbol) + (:vop-var vop) + (:temporary (:scs (non-descriptor-reg)) temp) + (:temporary (:scs (descriptor-reg)) move-temp) + (:temporary (:sc descriptor-reg :offset lra-offset) lra) + (:temporary (:scs (interior-reg)) lip) + (:temporary (:sc any-reg :offset nargs-offset) nargs) + (:temporary (:sc any-reg :offset ocfp-offset) old-fp) + (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)) + + +(eval-when (:compile-toplevel :load-toplevel :execute) + +(defun static-fun-template-name (num-args num-results) + (intern (format nil "~:@(~R-arg-~R-result-static-fun~)" + num-args num-results))) + + +(defun moves (src dst) + (collect ((moves)) + (do ((src src (cdr src)) + (dst dst (cdr dst))) + ((or (null src) (null dst))) + (moves `(move ,(car src) ,(car dst)))) + (moves))) + +(defun static-fun-template-vop (num-args num-results) + (assert (and (<= num-args register-arg-count) + (<= num-results register-arg-count)) + (num-args num-results) + "Either too many args (~D) or too many results (~D). Max = ~D" + num-args num-results register-arg-count) + (let ((num-temps (max num-args num-results))) + (collect ((temp-names) (temps) (arg-names) (args) (result-names) (results)) + (dotimes (i num-results) + (let ((result-name (intern (format nil "RESULT-~D" i)))) + (result-names result-name) + (results `(,result-name :scs (any-reg descriptor-reg))))) + (dotimes (i num-temps) + (let ((temp-name (intern (format nil "TEMP-~D" i)))) + (temp-names temp-name) + (temps `(:temporary (:sc descriptor-reg + :offset ,(nth i *register-arg-offsets*) + ,@(when (< i num-args) + `(:from (:argument ,i))) + ,@(when (< i num-results) + `(:to (:result ,i) + :target ,(nth i (result-names))))) + ,temp-name)))) + (dotimes (i num-args) + (let ((arg-name (intern (format nil "ARG-~D" i)))) + (arg-names arg-name) + (args `(,arg-name + :scs (any-reg descriptor-reg) + :target ,(nth i (temp-names)))))) + `(define-vop (,(static-fun-template-name num-args num-results) + static-fun-template) + (:args ,@(args)) + ,@(temps) + (:results ,@(results)) + (:generator ,(+ 50 num-args num-results) + (let ((lra-label (gen-label)) + (cur-nfp (current-nfp-tn vop))) + ,@(moves (arg-names) (temp-names)) + (inst li (fixnumize ,num-args) nargs) + (inst ldw (static-fun-offset symbol) null-tn lip) + (when cur-nfp + (store-stack-tn nfp-save cur-nfp)) + (inst move cfp-tn old-fp) + (inst compute-lra-from-code code-tn lra-label temp lra) + (note-this-location vop :call-site) + (inst bv lip) + (inst move csp-tn cfp-tn) + (emit-return-pc lra-label) + ,(collect ((bindings) (links)) + (do ((temp (temp-names) (cdr temp)) + (name 'values (gensym)) + (prev nil name) + (i 0 (1+ i))) + ((= i num-results)) + (bindings `(,name + (make-tn-ref ,(car temp) nil))) + (when prev + (links `(setf (tn-ref-across ,prev) ,name)))) + `(let ,(bindings) + ,@(links) + (default-unknown-values vop + ,(if (zerop num-results) nil 'values) + ,num-results move-temp temp lra-label))) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save)) + ,@(moves (temp-names) (result-names)))))))) + +) ; eval-when (compile load eval) + +(macrolet + ((foo () + (collect ((templates (list 'progn))) + (dotimes (i register-arg-count) + (templates (static-fun-template-vop i 1))) + (templates)))) + (foo)) + +(defmacro define-static-fun (name args &key (results '(x)) translate + policy cost arg-types result-types) + `(define-vop (,name + ,(static-fun-template-name (length args) + (length results))) + (:variant ',name) + (:note ,(format nil "static-fun ~@(~S~)" name)) + ,@(when translate + `((:translate ,translate))) + ,@(when policy + `((:policy ,policy))) + ,@(when cost + `((:generator-cost ,cost))) + ,@(when arg-types + `((:arg-types ,@arg-types))) + ,@(when result-types + `((:result-types ,@result-types))))) diff --git a/src/compiler/hppa/subprim.lisp b/src/compiler/hppa/subprim.lisp new file mode 100644 index 0000000..a2097b7 --- /dev/null +++ b/src/compiler/hppa/subprim.lisp @@ -0,0 +1,41 @@ +(in-package "SB!VM") + + + +;;;; Length + +(define-vop (length/list) + (:translate length) + (:args (object :scs (descriptor-reg) :target ptr)) + (:arg-types list) + (:temporary (:scs (descriptor-reg) :from (:argument 0)) ptr) + (:temporary (:scs (non-descriptor-reg) :type random) temp) + (:temporary (:scs (any-reg) :type fixnum :to (:result 0) :target result) + count) + (:results (result :scs (any-reg descriptor-reg))) + (:policy :fast-safe) + (:vop-var vop) + (:save-p :compute-only) + (:generator 50 + (move object ptr) + (inst comb := ptr null-tn done) + (inst li 0 count) + + (inst extru ptr 31 3 temp) + (inst comib :<> list-pointer-lowtag temp loose :nullify t) + (loadw ptr ptr cons-cdr-slot list-pointer-lowtag) + + LOOP + (inst addi (fixnumize 1) count count) + (inst comb := ptr null-tn done :nullify t) + (inst extru ptr 31 3 temp) + (inst comib := list-pointer-lowtag temp loop :nullify t) + (loadw ptr ptr cons-cdr-slot list-pointer-lowtag) + + LOOSE + (cerror-call vop done object-not-list-error ptr) + + DONE + (move count result))) + +(define-static-fun length (object) :translate length) diff --git a/src/compiler/hppa/system.lisp b/src/compiler/hppa/system.lisp new file mode 100644 index 0000000..d231f11 --- /dev/null +++ b/src/compiler/hppa/system.lisp @@ -0,0 +1,213 @@ +(in-package "SB!VM") + + +;;;; Type frobbing VOPs + +(define-vop (lowtag-of) + (:translate lowtag-of) + (:policy :fast-safe) + (:args (object :scs (any-reg descriptor-reg) :target result)) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 1 + (inst extru object 31 3 result))) + +(define-vop (widetag-of) + (:translate widetag-of) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to (:eval 1))) + (:results (result :scs (unsigned-reg) :from (:eval 0))) + (:result-types positive-fixnum) + (:generator 6 + (inst extru object 31 3 result) + (inst comib := other-pointer-lowtag result other-ptr :nullify t) + (inst comib := fun-pointer-lowtag result function-ptr :nullify t) + (inst bb t object 31 done :nullify t) + (inst extru object 31 2 result :=) + (inst extru object 31 8 result) + (inst nop :tr) + + FUNCTION-PTR + (load-type result object (- fun-pointer-lowtag)) + (inst nop :tr) + + OTHER-PTR + (load-type result object (- other-pointer-lowtag)) + + DONE)) + +(define-vop (fun-subtype) + (:translate fun-subtype) + (:policy :fast-safe) + (:args (function :scs (descriptor-reg))) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 6 + (load-type result function (- fun-pointer-lowtag)))) + +(define-vop (set-fun-subtype) + (:translate (setf fun-subtype)) + (:policy :fast-safe) + (:args (type :scs (unsigned-reg) :target result) + (function :scs (descriptor-reg))) + (:arg-types positive-fixnum *) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 6 + (inst stb type (- 3 fun-pointer-lowtag) function) + (move type result))) + +(define-vop (get-header-data) + (:translate get-header-data) + (:policy :fast-safe) + (:args (x :scs (descriptor-reg))) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 6 + (loadw res x 0 other-pointer-lowtag) + (inst srl res 8 res))) + +(define-vop (get-closure-length) + (:translate get-closure-length) + (:policy :fast-safe) + (:args (x :scs (descriptor-reg))) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 6 + (loadw res x 0 fun-pointer-lowtag) + (inst srl res 8 res))) + +(define-vop (set-header-data) + (:translate set-header-data) + (:policy :fast-safe) + (:args (x :scs (descriptor-reg) :target res) + (data :scs (unsigned-reg))) + (:arg-types * positive-fixnum) + (:results (res :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 6 + (loadw temp x 0 other-pointer-lowtag) + (inst dep data 23 24 temp) + (storew temp x 0 other-pointer-lowtag) + (move x res))) + +(define-vop (set-header-data-c) + (:translate set-header-data) + (:policy :fast-safe) + (:args (x :scs (descriptor-reg) :target res)) + (:arg-types * (:constant (signed-byte 5))) + (:info data) + (:results (res :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 5 + (loadw temp x 0 other-pointer-lowtag) + (inst dep data 23 24 temp) + (storew temp x 0 other-pointer-lowtag) + (move x res))) + +(define-vop (make-fixnum) + (:args (ptr :scs (any-reg descriptor-reg))) + (:results (res :scs (any-reg descriptor-reg))) + (:generator 1 + ;; + ;; Some code (the hash table code) depends on this returning a + ;; positive number so make sure it does. + (inst zdep ptr 29 29 res))) + +(define-vop (make-other-immediate-type) + (:args (val :scs (any-reg descriptor-reg)) + (type :scs (any-reg descriptor-reg) :target temp)) + (:results (res :scs (any-reg descriptor-reg) :from (:argument 0))) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 2 + (inst sll val (- n-widetag-bits 2) res) + (inst sra type 2 temp) + (inst or res temp res))) + + +;;;; Allocation + +(define-vop (dynamic-space-free-pointer) + (:results (int :scs (sap-reg))) + (:result-types system-area-pointer) + (:translate dynamic-space-free-pointer) + (:policy :fast-safe) + (:generator 1 + (move alloc-tn int))) + +(define-vop (binding-stack-pointer-sap) + (:results (int :scs (sap-reg))) + (:result-types system-area-pointer) + (:translate binding-stack-pointer-sap) + (:policy :fast-safe) + (:generator 1 + (move bsp-tn int))) + +(define-vop (control-stack-pointer-sap) + (:results (int :scs (sap-reg))) + (:result-types system-area-pointer) + (:translate control-stack-pointer-sap) + (:policy :fast-safe) + (:generator 1 + (move csp-tn int))) + + +;;;; Code object frobbing. + +(define-vop (code-instructions) + (:translate code-instructions) + (:policy :fast-safe) + (:args (code :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:results (sap :scs (sap-reg))) + (:result-types system-area-pointer) + (:generator 10 + (loadw ndescr code 0 other-pointer-lowtag) + (inst srl ndescr 8 ndescr) + (inst sll ndescr 2 ndescr) + (inst addi (- other-pointer-lowtag) ndescr ndescr) + (inst add code ndescr sap))) + +(define-vop (compute-fun) + (:args (code :scs (descriptor-reg)) + (offset :scs (signed-reg unsigned-reg))) + (:arg-types * positive-fixnum) + (:results (func :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:generator 10 + (loadw ndescr code 0 other-pointer-lowtag) + (inst srl ndescr 8 ndescr) + (inst sll ndescr 2 ndescr) + (inst add ndescr offset ndescr) + (inst addi (- fun-pointer-lowtag other-pointer-lowtag) ndescr ndescr) + (inst add ndescr code func))) + + +;;;; Other random VOPs. + + +(defknown sb!unix::do-pending-interrupt () (values)) +(define-vop (sb!unix::do-pending-interrupt) + (:policy :fast-safe) + (:translate sb!unix::do-pending-interrupt) + (:generator 1 + (inst break pending-interrupt-trap))) + + +(define-vop (halt) + (:generator 1 + (inst break halt-trap))) + + +;;;; Dynamic vop count collection support + +(define-vop (count-me) + (:args (count-vector :scs (descriptor-reg))) + (:info index) + (:temporary (:scs (non-descriptor-reg)) count) + (:generator 1 + (let ((offset + (- (* (+ index vector-data-offset) n-word-bytes) other-pointer-lowtag))) + (inst ldw offset count-vector count) + (inst addi 1 count count) + (inst stw count offset count-vector)))) diff --git a/src/compiler/hppa/target-insts.lisp b/src/compiler/hppa/target-insts.lisp new file mode 100644 index 0000000..422aa7e --- /dev/null +++ b/src/compiler/hppa/target-insts.lisp @@ -0,0 +1,15 @@ +;;;; This file is for stuff which was in CMU CL's insts.lisp +;;;; file, but which in the SBCL build process can't be compiled +;;;; into code for the cross-compilation host. + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + diff --git a/src/compiler/hppa/type-vops.lisp b/src/compiler/hppa/type-vops.lisp new file mode 100644 index 0000000..7b72169 --- /dev/null +++ b/src/compiler/hppa/type-vops.lisp @@ -0,0 +1,548 @@ +(in-package "SB!VM") + + + +;;;; Test generation utilities. + +(eval-when (:compile-toplevel :execute) + +(defparameter *immediate-types* + (list unbound-marker-widetag base-char-widetag)) + +(defparameter *fun-header-widetags* + (list funcallable-instance-header-widetag + simple-fun-header-widetag + closure-fun-header-widetag + closure-header-widetag)) + +(defun canonicalize-headers (headers) + (collect ((results)) + (let ((start nil) + (prev nil) + (delta (- other-immediate-1-lowtag other-immediate-0-lowtag))) + (flet ((emit-test () + (results (if (= start prev) + start + (cons start prev))))) + (dolist (header (sort headers #'<)) + (cond ((null start) + (setf start header) + (setf prev header)) + ((= header (+ prev delta)) + (setf prev header)) + (t + (emit-test) + (setf start header) + (setf prev header)))) + (emit-test))) + (results))) + +); eval-when (compile eval) + +(macrolet ((test-type (value temp target not-p &rest type-codes) + ;; Determine what interesting combinations we need to test for. + (let* ((type-codes (mapcar #'eval type-codes)) + (fixnump (and (member even-fixnum-lowtag type-codes) + (member odd-fixnum-lowtag type-codes) + t)) + (lowtags (remove lowtag-limit type-codes :test #'<)) + (extended (remove lowtag-limit type-codes :test #'>)) + (immediates (intersection extended *immediate-types* :test #'eql)) + (headers (set-difference extended *immediate-types* :test #'eql)) + (function-p (if (intersection headers *fun-header-widetags*) + (if (subsetp headers *fun-header-widetags*) + t + (error "Can't test for mix of function subtypes ~ + and normal header types.")) + nil))) + (unless type-codes + (error "Must supply at least on type for test-type.")) + (cond + (fixnump + (when (remove-if #'(lambda (x) + (or (= x even-fixnum-lowtag) + (= x odd-fixnum-lowtag))) + lowtags) + (error "Can't mix fixnum testing with other lowtags.")) + (when function-p + (error "Can't mix fixnum testing with function subtype testing.")) + (when immediates + (error "Can't mix fixnum testing with other immediates.")) + (if headers + `(%test-fixnum-and-headers ,value ,temp ,target ,not-p + ',(canonicalize-headers headers)) + `(%test-fixnum ,value ,temp ,target ,not-p))) + (immediates + (when headers + (error "Can't mix testing of immediates with testing of headers.")) + (when lowtags + (error "Can't mix testing of immediates with testing of lowtags.")) + (when (cdr immediates) + (error "Can't test multiple immediates at the same time.")) + `(%test-immediate ,value ,temp ,target ,not-p ,(car immediates))) + (lowtags + (when (cdr lowtags) + (error "Can't test multiple lowtags at the same time.")) + (if headers + `(%test-lowtag-and-headers + ,value ,temp ,target ,not-p ,(car lowtags) + ,function-p ',(canonicalize-headers headers)) + `(%test-lowtag ,value ,temp ,target ,not-p ,(car lowtags)))) + (headers + `(%test-headers ,value ,temp ,target ,not-p ,function-p + ',(canonicalize-headers headers))) + (t + (error "Nothing to test?")))))) + + +(defun %test-fixnum (value temp target not-p) + (declare (ignore temp)) + (assemble () + (inst extru value 31 2 zero-tn (if not-p := :<>)) + (inst b target :nullify t))) + +(defun %test-fixnum-and-headers (value temp target not-p headers) + (let ((drop-through (gen-label))) + (assemble () + (inst extru value 31 2 zero-tn :<>) + (inst b (if not-p drop-through target) :nullify t)) + (%test-headers value temp target not-p nil headers drop-through))) + +(defun %test-immediate (value temp target not-p immediate) + (assemble () + (inst extru value 31 8 temp) + (inst bci := not-p immediate temp target))) + +(defun %test-lowtag (value temp target not-p lowtag &optional temp-loaded) + (assemble () + (unless temp-loaded + (inst extru value 31 3 temp)) + (inst bci := not-p lowtag temp target))) + +(defun %test-lowtag-and-headers (value temp target not-p lowtag + function-p headers) + (let ((drop-through (gen-label))) + (%test-lowtag value temp (if not-p drop-through target) nil lowtag) + (%test-headers value temp target not-p function-p headers drop-through t))) + +(defun %test-headers (value temp target not-p function-p headers + &optional (drop-through (gen-label)) temp-loaded) + (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag))) + (multiple-value-bind + (equal greater-or-equal when-true when-false) + ;; EQUAL and GREATER-OR-EQUAL are the conditions for branching to + ;; TARGET. WHEN-TRUE and WHEN-FALSE are the labels to branch to when + ;; we know it's true and when we know it's false respectively. + (if not-p + (values :<> :< drop-through target) + (values := :>= target drop-through)) + (assemble () + (%test-lowtag value temp when-false t lowtag temp-loaded) + (inst ldb (- 3 lowtag) value temp) + (do ((remaining headers (cdr remaining))) + ((null remaining)) + (let ((header (car remaining)) + (last (null (cdr remaining)))) + (cond + ((atom header) + (if last + (inst bci equal nil header temp target) + (inst bci := nil header temp when-true))) + (t + (let ((start (car header)) + (end (cdr header))) + (unless (= start bignum-widetag) + (inst bci :> nil start temp when-false)) + (if last + (inst bci greater-or-equal nil end temp target) + (inst bci :>= nil end temp when-true))))))) + (emit-label drop-through))))) + + +;;;; Type checking and testing: + +(define-vop (check-type) + (:args (value :target result :scs (any-reg descriptor-reg))) + (:results (result :scs (any-reg descriptor-reg))) + (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp) + (:vop-var vop) + (:save-p :compute-only)) + +(define-vop (type-predicate) + (:args (value :scs (any-reg descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) temp) + (:conditional) + (:info target not-p) + (:policy :fast-safe)) + +(eval-when (:compile-toplevel :execute) + +(defun cost-to-test-types (type-codes) + (+ (* 2 (length type-codes)) + (if (> (apply #'max type-codes) lowtag-limit) 7 2))) + +) ; EVAL-WHEN + +(defmacro def-type-vops (pred-name check-name ptype error-code + &rest type-codes) + (let ((cost (cost-to-test-types (mapcar #'eval type-codes)))) + `(progn + ,@(when pred-name + `((define-vop (,pred-name type-predicate) + (:translate ,pred-name) + (:generator ,cost + (test-type value temp target not-p ,@type-codes))))) + ,@(when check-name + `((define-vop (,check-name check-type) + (:generator ,cost + (let ((err-lab + (generate-error-code vop ,error-code value))) + (test-type value temp err-lab t ,@type-codes) + (move value result)))))) + ,@(when ptype + `((primitive-type-vop ,check-name (:check) ,ptype)))))) + +(def-type-vops fixnump check-fixnum fixnum object-not-fixnum-error + even-fixnum-lowtag odd-fixnum-lowtag) + +(def-type-vops functionp check-function function + object-not-fun-error fun-pointer-lowtag) + +(def-type-vops listp check-list list object-not-list-error + list-pointer-lowtag) + +(def-type-vops %instancep check-instance instance object-not-instance-error + instance-pointer-lowtag) + +(def-type-vops bignump check-bignum bignum + object-not-bignum-error bignum-widetag) + +(def-type-vops ratiop check-ratio ratio + object-not-ratio-error ratio-widetag) + +(def-type-vops complexp check-complex complex object-not-complex-error + complex-widetag complex-single-float-widetag complex-double-float-widetag) + +(def-type-vops complex-rational-p check-complex-rational nil + object-not-complex-rational-error complex-widetag) + +(def-type-vops complex-float-p check-complex-float nil + object-not-complex-float-error + complex-single-float-widetag complex-double-float-widetag) + +(def-type-vops complex-single-float-p check-complex-single-float + complex-single-float object-not-complex-single-float-error + complex-single-float-widetag) + +(def-type-vops complex-double-float-p check-complex-double-float + complex-double-float object-not-complex-double-float-error + complex-double-float-widetag) + +(def-type-vops single-float-p check-single-float single-float + object-not-single-float-error single-float-widetag) + +(def-type-vops double-float-p check-double-float double-float + object-not-double-float-error double-float-widetag) + +(def-type-vops simple-string-p check-simple-string simple-string + object-not-simple-string-error simple-string-widetag) + +(def-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector + object-not-simple-bit-vector-error simple-bit-vector-widetag) + +(def-type-vops simple-vector-p check-simple-vector simple-vector + object-not-simple-vector-error simple-vector-widetag) + +(def-type-vops simple-array-unsigned-byte-2-p + check-simple-array-unsigned-byte-2 + simple-array-unsigned-byte-2 + object-not-simple-array-unsigned-byte-2-error + simple-array-unsigned-byte-2-widetag) + +(def-type-vops simple-array-unsigned-byte-4-p + check-simple-array-unsigned-byte-4 + simple-array-unsigned-byte-4 + object-not-simple-array-unsigned-byte-4-error + simple-array-unsigned-byte-4-widetag) + +(def-type-vops simple-array-unsigned-byte-8-p + check-simple-array-unsigned-byte-8 + simple-array-unsigned-byte-8 + object-not-simple-array-unsigned-byte-8-error + simple-array-unsigned-byte-8-widetag) + +(def-type-vops simple-array-unsigned-byte-16-p + check-simple-array-unsigned-byte-16 + simple-array-unsigned-byte-16 + object-not-simple-array-unsigned-byte-16-error + simple-array-unsigned-byte-16-widetag) + +(def-type-vops simple-array-unsigned-byte-32-p + check-simple-array-unsigned-byte-32 + simple-array-unsigned-byte-32 + object-not-simple-array-unsigned-byte-32-error + simple-array-unsigned-byte-32-widetag) + +(def-type-vops simple-array-signed-byte-8-p + check-simple-array-signed-byte-8 + simple-array-signed-byte-8 + object-not-simple-array-signed-byte-8-error + simple-array-signed-byte-8-widetag) + +(def-type-vops simple-array-signed-byte-16-p + check-simple-array-signed-byte-16 + simple-array-signed-byte-16 + object-not-simple-array-signed-byte-16-error + simple-array-signed-byte-16-widetag) + +(def-type-vops simple-array-signed-byte-30-p + check-simple-array-signed-byte-30 + simple-array-signed-byte-30 + object-not-simple-array-signed-byte-30-error + simple-array-signed-byte-30-widetag) + +(def-type-vops simple-array-signed-byte-32-p + check-simple-array-signed-byte-32 + simple-array-signed-byte-32 + object-not-simple-array-signed-byte-32-error + simple-array-signed-byte-32-widetag) + +(def-type-vops simple-array-single-float-p check-simple-array-single-float + simple-array-single-float object-not-simple-array-single-float-error + simple-array-single-float-widetag) + +(def-type-vops simple-array-double-float-p check-simple-array-double-float + simple-array-double-float object-not-simple-array-double-float-error + simple-array-double-float-widetag) + +(def-type-vops simple-array-complex-single-float-p + check-simple-array-complex-single-float + simple-array-complex-single-float + object-not-simple-array-complex-single-float-error + simple-array-complex-single-float-widetag) + +(def-type-vops simple-array-complex-double-float-p + check-simple-array-complex-double-float + simple-array-complex-double-float + object-not-simple-array-complex-double-float-error + simple-array-complex-double-float-widetag) + +(def-type-vops base-char-p check-base-char base-char + object-not-base-char-error base-char-widetag) + +(def-type-vops system-area-pointer-p check-system-area-pointer + system-area-pointer object-not-sap-error sap-widetag) + +(def-type-vops weak-pointer-p check-weak-pointer weak-pointer + object-not-weak-pointer-error weak-pointer-widetag) + +#| +(def-type-vops scavenger-hook-p nil nil nil + 0) +|# + +(def-type-vops code-component-p nil nil nil + code-header-widetag) + +(def-type-vops lra-p nil nil nil + return-pc-header-widetag) + +(def-type-vops fdefn-p nil nil nil + fdefn-widetag) + +(def-type-vops funcallable-instance-p nil nil nil + funcallable-instance-header-widetag) + +(def-type-vops array-header-p nil nil nil + simple-array-widetag complex-string-widetag complex-bit-vector-widetag + complex-vector-widetag complex-array-widetag) + +#+nil +(def-type-vops nil check-function-or-symbol nil + object-not-function-or-symbol-error + fun-pointer-lowtag symbol-header-widetag) + +(def-type-vops stringp check-string nil object-not-string-error + simple-string-widetag complex-string-widetag) + +(def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error + simple-bit-vector-widetag complex-bit-vector-widetag) + +(def-type-vops vectorp check-vector nil object-not-vector-error + simple-string-widetag simple-bit-vector-widetag simple-vector-widetag + simple-array-unsigned-byte-2-widetag simple-array-unsigned-byte-4-widetag + simple-array-unsigned-byte-8-widetag simple-array-unsigned-byte-16-widetag + simple-array-unsigned-byte-32-widetag + simple-array-signed-byte-8-widetag simple-array-signed-byte-16-widetag + simple-array-signed-byte-30-widetag simple-array-signed-byte-32-widetag + simple-array-single-float-widetag simple-array-double-float-widetag + simple-array-complex-single-float-widetag + simple-array-complex-double-float-widetag + complex-string-widetag complex-bit-vector-widetag complex-vector-widetag) + +(def-type-vops complex-vector-p check-complex-vector nil object-not-complex-vector-error + complex-vector-widetag) + +(def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error + simple-array-widetag simple-string-widetag simple-bit-vector-widetag + simple-vector-widetag simple-array-unsigned-byte-2-widetag + simple-array-unsigned-byte-4-widetag simple-array-unsigned-byte-8-widetag + simple-array-unsigned-byte-16-widetag simple-array-unsigned-byte-32-widetag + simple-array-signed-byte-8-widetag simple-array-signed-byte-16-widetag + simple-array-signed-byte-30-widetag simple-array-signed-byte-32-widetag + simple-array-single-float-widetag simple-array-double-float-widetag + simple-array-complex-single-float-widetag + simple-array-complex-double-float-widetag) + +(def-type-vops arrayp check-array nil object-not-array-error + simple-array-widetag simple-string-widetag simple-bit-vector-widetag + simple-vector-widetag simple-array-unsigned-byte-2-widetag + simple-array-unsigned-byte-4-widetag simple-array-unsigned-byte-8-widetag + simple-array-unsigned-byte-16-widetag simple-array-unsigned-byte-32-widetag + simple-array-signed-byte-8-widetag simple-array-signed-byte-16-widetag + simple-array-signed-byte-30-widetag simple-array-signed-byte-32-widetag + simple-array-single-float-widetag simple-array-double-float-widetag + simple-array-complex-single-float-widetag + simple-array-complex-double-float-widetag + complex-string-widetag complex-bit-vector-widetag complex-vector-widetag + complex-array-widetag) + +(def-type-vops numberp check-number nil object-not-number-error + even-fixnum-lowtag odd-fixnum-lowtag bignum-widetag ratio-widetag + single-float-widetag double-float-widetag complex-widetag + complex-single-float-widetag complex-double-float-widetag) + +(def-type-vops rationalp check-rational nil object-not-rational-error + even-fixnum-lowtag odd-fixnum-lowtag ratio-widetag bignum-widetag) + +(def-type-vops integerp check-integer nil object-not-integer-error + even-fixnum-lowtag odd-fixnum-lowtag bignum-widetag) + +(def-type-vops floatp check-float nil object-not-float-error + single-float-widetag double-float-widetag) + +(def-type-vops realp check-real nil object-not-real-error + even-fixnum-lowtag odd-fixnum-lowtag ratio-widetag bignum-widetag + single-float-widetag double-float-widetag) + + +;;;; Other integer ranges. + +;;; A (signed-byte 32) can be represented with either fixnum or a bignum with +;;; exactly one digit. + +(defun signed-byte-32-test (value temp not-p target not-target) + (multiple-value-bind + (yep nope) + (if not-p + (values not-target target) + (values target not-target)) + (assemble () + (inst extru value 31 2 zero-tn :<>) + (inst b yep :nullify t) + (inst extru value 31 3 temp) + (inst bci :<> nil other-pointer-lowtag temp nope) + (loadw temp value 0 other-pointer-lowtag) + (inst bci := not-p (+ (ash 1 n-widetag-bits) bignum-widetag) temp target))) + (values)) + +(define-vop (signed-byte-32-p type-predicate) + (:translate signed-byte-32-p) + (:generator 45 + (signed-byte-32-test value temp not-p target not-target) + NOT-TARGET)) + +(define-vop (check-signed-byte-32 check-type) + (:generator 45 + (let ((loose (generate-error-code vop object-not-signed-byte-32-error + value))) + (signed-byte-32-test value temp t loose okay)) + OKAY + (move value result))) + +;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a +;;; bignum with exactly one positive digit, or a bignum with exactly two digits +;;; and the second digit all zeros. + +(defun unsigned-byte-32-test (value temp not-p target not-target) + (let ((nope (if not-p target not-target))) + (assemble () + ;; Is it a fixnum? + (inst extru value 31 2 zero-tn :<>) + (inst b fixnum) + (inst move value temp) + + ;; If not, is it an other pointer? + (inst extru value 31 3 temp) + (inst bci :<> nil other-pointer-lowtag temp nope) + ;; Get the header. + (loadw temp value 0 other-pointer-lowtag) + ;; Is it one? + (inst bci := nil (+ (ash 1 n-widetag-bits) bignum-widetag) temp single-word) + ;; If it's other than two, we can't be an (unsigned-byte 32) + (inst bci :<> nil (+ (ash 2 n-widetag-bits) bignum-widetag) temp nope) + ;; Get the second digit. + (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag) + ;; All zeros, its an (unsigned-byte 32). + (inst comb (if not-p := :<>) temp zero-tn not-target :nullify t) + (inst b target :nullify t) + + SINGLE-WORD + ;; Get the single digit. + (loadw temp value bignum-digits-offset other-pointer-lowtag) + + ;; positive implies (unsigned-byte 32). + FIXNUM + (inst bc :>= not-p temp zero-tn target))) + (values)) + +(define-vop (unsigned-byte-32-p type-predicate) + (:translate unsigned-byte-32-p) + (:generator 45 + (unsigned-byte-32-test value temp not-p target not-target) + NOT-TARGET)) + +(define-vop (check-unsigned-byte-32 check-type) + (:generator 45 + (let ((loose (generate-error-code vop object-not-unsigned-byte-32-error + value))) + (unsigned-byte-32-test value temp t loose okay)) + OKAY + (move value result))) + + +;;;; List/symbol types: +;;; +;;; symbolp (or symbol (eq nil)) +;;; consp (and list (not (eq nil))) + +(define-vop (symbolp type-predicate) + (:translate symbolp) + (:generator 12 + (inst bc := nil value null-tn (if not-p drop-thru target)) + (test-type value temp target not-p symbol-header-widetag) + DROP-THRU)) + +(define-vop (check-symbol check-type) + (:generator 12 + (inst comb := value null-tn drop-thru) + (let ((error (generate-error-code vop object-not-symbol-error value))) + (test-type value temp error t symbol-header-widetag)) + DROP-THRU + (move value result))) + +(define-vop (consp type-predicate) + (:translate consp) + (:generator 8 + (inst bc := nil value null-tn (if not-p target drop-thru)) + (test-type value temp target not-p list-pointer-lowtag) + DROP-THRU)) + +(define-vop (check-cons check-type) + (:generator 8 + (let ((error (generate-error-code vop object-not-cons-error value))) + (inst bc := nil value null-tn error) + (test-type value temp error t list-pointer-lowtag)) + (move value result))) + +) ; MACROLET \ No newline at end of file diff --git a/src/compiler/hppa/values.lisp b/src/compiler/hppa/values.lisp new file mode 100644 index 0000000..492c77a --- /dev/null +++ b/src/compiler/hppa/values.lisp @@ -0,0 +1,103 @@ +(in-package "SB!VM") + +(define-vop (reset-stack-pointer) + (:args (ptr :scs (any-reg))) + (:generator 1 + (move ptr csp-tn))) + + +;;; Push some values onto the stack, returning the start and number of values +;;; pushed as results. It is assumed that the Vals are wired to the standard +;;; argument locations. Nvals is the number of values to push. +;;; +;;; The generator cost is pseudo-random. We could get it right by defining a +;;; bogus SC that reflects the costs of the memory-to-memory moves for each +;;; operand, but this seems unworthwhile. +;;; +(define-vop (push-values) + (:args + (vals :more t)) + (:results (start :scs (any-reg) :from :load) + (count :scs (any-reg))) + (:info nvals) + (:temporary (:scs (descriptor-reg)) temp) + (:generator 20 + (move csp-tn start) + (inst addi (* nvals n-word-bytes) csp-tn csp-tn) + (do ((val vals (tn-ref-across val)) + (i 0 (1+ i))) + ((null val)) + (let ((tn (tn-ref-tn val))) + (sc-case tn + (descriptor-reg + (storew tn start i)) + (control-stack + (load-stack-tn temp tn) + (storew temp start i))))) + (inst li (fixnumize nvals) count))) + + +;;; Push a list of values on the stack, returning Start and Count as used in +;;; unknown values continuations. +;;; +(define-vop (values-list) + (:args (arg :scs (descriptor-reg) :target list)) + (:arg-types list) + (:policy :fast-safe) + (:results (start :scs (any-reg)) + (count :scs (any-reg))) + (:temporary (:scs (descriptor-reg) :type list :from (:argument 0)) list) + (:temporary (:scs (descriptor-reg)) temp) + (:temporary (:scs (non-descriptor-reg) :type random) ndescr) + (:vop-var vop) + (:save-p :compute-only) + (:generator 0 + (move arg list) + (inst comb := list null-tn done) + (move csp-tn start) + + LOOP + (loadw temp list cons-car-slot list-pointer-lowtag) + (loadw list list cons-cdr-slot list-pointer-lowtag) + (inst addi n-word-bytes csp-tn csp-tn) + (storew temp csp-tn -1) + (inst extru list 31 n-lowtag-bits ndescr) + (inst comib := list-pointer-lowtag ndescr loop) + (inst comb := list null-tn done :nullify t) + (error-call vop bogus-arg-to-values-list-error list) + + DONE + (inst sub csp-tn start count))) + + +;;; Copy the more arg block to the top of the stack so we can use them +;;; as function arguments. +;;; +(define-vop (%more-arg-values) + (:args (context :scs (descriptor-reg any-reg) :target src) + (skip :scs (any-reg zero immediate)) + (num :scs (any-reg) :target count)) + (:temporary (:sc any-reg :from (:argument 0)) src) + (:temporary (:sc any-reg :from (:argument 1)) dst end) + (:temporary (:sc descriptor-reg :from (:argument 1)) temp) + (:results (start :scs (any-reg)) + (count :scs (any-reg))) + (:generator 20 + (sc-case skip + (zero + (move context src)) + (immediate + (inst addi (* (tn-value skip) n-word-bytes) context src)) + (any-reg + (inst add skip context src))) + (move num count) + (inst comb := num zero-tn done) + (inst move csp-tn start) + (inst move csp-tn dst) + (inst add csp-tn count csp-tn) + (inst addi (- n-word-bytes) csp-tn end) + LOOP + (inst ldwm 4 src temp) + (inst comb :< dst end loop) + (inst stwm temp 4 dst) + DONE)) diff --git a/src/compiler/hppa/vm.lisp b/src/compiler/hppa/vm.lisp new file mode 100644 index 0000000..3a2477a --- /dev/null +++ b/src/compiler/hppa/vm.lisp @@ -0,0 +1,353 @@ +(in-package "SB!VM") + + +;;;; Define the registers + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar *register-names* (make-array 32 :initial-element nil))) + +;;; FIXME: These want to turn into macrolets. +(macrolet ((defreg (name offset) + (let ((offset-sym (symbolicate name "-OFFSET"))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (def!constant ,offset-sym ,offset) + (setf (svref *register-names* ,offset-sym) ,(symbol-name name))))) + (defregset (name &rest regs) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter ,name + (list ,@(mapcar #'(lambda (name) (symbolicate name "-OFFSET")) regs)))))) + + ;; Wired-zero + (defreg zero 0) + ;; This gets trashed by the C call convention. + (defreg nfp 1) + (defreg cfunc 2) + ;; These are the callee saves, so these registers are stay live over + ;; call-out. + (defreg csp 3) + (defreg cfp 4) + (defreg bsp 5) + (defreg null 6) + (defreg alloc 7) + (defreg code 8) + (defreg fdefn 9) + (defreg lexenv 10) + (defreg nargs 11) + (defreg ocfp 12) + (defreg lra 13) + (defreg a0 14) + (defreg a1 15) + (defreg a2 16) + (defreg a3 17) + (defreg a4 18) + ;; This is where the caller-saves registers start, but we don't + ;; really care because we need to clear the above after call-out to + ;; make sure no pointers into oldspace are kept around. + (defreg a5 19) + (defreg l0 20) + (defreg l1 21) + (defreg l2 22) + ;; These are the 4 C argument registers. + (defreg nl3 23) + (defreg nl2 24) + (defreg nl1 25) + (defreg nl0 26) + ;; The global Data Pointer. We just leave it alone, because we + ;; don't need it. + (defreg dp 27) + ;; These two are use for C return values. + (defreg nl4 28) + (defreg nl5 29) + (defreg nsp 30) + (defreg lip 31) + + (defregset non-descriptor-regs + nl0 nl1 nl2 nl3 nl4 nl5 nfp cfunc) + + (defregset descriptor-regs + fdefn lexenv nargs ocfp lra a0 a1 a2 a3 a4 a5 l0 l1 l2) + + (defregset *register-arg-offsets* + a0 a1 a2 a3 a4 a5)) + + +(define-storage-base registers :finite :size 32) +(define-storage-base float-registers :finite :size 64) +(define-storage-base control-stack :unbounded :size 8) +(define-storage-base non-descriptor-stack :unbounded :size 0) +(define-storage-base constant :non-packed) +(define-storage-base immediate-constant :non-packed) + +;;; +;;; Handy macro so we don't have to keep changing all the numbers whenever +;;; we insert a new storage class. +;;; +(defmacro !define-storage-classes (&rest classes) + (do ((forms (list 'progn) + (let* ((class (car classes)) + (sc-name (car class)) + (constant-name (intern (concatenate 'simple-string + (string sc-name) + "-SC-NUMBER")))) + (list* `(define-storage-class ,sc-name ,index + ,@(cdr class)) + `(defconstant ,constant-name ,index) + `(export ',constant-name) + forms))) + (index 0 (1+ index)) + (classes classes (cdr classes))) + ((null classes) + (nreverse forms)))) + +(def!constant sb!vm::kludge-nondeterministic-catch-block-size 7) + +(!define-storage-classes + + ;; Non-immediate contstants in the constant pool + (constant constant) + + ;; ZERO and NULL are in registers. + (zero immediate-constant) + (null immediate-constant) + (fp-single-zero immediate-constant) + (fp-double-zero immediate-constant) + + ;; Anything else that can be an immediate. + (immediate immediate-constant) + + + ;; **** The stacks. + + ;; The control stack. (Scanned by GC) + (control-stack control-stack) + + ;; The non-descriptor stacks. + (signed-stack non-descriptor-stack) ; (signed-byte 32) + (unsigned-stack non-descriptor-stack) ; (unsigned-byte 32) + (base-char-stack non-descriptor-stack) ; non-descriptor characters. + (sap-stack non-descriptor-stack) ; System area pointers. + (single-stack non-descriptor-stack) ; single-floats + (double-stack non-descriptor-stack + :element-size 2 :alignment 2) ; double floats. + (complex-single-stack non-descriptor-stack :element-size 2) + (complex-double-stack non-descriptor-stack :element-size 4 :alignment 2) + + + ;; **** Things that can go in the integer registers. + + ;; Immediate descriptor objects. Don't have to be seen by GC, but nothing + ;; bad will happen if they are. (fixnums, characters, header values, etc). + (any-reg + registers + :locations #.(append non-descriptor-regs descriptor-regs) + :constant-scs (zero immediate) + :save-p t + :alternate-scs (control-stack)) + + ;; Pointer descriptor objects. Must be seen by GC. + (descriptor-reg registers + :locations #.descriptor-regs + :constant-scs (constant null immediate) + :save-p t + :alternate-scs (control-stack)) + + ;; Non-Descriptor characters + (base-char-reg registers + :locations #.non-descriptor-regs + :constant-scs (immediate) + :save-p t + :alternate-scs (base-char-stack)) + + ;; Non-Descriptor SAP's (arbitrary pointers into address space) + (sap-reg registers + :locations #.non-descriptor-regs + :constant-scs (immediate) + :save-p t + :alternate-scs (sap-stack)) + + ;; Non-Descriptor (signed or unsigned) numbers. + (signed-reg registers + :locations #.non-descriptor-regs + :constant-scs (zero immediate) + :save-p t + :alternate-scs (signed-stack)) + (unsigned-reg registers + :locations #.non-descriptor-regs + :constant-scs (zero immediate) + :save-p t + :alternate-scs (unsigned-stack)) + + ;; Random objects that must not be seen by GC. Used only as temporaries. + (non-descriptor-reg registers + :locations #.non-descriptor-regs) + + ;; Pointers to the interior of objects. Used only as an temporary. + (interior-reg registers + :locations (#.lip-offset)) + + + ;; **** Things that can go in the floating point registers. + + ;; Non-Descriptor single-floats. + (single-reg float-registers + :locations #.(loop for i from 4 to 31 collect i) + :constant-scs (fp-single-zero) + :save-p t + :alternate-scs (single-stack)) + + ;; Non-Descriptor double-floats. + (double-reg float-registers + :locations #.(loop for i from 4 to 31 collect i) + :constant-scs (fp-double-zero) + :save-p t + :alternate-scs (double-stack)) + + (complex-single-reg float-registers + :locations #.(loop for i from 4 to 30 by 2 collect i) + :element-size 2 + :constant-scs () + :save-p t + :alternate-scs (complex-single-stack)) + + (complex-double-reg float-registers + :locations #.(loop for i from 4 to 30 by 2 collect i) + :element-size 2 + :constant-scs () + :save-p t + :alternate-scs (complex-double-stack)) + + ;; A catch or unwind block. + (catch-block control-stack :element-size sb!vm::kludge-nondeterministic-catch-block-size)) + + +;;;; Make some random tns for important registers. + +(macrolet ((defregtn (name sc) + (let ((offset-sym (symbolicate name "-OFFSET")) + (tn-sym (symbolicate name "-TN"))) + `(defparameter ,tn-sym + (make-random-tn :kind :normal + :sc (sc-or-lose ',sc) + :offset ,offset-sym))))) + + ;; These, we access by foo-TN only + + (defregtn zero any-reg) + (defregtn null descriptor-reg) + (defregtn code descriptor-reg) + (defregtn alloc any-reg) + (defregtn bsp any-reg) + (defregtn csp any-reg) + (defregtn cfp any-reg) + (defregtn nsp any-reg) + + ;; These alias regular locations, so we have to make sure we don't bypass + ;; the register allocator when using them. + (defregtn nargs any-reg) + (defregtn ocfp any-reg) + (defregtn lip interior-reg)) + +;; And some floating point values. +(defparameter fp-single-zero-tn + (make-random-tn :kind :normal + :sc (sc-or-lose 'single-reg) + :offset 0)) +(defparameter fp-double-zero-tn + (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset 0)) + + +;;; Immediate-Constant-SC -- Interface +;;; +;;; If value can be represented as an immediate constant, then return the +;;; appropriate SC number, otherwise return NIL. +;;; +(!def-vm-support-routine immediate-constant-sc (value) + (typecase value + ((integer 0 0) + (sc-number-or-lose 'zero)) + (null + (sc-number-or-lose 'null)) + ((or fixnum system-area-pointer character) + (sc-number-or-lose 'immediate)) + (symbol + (if (static-symbol-p value) + (sc-number-or-lose 'immediate) + nil)) + (single-float + (if (zerop value) + (sc-number-or-lose 'fp-single-zero) + nil)) + (double-float + (if (zerop value) + (sc-number-or-lose 'fp-double-zero) + nil)))) + + +;;;; Function Call Parameters + +;;; The SC numbers for register and stack arguments/return values. +;;; +(defconstant register-arg-scn (meta-sc-number-or-lose 'descriptor-reg)) +(defconstant immediate-arg-scn (meta-sc-number-or-lose 'any-reg)) +(defconstant control-stack-arg-scn (meta-sc-number-or-lose 'control-stack)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + +;;; Offsets of special stack frame locations +(defconstant ocfp-save-offset 0) +(defconstant lra-save-offset 1) +(defconstant nfp-save-offset 2) + +;;; The number of arguments/return values passed in registers. +;;; +(defconstant register-arg-count 6) + +;;; Names to use for the argument registers. +;;; +(defconstant-eqx register-arg-names '(a0 a1 a2 a3 a4 a5) #'equal) + +); Eval-When (:Compile-Toplevel :Load-Toplevel :Execute) + + +;;; A list of TN's describing the register arguments. +;;; +(defparameter register-arg-tns + (mapcar #'(lambda (n) + (make-random-tn :kind :normal + :sc (sc-or-lose 'descriptor-reg) + :offset n)) + *register-arg-offsets*)) + +;;; SINGLE-VALUE-RETURN-BYTE-OFFSET +;;; +;;; This is used by the debugger. +;;; +(defconstant single-value-return-byte-offset 4) + + +;;; LOCATION-PRINT-NAME -- Interface +;;; +;;; This function is called by debug output routines that want a pretty name +;;; for a TN's location. It returns a thing that can be printed with PRINC. +;;; +(!def-vm-support-routine location-print-name (tn) + (declare (type tn tn)) + (let ((sb (sb-name (sc-sb (tn-sc tn)))) + (offset (tn-offset tn))) + (ecase sb + (registers (or (svref *register-names* offset) + (format nil "R~D" offset))) + (float-registers (format nil "F~D" offset)) + (control-stack (format nil "CS~D" offset)) + (non-descriptor-stack (format nil "NS~D" offset)) + (constant (format nil "Const~D" offset)) + (immediate-constant "Immed")))) + +;;; The loader uses this to convert alien names to the form they +;;; occure in the symbol table (for example, prepending an +;;; underscore). On the HPPA we just leave it alone. +(defun extern-alien-name (name) + (declare (type simple-base-string name)) + name) diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp index 3879374..453edf1 100644 --- a/src/compiler/target-disassem.lisp +++ b/src/compiler/target-disassem.lisp @@ -276,71 +276,6 @@ (seg-virtual-location seg) (seg-code seg))))) -;;; All state during disassembly. We store some seemingly redundant -;;; information so that we can allow garbage collect during disassembly and -;;; not get tripped up by a code block being moved... -(defstruct (disassem-state (:conc-name dstate-) - (:constructor %make-dstate) - (:copier nil)) - ;; offset of current pos in segment - (cur-offs 0 :type offset) - ;; offset of next position - (next-offs 0 :type offset) - ;; a sap pointing to our segment - (segment-sap (missing-arg) :type sb!sys:system-area-pointer) - ;; the current segment - (segment nil :type (or null segment)) - ;; what to align to in most cases - (alignment sb!vm:n-word-bytes :type alignment) - (byte-order :little-endian - :type (member :big-endian :little-endian)) - ;; for user code to hang stuff off of - (properties nil :type list) - (filtered-values (make-array max-filtered-value-index) - :type filtered-value-vector) - ;; used for prettifying printing - (addr-print-len nil :type (or null (integer 0 20))) - (argument-column 0 :type column) - ;; to make output look nicer - (output-state :beginning - :type (member :beginning - :block-boundary - nil)) - - ;; alist of (address . label-number) - (labels nil :type list) - ;; same as LABELS slot data, but in a different form - (label-hash (make-hash-table) :type hash-table) - ;; list of function - (fun-hooks nil :type list) - - ;; alist of (address . label-number), popped as it's used - (cur-labels nil :type list) - ;; OFFS-HOOKs, popped as they're used - (cur-offs-hooks nil :type list) - - ;; for the current location - (notes nil :type list) - - ;; currently active source variables - (current-valid-locations nil :type (or null (vector bit)))) -(def!method print-object ((dstate disassem-state) stream) - (print-unreadable-object (dstate stream :type t) - (format stream - "+~W~@[ in ~S~]" - (dstate-cur-offs dstate) - (dstate-segment dstate)))) - -;;; Return the absolute address of the current instruction in DSTATE. -(defun dstate-cur-addr (dstate) - (the address (+ (seg-virtual-location (dstate-segment dstate)) - (dstate-cur-offs dstate)))) - -;;; Return the absolute address of the next instruction in DSTATE. -(defun dstate-next-addr (dstate) - (the address (+ (seg-virtual-location (dstate-segment dstate)) - (dstate-next-offs dstate)))) - ;;;; function ops (defun fun-self (fun) diff --git a/src/runtime/Config.hppa-linux b/src/runtime/Config.hppa-linux new file mode 100644 index 0000000..2b2b731 --- /dev/null +++ b/src/runtime/Config.hppa-linux @@ -0,0 +1,22 @@ +# This software is part of the SBCL system. See the README file for +# more information. +# +# This software is derived from the CMU CL system, which was +# written at Carnegie Mellon University and released into the +# public domain. The software is in the public domain and is +# provided with absolutely no warranty. See the COPYING and CREDITS +# files for more information. + +CFLAGS += -g -Dhppa +LD = ld +LINKFLAGS = -v -g +NM = nm -p + +ASSEM_SRC = hppa-assem.S #hppa-linux-stubs.S +ARCH_SRC = hppa-arch.c undefineds.c + +OS_SRC = linux-os.c hppa-linux-os.c os-common.c +LINKFLAGS+=-static +OS_LIBS= -ldl + +GC_SRC= cheneygc.c diff --git a/src/runtime/hppa-arch.c b/src/runtime/hppa-arch.c new file mode 100644 index 0000000..9e8abb6 --- /dev/null +++ b/src/runtime/hppa-arch.c @@ -0,0 +1,457 @@ +/* + * This software is part of the SBCL system. See the README file for + * more information. + * + * This software is derived from the CMU CL system, which was + * written at Carnegie Mellon University and released into the + * public domain. The software is in the public domain and is + * provided with absolutely no warranty. See the COPYING and CREDITS + * files for more information. + */ +#include + +/* Copied from sparc-arch.c. Not all of these are necessary, probably */ +#include "runtime.h" +#include "arch.h" +#include "sbcl.h" +#include "globals.h" +#include "validate.h" +#include "os.h" +#include "lispregs.h" +#include "signal.h" +#include "alloc.h" +#include "interrupt.h" +#include "interr.h" +#include "breakpoint.h" +#include "monitor.h" + +void arch_init(void) +{ + return; +} + +os_vm_address_t arch_get_bad_addr(int signal, siginfo_t *siginfo, os_context_t *context) +{ + return siginfo->si_addr; +#if 0 +#ifdef hpux + struct save_state *state; + os_vm_address_t addr; + + state = (struct save_state *)(&(scp->sc_sl.sl_ss)); + + if (state == NULL) + return NULL; + + /* Check the instruction address first. */ + addr = (os_vm_address_t)((unsigned long)scp->sc_pcoq_head & ~3); + if (addr < (os_vm_address_t)0x1000) + return addr; + + /* Otherwise, it must have been a data fault. */ + return (os_vm_address_t)state->ss_cr21; +#else + struct hp800_thread_state *state; + os_vm_address_t addr; + + state = (struct hp800_thread_state *)(scp->sc_ap); + + if (state == NULL) + return NULL; + + /* Check the instruction address first. */ + addr = scp->sc_pcoqh & ~3; + if (addr < 0x1000) + return addr; + + /* Otherwise, it must have been a data fault. */ + return state->cr21; +#endif +#endif +} + +unsigned char *arch_internal_error_arguments(os_context_t *context) +{ + return (unsigned char *)((*os_context_pc_addr(context) & ~3) + 4); +} + +boolean arch_pseudo_atomic_atomic(os_context_t *context) +{ + return ((*os_context_register_addr(context,reg_ALLOC)) & 4); +} + +void arch_set_pseudo_atomic_interrupted(os_context_t *context) +{ + *os_context_register_addr(context,reg_ALLOC) |= 1; +} + +void arch_skip_instruction(os_context_t *context) +{ + ((char *) *os_context_pc_addr(context)) = ((char *) *os_context_npc_addr(context)); + ((char *) *os_context_npc_addr(context)) += 4; +} + +unsigned long arch_install_breakpoint(void *pc) +{ + unsigned long *ulpc = (unsigned long *)pc; + unsigned long orig_inst = *ulpc; + + *ulpc = trap_Breakpoint; + os_flush_icache((os_vm_address_t)pc, sizeof(*ulpc)); + return orig_inst; +} + +void arch_remove_breakpoint(void *pc, unsigned long orig_inst) +{ + unsigned long *ulpc = (unsigned long *)pc; + + *ulpc = orig_inst; + os_flush_icache((os_vm_address_t)pc, sizeof(*ulpc)); +} + +void arch_do_displaced_inst(os_context_t *context, unsigned int orig_inst) +{ + /* FIXME: Fill this in */ +#if 0 +#ifdef hpux + /* We change the next-pc to point to a breakpoint instruction, restore */ + /* the original instruction, and exit. We would like to be able to */ + /* sigreturn, but we can't, because this is hpux. */ + unsigned long *pc = (unsigned long *)(SC_PC(scp) & ~3); + + NextPc = SC_NPC(scp); + SC_NPC(scp) = (unsigned)SingleStepTraps | (SC_NPC(scp)&3); + + BreakpointAddr = pc; + *pc = orig_inst; + os_flush_icache((os_vm_address_t)pc, sizeof(unsigned long)); +#else + /* We set the recovery counter to cover one instruction, put the */ + /* original instruction back in, and then resume. We will then trap */ + /* after executing that one instruction, at which time we can put */ + /* the breakpoint back in. */ + + ((struct hp800_thread_state *)scp->sc_ap)->cr0 = 1; + scp->sc_ps |= 0x10; + *(unsigned long *)SC_PC(scp) = orig_inst; + + sigreturn(scp); +#endif +#endif +} + +#ifdef hpux +static void restore_breakpoint(struct sigcontext *scp) +{ + /* We just single-stepped over an instruction that we want to replace */ + /* with a breakpoint. So we put the breakpoint back in, and tweek the */ + /* state so that we will continue as if nothing happened. */ + + if (NextPc == NULL) + lose("SingleStepBreakpoint trap at strange time."); + + if ((SC_PC(scp)&~3) == (unsigned long)SingleStepTraps) { + /* The next instruction was not nullified. */ + SC_PC(scp) = NextPc; + if ((SC_NPC(scp)&~3) == (unsigned long)SingleStepTraps + 4) { + /* The instruction we just stepped over was not a branch, so */ + /* we need to fix it up. If it was a branch, it will point to */ + /* the correct place. */ + SC_NPC(scp) = NextPc + 4; + } + } + else { + /* The next instruction was nullified, so we want to skip it. */ + SC_PC(scp) = NextPc + 4; + SC_NPC(scp) = NextPc + 8; + } + NextPc = NULL; + + if (BreakpointAddr) { + *BreakpointAddr = trap_Breakpoint; + os_flush_icache((os_vm_address_t)BreakpointAddr, + sizeof(unsigned long)); + BreakpointAddr = NULL; + } +} +#endif + +static void sigtrap_handler(int signal, siginfo_t *siginfo, void *void_context) +{ + os_context_t *context = arch_os_get_context(&void_context); + unsigned long bad_inst; + + sigprocmask(SIG_SETMASK, os_context_sigmask_addr(context), 0); +#if 0 + printf("sigtrap_handler, pc=0x%08x, alloc=0x%08x\n", scp->sc_pcoqh, + SC_REG(scp,reg_ALLOC)); +#endif + + bad_inst = *(unsigned long *)(*os_context_pc_addr(context) & ~3); + if (bad_inst & 0xfc001fe0) + interrupt_handle_now(signal, siginfo, context); + else { + int im5 = bad_inst & 0x1f; + + switch (im5) { + case trap_Halt: + fake_foreign_function_call(context); + lose("%%primitive halt called; the party is over.\n"); + + case trap_PendingInterrupt: + arch_skip_instruction(context); + interrupt_handle_pending(context); + break; + + case trap_Error: + case trap_Cerror: + interrupt_internal_error(signal, siginfo, context, im5==trap_Cerror); + break; + + case trap_Breakpoint: + /*sigsetmask(scp->sc_mask); */ + handle_breakpoint(signal, siginfo, context); + break; + + case trap_FunEndBreakpoint: + /*sigsetmask(scp->sc_mask); */ + { + unsigned long pc; + pc = (unsigned long) + handle_fun_end_breakpoint(signal, siginfo, context); + *os_context_pc_addr(context) = pc; + *os_context_npc_addr(context) = pc + 4; + } + break; + + case trap_SingleStepBreakpoint: + /* Uh, FIXME */ +#ifdef hpux + restore_breakpoint(context); +#endif + break; + + default: + interrupt_handle_now(signal, siginfo, context); + break; + } + } +} + +static void sigfpe_handler(int signal, siginfo_t *siginfo, void *void_context) +{ + os_context_t *context = arch_os_get_context(&void_context); + unsigned long badinst; + int opcode, r1, r2, t; + long op1, op2, res; + +#if 0 + printf("sigfpe_handler, pc=0x%08x, alloc=0x%08x\n", scp->sc_pcoqh, + SC_REG(scp,reg_ALLOC)); +#endif + + switch (siginfo->si_code) { + case FPE_INTOVF: /*I_OVFLO: */ + badinst = *(unsigned long *)(*os_context_pc_addr(context) & ~3); + opcode = badinst >> 26; + + if (opcode == 2) { + /* reg/reg inst. */ + r1 = (badinst >> 16) & 0x1f; + op1 = fixnum_value(*os_context_register_addr(context, r1)); + r2 = (badinst >> 21) & 0x1f; + op2 = fixnum_value(*os_context_register_addr(context, r2)); + t = badinst & 0x1f; + + switch ((badinst >> 5) & 0x7f) { + case 0x70: + /* Add and trap on overflow. */ + res = op1 + op2; + break; + + case 0x60: + /* Subtract and trap on overflow. */ + res = op1 - op2; + break; + + default: + goto not_interesting; + } + } + else if ((opcode & 0x37) == 0x25 && (badinst & (1<<11))) { + /* Add or subtract immediate. */ + op1 = ((badinst >> 3) & 0xff) | ((-badinst&1)<<8); + r2 = (badinst >> 16) & 0x1f; + op2 = fixnum_value(*os_context_register_addr(context, r1)); + t = (badinst >> 21) & 0x1f; + if (opcode == 0x2d) + res = op1 + op2; + else + res = op1 - op2; + } + else + goto not_interesting; + + /* ?? What happens here if we hit the end of dynamic space? */ + dynamic_space_free_pointer = (lispobj *) *os_context_register_addr(context, reg_ALLOC); + *os_context_register_addr(context, t) = alloc_number(res); + *os_context_register_addr(context, reg_ALLOC) + = (unsigned long) dynamic_space_free_pointer; + arch_skip_instruction(context); + + break; + + case 0: /* I_COND: ?? Maybe tagged add?? FIXME */ + badinst = *(unsigned long *)(*os_context_pc_addr(context) & ~3); + if ((badinst&0xfffff800) == (0xb000e000|reg_ALLOC<<21|reg_ALLOC<<16)) { + /* It is an ADDIT,OD i,ALLOC,ALLOC instruction that trapped. */ + /* That means that it is the end of a pseudo-atomic. So do the */ + /* add stripping off the pseudo-atomic-interrupted bit, and then */ + /* tell the machine-independent code to process the pseudo- */ + /* atomic. */ + int immed = (badinst>>1)&0x3ff; + if (badinst & 1) + immed |= -1<<10; + *os_context_register_addr(context, reg_ALLOC) += (immed-1); + arch_skip_instruction(context); + interrupt_handle_pending(context); + break; + } + /* else drop-through. */ + default: + not_interesting: + interrupt_handle_now(signal, siginfo, context); + } +} + +/* Merrily cut'n'pasted from sigfpe_handler. On Linux, until + 2.4.19-pa4 (hopefully), the overflow_trap wasn't implemented, + resulting in a SIGBUS instead. We adapt the sigfpe_handler here, in + the hope that it will do as a replacement until the new kernel sees + the light of day. Since the instructions that we need to fix up + tend not to be doing unaligned memory access, this should be a safe + workaround. -- CSR, 2002-08-17 */ +static void sigbus_handler(int signal, siginfo_t *siginfo, void *void_context) +{ + os_context_t *context = arch_os_get_context(&void_context); + unsigned long badinst; + int opcode, r1, r2, t; + long op1, op2, res; + + badinst = *(unsigned long *)(*os_context_pc_addr(context) & ~3); + /* First, test for the pseudo-atomic instruction */ + if ((badinst & 0xfffff800) == (0xb000e000 | + reg_ALLOC<<21 | + reg_ALLOC<<16)) { + /* It is an ADDIT,OD i,ALLOC,ALLOC instruction that trapped. + That means that it is the end of a pseudo-atomic. So do + the add stripping off the pseudo-atomic-interrupted bit, + and then tell the machine-independent code to process the + pseudo-atomic. */ + int immed = (badinst>>1) & 0x3ff; + if (badinst & 1) + immed |= -1<<10; + *os_context_register_addr(context, reg_ALLOC) += (immed-1); + arch_skip_instruction(context); + interrupt_handle_pending(context); + return; + } else { + opcode = badinst >> 26; + if (opcode == 2) { + /* reg/reg inst. */ + r1 = (badinst >> 16) & 0x1f; + op1 = fixnum_value(*os_context_register_addr(context, r1)); + r2 = (badinst >> 21) & 0x1f; + op2 = fixnum_value(*os_context_register_addr(context, r2)); + t = badinst & 0x1f; + + switch ((badinst >> 5) & 0x7f) { + case 0x70: + /* Add and trap on overflow. */ + res = op1 + op2; + break; + + case 0x60: + /* Subtract and trap on overflow. */ + res = op1 - op2; + break; + + default: + goto not_interesting; + } + } else if ((opcode & 0x37) == 0x25 && (badinst & (1<<11))) { + /* Add or subtract immediate. */ + op1 = ((badinst >> 3) & 0xff) | ((-badinst&1)<<8); + r2 = (badinst >> 16) & 0x1f; + op2 = fixnum_value(*os_context_register_addr(context, r1)); + t = (badinst >> 21) & 0x1f; + if (opcode == 0x2d) + res = op1 + op2; + else + res = op1 - op2; + } + else + goto not_interesting; + + /* ?? What happens here if we hit the end of dynamic space? */ + dynamic_space_free_pointer = (lispobj *) *os_context_register_addr(context, reg_ALLOC); + *os_context_register_addr(context, t) = alloc_number(res); + *os_context_register_addr(context, reg_ALLOC) + = (unsigned long) dynamic_space_free_pointer; + arch_skip_instruction(context); + + return; + + not_interesting: + interrupt_handle_now(signal, siginfo, context); + } +} + + +void arch_install_interrupt_handlers(void) +{ + undoably_install_low_level_interrupt_handler(SIGTRAP,sigtrap_handler); + undoably_install_low_level_interrupt_handler(SIGFPE,sigfpe_handler); + /* FIXME: beyond 2.4.19-pa4 this shouldn't be necessary. */ + undoably_install_low_level_interrupt_handler(SIGBUS,sigbus_handler); +} + +lispobj funcall0(lispobj function) +{ + lispobj *args = current_control_stack_pointer; + + return call_into_lisp(function, args, 0); +} + +lispobj funcall1(lispobj function, lispobj arg0) +{ + lispobj *args = current_control_stack_pointer; + + current_control_stack_pointer += 1; + args[0] = arg0; + + return call_into_lisp(function, args, 1); +} + +lispobj funcall2(lispobj function, lispobj arg0, lispobj arg1) +{ + lispobj *args = current_control_stack_pointer; + + current_control_stack_pointer += 2; + args[0] = arg0; + args[1] = arg1; + + return call_into_lisp(function, args, 2); +} + +lispobj funcall3(lispobj function, lispobj arg0, lispobj arg1, lispobj arg2) +{ + lispobj *args = current_control_stack_pointer; + + current_control_stack_pointer += 3; + args[0] = arg0; + args[1] = arg1; + args[2] = arg2; + + return call_into_lisp(function, args, 3); +} diff --git a/src/runtime/hppa-arch.h b/src/runtime/hppa-arch.h new file mode 100644 index 0000000..3a2c96e --- /dev/null +++ b/src/runtime/hppa-arch.h @@ -0,0 +1,6 @@ +#ifndef _HPPA_ARCH_H +#define _HPPA_ARCH_H + +#define ARCH_HAS_NPC_REGISTER + +#endif /* _HPPA_ARCH_H */ diff --git a/src/runtime/hppa-assem.S b/src/runtime/hppa-assem.S new file mode 100644 index 0000000..073e0dc --- /dev/null +++ b/src/runtime/hppa-assem.S @@ -0,0 +1,459 @@ +#define LANGUAGE_ASSEMBLY + +#include "sbcl.h" +#include "lispregs.h" + + .import $global$,data + .import foreign_function_call_active,data + .import current_control_stack_pointer,data + .import current_control_frame_pointer,data + .import current_binding_stack_pointer,data + .import dynamic_space_free_pointer,data + +/* .space $TEXT$ + .subspace $CODE$ + .import $$dyncall,MILLICODE +*/ + +/* + * Call-into-lisp + */ + + .export call_into_lisp +call_into_lisp: + .proc + .callinfo entry_gr=18,save_rp + .entry + /* %arg0=function, %arg1=cfp, %arg2=nargs */ + + stw %rp,-0x14(%sr0,%sp) + stwm %r3,0x40(%sr0,%sp) + stw %r4,-0x3c(%sr0,%sp) + stw %r5,-0x38(%sr0,%sp) + stw %r6,-0x34(%sr0,%sp) + stw %r7,-0x30(%sr0,%sp) + stw %r8,-0x2c(%sr0,%sp) + stw %r9,-0x28(%sr0,%sp) + stw %r10,-0x24(%sr0,%sp) + stw %r11,-0x20(%sr0,%sp) + stw %r12,-0x1c(%sr0,%sp) + stw %r13,-0x18(%sr0,%sp) + stw %r14,-0x14(%sr0,%sp) + stw %r15,-0x10(%sr0,%sp) + stw %r16,-0xc(%sr0,%sp) + stw %r17,-0x8(%sr0,%sp) + stw %r18,-0x4(%sr0,%sp) + + /* Clear the descriptor regs, moving in args as approporate. */ + copy %r0,reg_CODE + copy %r0,reg_FDEFN + copy %arg0,reg_LEXENV + zdep %arg2,29,30,reg_NARGS + copy %r0,reg_OCFP + copy %r0,reg_LRA + copy %r0,reg_A0 + copy %r0,reg_A1 + copy %r0,reg_A2 + copy %r0,reg_A3 + copy %r0,reg_A4 + copy %r0,reg_A5 + copy %r0,reg_L0 + copy %r0,reg_L1 + copy %r0,reg_L2 + + /* Establish NIL. */ + ldil L%NIL,reg_NULL + ldo R%NIL(reg_NULL),reg_NULL + + /* Turn on pseudo-atomic. */ + ldo 4(%r0),reg_ALLOC + + /* No longer in foreign function call land. */ + addil L%foreign_function_call_active-$global$,%dp + stw %r0,R%foreign_function_call_active-$global$(0,%r1) + + /* Load lisp state. */ + addil L%dynamic_space_free_pointer-$global$,%dp + ldw R%dynamic_space_free_pointer-$global$(0,%r1),%r1 + add reg_ALLOC,%r1,reg_ALLOC + addil L%current_binding_stack_pointer-$global$,%dp + ldw R%current_binding_stack_pointer-$global$(0,%r1),reg_BSP + addil L%current_control_stack_pointer-$global$,%dp + ldw R%current_control_stack_pointer-$global$(0,%r1),reg_CSP + addil L%current_control_frame_pointer-$global$,%dp + ldw R%current_control_frame_pointer-$global$(0,%r1),reg_OCFP + copy %arg1,reg_CFP + + /* End of pseudo-atomic. */ + addit,od -4,reg_ALLOC,reg_ALLOC + + /* Establish lisp arguments. */ + ldw 0(reg_CFP),reg_A0 + ldw 4(reg_CFP),reg_A1 + ldw 8(reg_CFP),reg_A2 + ldw 12(reg_CFP),reg_A3 + ldw 16(reg_CFP),reg_A4 + ldw 20(reg_CFP),reg_A5 + + /* Calculate the LRA. */ + ldil L%lra+OTHER_POINTER_LOWTAG,reg_LRA + ldo R%lra+OTHER_POINTER_LOWTAG(reg_LRA),reg_LRA + + /* Indirect the closure */ + ldw CLOSURE_FUN_OFFSET(0,reg_LEXENV),reg_CODE + addi 6*4-FUN_POINTER_LOWTAG,reg_CODE,reg_LIP + + /* And into lisp we go. */ + .export break_here +break_here: + be,n 0(%sr5,reg_LIP) + + break 0,0 + + .align 8 +lra: + .word RETURN_PC_HEADER_WIDETAG + copy reg_OCFP,reg_CSP + + /* Copy CFP (%r4) into someplace else and restore r4. */ + copy reg_CFP,reg_NL1 + ldw -64(0,%sp),%r4 + + /* Copy the return value. */ + copy reg_A0,%ret0 + + /* Turn on pseudo-atomic. */ + addi 4,reg_ALLOC,reg_ALLOC + + /* Store the lisp state. */ + copy reg_ALLOC,reg_NL0 + depi 0,31,3,reg_NL0 + addil L%dynamic_space_free_pointer-$global$,%dp + stw reg_NL0,R%dynamic_space_free_pointer-$global$(0,%r1) + addil L%current_binding_stack_pointer-$global$,%dp + stw reg_BSP,R%current_binding_stack_pointer-$global$(0,%r1) + addil L%current_control_stack_pointer-$global$,%dp + stw reg_CSP,R%current_control_stack_pointer-$global$(0,%r1) + addil L%current_control_frame_pointer-$global$,%dp + stw reg_NL1,R%current_control_frame_pointer-$global$(0,%r1) + + /* Back in C land. [CSP is just a handy non-zero value.] */ + addil L%foreign_function_call_active-$global$,%dp + stw reg_CSP,R%foreign_function_call_active-$global$(0,%r1) + + /* Turn off pseudo-atomic and check for traps. */ + addit,od -4,reg_ALLOC,reg_ALLOC + + + ldw -0x54(%sr0,%sp),%rp + ldw -0x4(%sr0,%sp),%r18 + ldw -0x8(%sr0,%sp),%r17 + ldw -0xc(%sr0,%sp),%r16 + ldw -0x10(%sr0,%sp),%r15 + ldw -0x14(%sr0,%sp),%r14 + ldw -0x18(%sr0,%sp),%r13 + ldw -0x1c(%sr0,%sp),%r12 + ldw -0x20(%sr0,%sp),%r11 + ldw -0x24(%sr0,%sp),%r10 + ldw -0x28(%sr0,%sp),%r9 + ldw -0x2c(%sr0,%sp),%r8 + ldw -0x30(%sr0,%sp),%r7 + ldw -0x34(%sr0,%sp),%r6 + ldw -0x38(%sr0,%sp),%r5 + ldw -0x3c(%sr0,%sp),%r4 + bv %r0(%rp) + ldwm -0x40(%sr0,%sp),%r3 + + + /* And thats all. */ + .exit + .procend + + +/* + * Call-into-C + */ + + + .export call_into_c +call_into_c: + /* Set up a lisp stack frame. Note: we convert the raw return pc into + * a fixnum pc-offset because we don't have ahold of an lra object. + */ + copy reg_CFP, reg_OCFP + copy reg_CSP, reg_CFP + addi 32, reg_CSP, reg_CSP + stw reg_OCFP, 0(0,reg_CFP) + sub reg_LIP, reg_CODE, reg_NL5 + addi 3-OTHER_POINTER_LOWTAG, reg_NL5, reg_NL5 + stw reg_NL5, 4(0,reg_CFP) + stw reg_CODE, 8(0,reg_CFP) + + /* Turn on pseudo-atomic. */ + addi 4, reg_ALLOC, reg_ALLOC + + /* Store the lisp state. */ + copy reg_ALLOC,reg_NL5 + depi 0,31,3,reg_NL5 + addil L%dynamic_space_free_pointer-$global$,%dp + stw reg_NL5,R%dynamic_space_free_pointer-$global$(0,%r1) + addil L%current_binding_stack_pointer-$global$,%dp + stw reg_BSP,R%current_binding_stack_pointer-$global$(0,%r1) + addil L%current_control_stack_pointer-$global$,%dp + stw reg_CSP,R%current_control_stack_pointer-$global$(0,%r1) + addil L%current_control_frame_pointer-$global$,%dp + stw reg_CFP,R%current_control_frame_pointer-$global$(0,%r1) + + /* Back in C land. [CSP is just a handy non-zero value.] */ + addil L%foreign_function_call_active-$global$,%dp + stw reg_CSP,R%foreign_function_call_active-$global$(0,%r1) + + /* Turn off pseudo-atomic and check for traps. */ + addit,od -4,reg_ALLOC,reg_ALLOC + + /* in order to be able to call incrementally linked (ld -A) functions, + we have to do some mild trickery here */ + copy reg_CFUNC,%r22 + bl $$dyncall,%r31 + copy %r31, %r2 + + /* Clear the callee saves descriptor regs. */ + copy %r0, reg_A5 + copy %r0, reg_L0 + copy %r0, reg_L1 + copy %r0, reg_L2 + + /* Turn on pseudo-atomic. */ + ldi 4, reg_ALLOC + + /* Turn off foreign function call. */ + addil L%foreign_function_call_active-$global$,%dp + stw %r0,R%foreign_function_call_active-$global$(0,%r1) + + /* Load ALLOC. */ + addil L%dynamic_space_free_pointer-$global$,%dp + ldw R%dynamic_space_free_pointer-$global$(0,%r1),%r1 + add reg_ALLOC,%r1,reg_ALLOC + + /* We don't need to load OCFP, CFP, CSP, or BSP because they are + * in caller saves registers. + */ + + /* End of pseudo-atomic. */ + addit,od -4,reg_ALLOC,reg_ALLOC + + /* Restore CODE. Even though it is in a callee saves register + * it might have been GC'ed. + */ + ldw 8(0,reg_CFP), reg_CODE + + /* Restore the return pc. */ + ldw 4(0,reg_CFP), reg_NL0 + addi OTHER_POINTER_LOWTAG-3, reg_NL0, reg_NL0 + add reg_CODE, reg_NL0, reg_LIP + + /* Pop the lisp stack frame, and back we go. */ + copy reg_CFP, reg_CSP + be 0(4,reg_LIP) + copy reg_OCFP, reg_CFP + + + +/* + * Stuff to sanctify a block of memory for execution. + */ + + .EXPORT sanctify_for_execution +sanctify_for_execution: + .proc + .callinfo + .entry + /* %arg0=start addr, %arg1=length in bytes */ + add %arg0,%arg1,%arg1 + ldo -1(%arg1),%arg1 + depi 0,31,5,%arg0 + depi 0,31,5,%arg1 + ldsid (%arg0),%r1 + mtsp %r1,%sr1 + ldi 32,%r1 ; bytes per cache line +sanctify_loop: + fdc 0(%sr1,%arg0) + comb,< %arg0,%arg1,sanctify_loop + fic,m %r1(%sr1,%arg0) + + bv %r0(%rp) + nop + + .exit + .procend + + +/* + * Trampolines. + */ + + .EXPORT closure_tramp +closure_tramp: + /* reg_FDEFN holds the fdefn object. */ + ldw FDEFN_FUN_OFFSET(0,reg_FDEFN),reg_LEXENV + ldw CLOSURE_FUN_OFFSET(0,reg_LEXENV),reg_L0 + addi SIMPLE_FUN_CODE_OFFSET, reg_L0, reg_LIP + bv,n 0(reg_LIP) + + .EXPORT undefined_tramp +undefined_tramp: + break trap_Error,0 + .byte 4 + .byte UNDEFINED_FUN_ERROR + .byte 254 + .byte (0x40 + sc_DescriptorReg) + .byte 1 + .align 4 + + +/* + * Core saving/restoring support + */ + + .export call_on_stack +call_on_stack: + /* %arg0 = fn to invoke, %arg1 = new stack base */ + + /* Compute the new stack pointer. */ + addi 64,%arg1,%sp + + /* Zero out the previous stack pointer. */ + stw %r0,-4(0,%sp) + + /* Invoke the function. */ + ble 0(4,%arg0) + copy %r31, %r2 + + /* Flame out. */ + break 0,0 + + .export save_state +save_state: + .proc + .callinfo entry_gr=18,entry_fr=21,save_rp,calls + .entry + + stw %rp,-0x14(%sr0,%sp) + fstds,ma %fr12,8(%sr0,%sp) + fstds,ma %fr13,8(%sr0,%sp) + fstds,ma %fr14,8(%sr0,%sp) + fstds,ma %fr15,8(%sr0,%sp) + fstds,ma %fr16,8(%sr0,%sp) + fstds,ma %fr17,8(%sr0,%sp) + fstds,ma %fr18,8(%sr0,%sp) + fstds,ma %fr19,8(%sr0,%sp) + fstds,ma %fr20,8(%sr0,%sp) + fstds,ma %fr21,8(%sr0,%sp) + stwm %r3,0x70(%sr0,%sp) + stw %r4,-0x6c(%sr0,%sp) + stw %r5,-0x68(%sr0,%sp) + stw %r6,-0x64(%sr0,%sp) + stw %r7,-0x60(%sr0,%sp) + stw %r8,-0x5c(%sr0,%sp) + stw %r9,-0x58(%sr0,%sp) + stw %r10,-0x54(%sr0,%sp) + stw %r11,-0x50(%sr0,%sp) + stw %r12,-0x4c(%sr0,%sp) + stw %r13,-0x48(%sr0,%sp) + stw %r14,-0x44(%sr0,%sp) + stw %r15,-0x40(%sr0,%sp) + stw %r16,-0x3c(%sr0,%sp) + stw %r17,-0x38(%sr0,%sp) + stw %r18,-0x34(%sr0,%sp) + + + /* Remember the function we want to invoke */ + copy %arg0,%r19 + + /* Pass the new stack pointer in as %arg0 */ + copy %sp,%arg0 + + /* Leave %arg1 as %arg1. */ + + /* do the call. */ + ble 0(4,%r19) + copy %r31, %r2 + + .export _restore_state +_restore_state: + + ldw -0xd4(%sr0,%sp),%rp + ldw -0x34(%sr0,%sp),%r18 + ldw -0x38(%sr0,%sp),%r17 + ldw -0x3c(%sr0,%sp),%r16 + ldw -0x40(%sr0,%sp),%r15 + ldw -0x44(%sr0,%sp),%r14 + ldw -0x48(%sr0,%sp),%r13 + ldw -0x4c(%sr0,%sp),%r12 + ldw -0x50(%sr0,%sp),%r11 + ldw -0x54(%sr0,%sp),%r10 + ldw -0x58(%sr0,%sp),%r9 + ldw -0x5c(%sr0,%sp),%r8 + ldw -0x60(%sr0,%sp),%r7 + ldw -0x64(%sr0,%sp),%r6 + ldw -0x68(%sr0,%sp),%r5 + ldw -0x6c(%sr0,%sp),%r4 + ldwm -0x70(%sr0,%sp),%r3 + fldds,mb -8(%sr0,%sp),%fr21 + fldds,mb -8(%sr0,%sp),%fr20 + fldds,mb -8(%sr0,%sp),%fr19 + fldds,mb -8(%sr0,%sp),%fr18 + fldds,mb -8(%sr0,%sp),%fr17 + fldds,mb -8(%sr0,%sp),%fr16 + fldds,mb -8(%sr0,%sp),%fr15 + fldds,mb -8(%sr0,%sp),%fr14 + fldds,mb -8(%sr0,%sp),%fr13 + bv %r0(%rp) + fldds,mb -8(%sr0,%sp),%fr12 + + + .exit + .procend + + .export restore_state +restore_state: + .proc + .callinfo + copy %arg0,%sp + b _restore_state + copy %arg1,%ret0 + .procend + + + + .export SingleStepTraps +SingleStepTraps: + break trap_SingleStepBreakpoint,0 + break trap_SingleStepBreakpoint,0 +/* Missing !! NOT + there's a break 0,0 in the new version here!!! +*/ + + .align 8 + .export fun_end_breakpoint_guts +fun_end_breakpoint_guts: + .word RETURN_PC_HEADER_WIDETAG + /* multiple value return point -- just jump to trap. */ + b,n fun_end_breakpoint_trap + /* single value return point -- convert to multiple w/ n=1 */ + copy reg_CSP, reg_OCFP + addi 4, reg_CSP, reg_CSP + addi 4, %r0, reg_NARGS + copy reg_NULL, reg_A1 + copy reg_NULL, reg_A2 + copy reg_NULL, reg_A3 + copy reg_NULL, reg_A4 + copy reg_NULL, reg_A5 + + .export fun_end_breakpoint_trap +fun_end_breakpoint_trap: + break trap_FunEndBreakpoint,0 + b,n fun_end_breakpoint_trap + + .export fun_end_breakpoint_end +fun_end_breakpoint_end: diff --git a/src/runtime/hppa-linux-os.c b/src/runtime/hppa-linux-os.c new file mode 100644 index 0000000..a6b39dc --- /dev/null +++ b/src/runtime/hppa-linux-os.c @@ -0,0 +1,87 @@ +/* + * This is the HPPA Linux incarnation of arch-dependent OS-dependent + * routines. See also "linux-os.c". + */ + +/* + * This software is part of the SBCL system. See the README file for + * more information. + * + * This software is derived from the CMU CL system, which was + * written at Carnegie Mellon University and released into the + * public domain. The software is in the public domain and is + * provided with absolutely no warranty. See the COPYING and CREDITS + * files for more information. + */ + +#include +#include +#include +#include "./signal.h" +#include "os.h" +#include "arch.h" +#include "globals.h" +#include "interrupt.h" +#include "interr.h" +#include "lispregs.h" +#include "sbcl.h" +#include +#include + +#include +#include +#include +#include +#include + +#include "validate.h" +size_t os_vm_page_size; + + +os_context_register_t * +os_context_register_addr(os_context_t *context, int offset) +{ + if (offset == 0) { + /* KLUDGE: I'm not sure, but it's possible that Linux puts the + contents of the Processor Status Word in the (wired-zero) + slot in the mcontext. In any case, the following is + unlikely to do any harm: */ + static int zero; + zero = 0; + return &zero; + } else { + return &(((struct sigcontext *) &(context->uc_mcontext))->sc_gr[offset]); + } +} + +os_context_register_t * +os_context_pc_addr(os_context_t *context) +{ + /* Why do I get all the silly ports? -- CSR, 2002-08-11 */ + return &(((struct sigcontext *) &(context->uc_mcontext))->sc_iaoq[0]); +} + +os_context_register_t * +os_context_npc_addr(os_context_t *context) +{ + return &(((struct sigcontext *) &(context->uc_mcontext))->sc_iaoq[1]); +} + +sigset_t * +os_context_sigmask_addr(os_context_t *context) +{ + return &(context->uc_sigmask); +} + +void +os_restore_fp_control(os_context_t *context) +{ + /* FIXME: Probably do something. */ +} + +void +os_flush_icache(os_vm_address_t address, os_vm_size_t length) +{ + /* FIXME: Maybe this is OK. */ + sanctify_for_execution(address,length); +} diff --git a/src/runtime/hppa-linux-os.h b/src/runtime/hppa-linux-os.h new file mode 100644 index 0000000..97711b6 --- /dev/null +++ b/src/runtime/hppa-linux-os.h @@ -0,0 +1,13 @@ +#ifndef _HPPA_LINUX_OS_H +#define _HPPA_LINUX_OS_H + +typedef struct ucontext os_context_t; + +static inline os_context_t *arch_os_get_context(void **void_context) { + return (os_context_t *) *void_context; +} + +unsigned long os_context_fp_control(os_context_t *context); +void os_restore_fp_control(os_context_t *context); + +#endif /* _HPPA_LINUX_OS_H */ diff --git a/src/runtime/hppa-lispregs.h b/src/runtime/hppa-lispregs.h new file mode 100644 index 0000000..a08adee --- /dev/null +++ b/src/runtime/hppa-lispregs.h @@ -0,0 +1,63 @@ +#define NREGS (32) + +#ifdef LANGUAGE_ASSEMBLY +#define REG(num) num +#else +#define REG(num) num +#endif + +#define reg_ZERO REG(0) +#define reg_NFP REG(1) +#define reg_CFUNC REG(2) +#define reg_CSP REG(3) +#define reg_CFP REG(4) +#define reg_BSP REG(5) +#define reg_NULL REG(6) +#define reg_ALLOC REG(7) +#define reg_CODE REG(8) +#define reg_FDEFN REG(9) +#define reg_LEXENV REG(10) +#define reg_NARGS REG(11) +#define reg_OCFP REG(12) +#define reg_LRA REG(13) +#define reg_A0 REG(14) +#define reg_A1 REG(15) +#define reg_A2 REG(16) +#define reg_A3 REG(17) +#define reg_A4 REG(18) +#define reg_A5 REG(19) +#define reg_L0 REG(20) +#define reg_L1 REG(21) +#define reg_L2 REG(22) +#define reg_NL3 REG(23) +#define reg_NL2 REG(24) +#define reg_NL1 REG(25) +#define reg_NL0 REG(26) +#define reg_DP REG(27) +#define reg_NL4 REG(28) +#define reg_NL5 REG(29) +#define reg_NSP REG(30) +#define reg_LIP REG(31) + + +#define REGNAMES \ + "ZERO", "NFP", "CFUNC", "CSP", "CFP", "BSP", "NULL", "ALLOC", \ + "CODE", "FDEFN", "LEXENV", "NARGS", "OCFP", "LRA", "A0", "A1", \ + "A2", "A3", "A4", "A5", "L0", "L1", "L2", "NL3", \ + "NL2", "NL1", "NL0", "DP", "NL4", "NL5", "NSP", "LIP" + +#define BOXED_REGISTERS { \ + reg_CODE, reg_FDEFN, reg_LEXENV, reg_NARGS, reg_OCFP, reg_LRA, \ + reg_A0, reg_A1, reg_A2, reg_A3, reg_A4, reg_A5, \ + reg_L0, reg_L1, reg_L2 \ +} + +#ifdef hpux +#define SC_REG(sc, n) (((unsigned long *)(&(sc)->sc_sl.sl_ss.ss_flags))[n]) +#define SC_PC(sc) ((sc)->sc_sl.sl_ss.ss_pcoq_head) +#define SC_NPC(sc) ((sc)->sc_sl.sl_ss.ss_pcoq_tail) +#else +#define SC_REG(sc, n) (((unsigned long *)((sc)->sc_ap))[n]) +#define SC_PC(sc) ((sc)->sc_pcoqh) +#define SC_NPC(sc) ((sc)->sc_pcoqt) +#endif diff --git a/src/runtime/ppc-arch.c b/src/runtime/ppc-arch.c index 2d62424..5e44b63 100644 --- a/src/runtime/ppc-arch.c +++ b/src/runtime/ppc-arch.c @@ -1,12 +1,3 @@ -/* - - $Header$ - - This code was written as part of the CMU Common Lisp project at - Carnegie Mellon University, and has been placed in the public domain. - -*/ - #include #include "arch.h" diff --git a/src/runtime/sparc-arch.c b/src/runtime/sparc-arch.c index 6a79854..114c81f 100644 --- a/src/runtime/sparc-arch.c +++ b/src/runtime/sparc-arch.c @@ -1,12 +1,13 @@ /* - - $Header$ - - This code was written as part of the CMU Common Lisp project at - Carnegie Mellon University, and has been placed in the public domain. - -*/ - + * This software is part of the SBCL system. See the README file for + * more information. + * + * This software is derived from the CMU CL system, which was + * written at Carnegie Mellon University and released into the + * public domain. The software is in the public domain and is + * provided with absolutely no warranty. See the COPYING and CREDITS + * files for more information. + */ #include #include "runtime.h" diff --git a/version.lisp-expr b/version.lisp-expr index 99b7acd..312f71e 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; for internal versions, especially for internal versions off the ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.6.26" +"0.7.6.27" -- 1.7.10.4