Permalink
Browse files

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/
  • Loading branch information...
1 parent 1fd8027 commit 8a19c6876412b8ad1cf729297c2a373d63a0d0ec @csrhodes csrhodes committed Aug 19, 2002
Showing with 10,714 additions and 85 deletions.
  1. +4 −0 NEWS
  2. +1 −0 make-config.sh
  3. +6 −0 src/assembly/hppa/alloc.lisp
  4. +265 −0 src/assembly/hppa/arith.lisp
  5. +96 −0 src/assembly/hppa/array.lisp
  6. +203 −0 src/assembly/hppa/assem-rtns.lisp
  7. +62 −0 src/assembly/hppa/support.lisp
  8. +103 −0 src/code/hppa-vm.lisp
  9. +65 −0 src/compiler/disassem.lisp
  10. +32 −2 src/compiler/generic/genesis.lisp
  11. +170 −0 src/compiler/hppa/alloc.lisp
  12. +878 −0 src/compiler/hppa/arith.lisp
  13. +472 −0 src/compiler/hppa/array.lisp
  14. +7 −0 src/compiler/hppa/backend-parms.lisp
  15. +165 −0 src/compiler/hppa/c-call.lisp
  16. +1,220 −0 src/compiler/hppa/call.lisp
  17. +253 −0 src/compiler/hppa/cell.lisp
  18. +120 −0 src/compiler/hppa/char.lisp
  19. +121 −0 src/compiler/hppa/debug.lisp
  20. +930 −0 src/compiler/hppa/float.lisp
  21. +1,510 −0 src/compiler/hppa/insts.lisp
  22. +383 −0 src/compiler/hppa/macros.lisp
  23. +44 −0 src/compiler/hppa/memory.lisp
  24. +290 −0 src/compiler/hppa/move.lisp
  25. +258 −0 src/compiler/hppa/nlx.lisp
  26. +168 −0 src/compiler/hppa/parms.lisp
  27. +25 −0 src/compiler/hppa/pred.lisp
  28. +26 −0 src/compiler/hppa/sanctify.lisp
  29. +290 −0 src/compiler/hppa/sap.lisp
  30. +31 −0 src/compiler/hppa/show.lisp
  31. +126 −0 src/compiler/hppa/static-fn.lisp
  32. +41 −0 src/compiler/hppa/subprim.lisp
  33. +213 −0 src/compiler/hppa/system.lisp
  34. +15 −0 src/compiler/hppa/target-insts.lisp
  35. +548 −0 src/compiler/hppa/type-vops.lisp
  36. +103 −0 src/compiler/hppa/values.lisp
  37. +353 −0 src/compiler/hppa/vm.lisp
  38. +0 −65 src/compiler/target-disassem.lisp
  39. +22 −0 src/runtime/Config.hppa-linux
  40. +457 −0 src/runtime/hppa-arch.c
  41. +6 −0 src/runtime/hppa-arch.h
  42. +459 −0 src/runtime/hppa-assem.S
  43. +87 −0 src/runtime/hppa-linux-os.c
  44. +13 −0 src/runtime/hppa-linux-os.h
  45. +63 −0 src/runtime/hppa-lispregs.h
  46. +0 −9 src/runtime/ppc-arch.c
  47. +9 −8 src/runtime/sparc-arch.c
  48. +1 −1 version.lisp-expr
View
4 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
View
@@ -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
@@ -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.
+
@@ -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))
@@ -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))
Oops, something went wrong.

0 comments on commit 8a19c68

Please sign in to comment.