Skip to content
Browse files

0.7.1.20:

	merged CSR SPARC port patch (sbcl-devel 2002-02-12, plus
		lotso new files through FTP)
	tweaking patch...
	...s/ARCH_HAS_FOO/ARCH_HAS_FOO_IN_SIGCONTEXT/
	...updated sbcl.1
	...added 'typedef os_context_register' for OpenBSD
	...added ARCH_HAS_STACK_POINTER for x86 (and added
		x86-arch.h to hold it)
	...renamed fpregister and fp.register to float.register (to
		avoid the ambiguity with "frame pointer" that I
		experienced when first trying to figure this out,
		since even though for a given architecture it's pretty
		unambiguous, in architecture-neutral code it's not)
	...added x86-bsd-os.h
  • Loading branch information...
1 parent 63cef08 commit 68fd2d2dd6f265669a8957accd8a33e62786a97e William Harold Newman committed Feb 15, 2002
Showing with 14,642 additions and 169 deletions.
  1. +3 −0 NEWS
  2. +1 −6 TODO
  3. +15 −1 build-order.lisp-expr
  4. +4 −4 doc/sbcl.1
  5. +12 −1 make-config.sh
  6. +16 −0 src/assembly/sparc/alloc.lisp
  7. +573 −0 src/assembly/sparc/arith.lisp
  8. +114 −0 src/assembly/sparc/array.lisp
  9. +238 −0 src/assembly/sparc/assem-rtns.lisp
  10. +78 −0 src/assembly/sparc/support.lisp
  11. +1 −1 src/code/alpha-vm.lisp
  12. +2 −2 src/code/cold-init.lisp
  13. +28 −0 src/code/sc-offset.lisp
  14. +201 −0 src/code/sparc-vm.lisp
  15. +14 −3 src/code/target-hash-table.lisp
  16. +14 −0 src/cold/warm.lisp
  17. +0 −1 src/compiler/aliencomp.lisp
  18. +19 −1 src/compiler/dump.lisp
  19. +3 −0 src/compiler/early-aliencomp.lisp
  20. +40 −19 src/compiler/generic/genesis.lisp
  21. +189 −0 src/compiler/sparc/alloc.lisp
  22. +1,251 −0 src/compiler/sparc/arith.lisp
  23. +716 −0 src/compiler/sparc/array.lisp
  24. +27 −0 src/compiler/sparc/backend-parms.lisp
  25. +252 −0 src/compiler/sparc/c-call.lisp
  26. +1,193 −0 src/compiler/sparc/call.lisp
  27. +276 −0 src/compiler/sparc/cell.lisp
  28. +131 −0 src/compiler/sparc/char.lisp
  29. +122 −0 src/compiler/sparc/debug.lisp
  30. +2,582 −0 src/compiler/sparc/float.lisp
  31. +2,161 −0 src/compiler/sparc/insts.lisp
  32. +445 −0 src/compiler/sparc/macros.lisp
  33. +99 −0 src/compiler/sparc/memory.lisp
  34. +301 −0 src/compiler/sparc/move.lisp
  35. +268 −0 src/compiler/sparc/nlx.lisp
  36. +236 −0 src/compiler/sparc/parms.lisp
  37. +38 −0 src/compiler/sparc/pred.lisp
  38. +304 −0 src/compiler/sparc/sap.lisp
  39. +35 −0 src/compiler/sparc/show.lisp
  40. +142 −0 src/compiler/sparc/static-fn.lisp
  41. +53 −0 src/compiler/sparc/subprim.lisp
  42. +243 −0 src/compiler/sparc/system.lisp
  43. +15 −0 src/compiler/sparc/target-insts.lisp
  44. +542 −0 src/compiler/sparc/type-vops.lisp
  45. +117 −0 src/compiler/sparc/values.lisp
  46. +375 −0 src/compiler/sparc/vm.lisp
  47. +27 −0 src/runtime/Config.sparc-linux
  48. +30 −30 src/runtime/alpha-arch.c
  49. +6 −0 src/runtime/alpha-arch.h
  50. +4 −10 src/runtime/alpha-linux-os.c
  51. +10 −0 src/runtime/alpha-linux-os.h
  52. +4 −0 src/runtime/bsd-os.h
  53. +70 −19 src/runtime/gc.c
  54. +6 −7 src/runtime/interrupt.c
  55. +20 −4 src/runtime/linux-os.c
  56. +4 −2 src/runtime/linux-os.h
  57. +1 −19 src/runtime/lispregs.h
  58. +4 −4 src/runtime/os-common.c
  59. +34 −14 src/runtime/os.h
  60. +8 −8 src/runtime/print.c
  61. +7 −9 src/runtime/purify.c
  62. +399 −0 src/runtime/sparc-arch.c
  63. +6 −0 src/runtime/sparc-arch.h
  64. +295 −0 src/runtime/sparc-assem.S
  65. +91 −0 src/runtime/sparc-linux-os.c
  66. +11 −0 src/runtime/sparc-linux-os.h
  67. +77 −0 src/runtime/sparc-lispregs.h
  68. +15 −0 src/runtime/x86-arch.h
  69. +8 −0 src/runtime/x86-bsd-os.h
  70. +5 −3 src/runtime/x86-linux-os.c
  71. +10 −0 src/runtime/x86-linux-os.h
  72. +1 −1 version.lisp-expr
View
3 NEWS
@@ -1010,6 +1010,9 @@ changes in sbcl-0.7.2 relative to sbcl-0.7.1:
(> SPEED DEBUG). (This is an incompatible change because there are
programs which relied on the old CMU-CL-style behavior to optimize
away their unbounded recursion which will now die of stack overflow.)
+ * SBCL runs on SPARC systems now. (thanks to Christophe Rhodes' port
+ of CMU CL's support for SPARC, and various endianness and other
+ SBCL portability fixes due to Christophe Rhodes and Dan Barlow)
* new syntactic sugar for the Unix command line: --load foo.bar is now
an alternate notation for --eval '(load "foo.bar")'.
* bug fixes:
View
7 TODO
@@ -1,11 +1,6 @@
for early 0.7.x:
-* building with CLISP (or explaining why not). This will likely involve
- a rearrangement of the build system so that it never renames
- the output from COMPILE-FILE, because CLISP's COMPILE-FILE
- outputs two (!) files and as far as I can tell LOAD uses both
- of them. Since I have other motivations for this rearrangement
- besides CLISPiosyncrasies, I'm reasonably motivated to do it.
+* building with CLISP (or explaining why not)
* urgent EVAL/EVAL-WHEN/%COMPILE/DEFUN/DEFSTRUCT cleanup:
** made inlining DEFUN inside MACROLET work again
** (also, while working on INLINE anyway, it might be easy
View
16 build-order.lisp-expr
@@ -190,6 +190,12 @@
#!+bsd ("src/code/bsd-os" :not-host)
#!+linux ("src/code/linux-os" :not-host)
+ ;; sparc-vm and ppc-vm need sc-offset defined to get at internal
+ ;; error args. This file contains stuff previously in
+ ;; debug-info.lisp. Should it therefore be :not-host? -- CSR,
+ ;; 2002-02-05
+ ("src/code/sc-offset")
+
;; KLUDGE: I'd prefer to have this done with a "code/target" softlink
;; instead of a bunch of reader macros. -- WHN 19990308
#!+pmax ("src/code/pmax-vm" :not-host)
@@ -198,6 +204,7 @@
#!+rt ("src/code/rt-vm" :not-host)
#!+hppa ("src/code/hppa-vm" :not-host)
#!+x86 ("src/code/x86-vm" :not-host)
+ #!+ppc ("src/code/ppc-vm" :not-host)
#!+alpha ("src/code/alpha-vm" :not-host)
#!+sgi ("src/code/sgi-vm" :not-host)
@@ -483,10 +490,17 @@
("src/compiler/target/char")
("src/compiler/target/memory")
("src/compiler/target/static-fn")
- ("src/compiler/target/arith")
+ ("src/compiler/target/arith"
+ ;; KLUDGE: for ppc and sparc this appears to be necessary -- see the
+ ;; comment below regarding src/compiler/target/array -- CSR,
+ ;; 2002-05-05
+ :ignore-failure-p)
("src/compiler/target/subprim")
("src/compiler/target/debug")
+ ;; src/compiler/sparc/c-call contains a deftransform for
+ ;; %ALIEN-FUNCALL -- CSR
+ ("src/compiler/early-aliencomp")
("src/compiler/target/c-call")
("src/compiler/target/cell")
("src/compiler/target/values")
View
8 doc/sbcl.1
@@ -345,10 +345,10 @@ chance to see it.
.SH SYSTEM REQUIREMENTS
-Unlike its distinguished ancestor CMU CL, SBCL currently runs only on X86
-(Linux, FreeBSD, and OpenBSD) and Alpha (Linux). For information on
-other ongoing ports, see the sbcl-devel mailing list, and/or the
-web site.
+Unlike its distinguished ancestor CMU CL, SBCL currently runs only on
+X86 (Linux, FreeBSD, and OpenBSD), Alpha (Linux), and SPARC (Linux).
+For information on other ongoing and possible ports, see the
+sbcl-devel mailing list, and/or the web site.
SBCL requires on the order of 16Mb RAM to run on X86 systems.
View
13 make-config.sh
@@ -32,6 +32,8 @@ echo //guessing default target CPU architecture from host architecture
case `uname -m` in
*86) guessed_sbcl_arch=x86 ;;
[Aa]lpha) guessed_sbcl_arch=alpha ;;
+ sparc*) guessed_sbcl_arch=sparc ;;
+ ppc) guessed_sbcl_arch=ppc ;;
*)
# If we're not building on a supported target architecture, we
# we have no guess, but it's not an error yet, since maybe
@@ -70,14 +72,23 @@ done
echo //setting up OS-dependent information
original_dir=`pwd`
cd src/runtime/
-rm -f Config
+rm -f Config target-arch-os.h target-arch.h target-os.h target-lispregs.h
+# KLUDGE: these two logically belong in the previous section
+# ("architecture-dependent"); it seems silly to enforce this in terms
+# of the shell script, though. -- CSR, 2002-02-03
+ln -s $sbcl_arch-arch.h target-arch.h
+ln -s $sbcl_arch-lispregs.h target-lispregs.h
case `uname` in
Linux)
echo -n ' :linux' >> $ltf
ln -s Config.$sbcl_arch-linux Config
+ ln -s $sbcl_arch-linux-os.h target-arch-os.h
+ ln -s linux-os.h target-os.h
;;
*BSD)
echo -n ' :bsd' >> $ltf
+ ln -s $sbcl_arch-bsd-os.h target-arch-os.h
+ ln -s bsd-os.h target-os.h
case `uname` in
FreeBSD)
echo -n ' :freebsd' >> $ltf
View
16 src/assembly/sparc/alloc.lisp
@@ -0,0 +1,16 @@
+;;;; stuff to handle allocation of stuff we don't want to do inline
+
+;;;; 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")
+
+;;; (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.)
View
573 src/assembly/sparc/arith.lisp
@@ -0,0 +1,573 @@
+;;;; Stuff to handle simple cases for generic arithmetic.
+
+;;;; 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")
+
+;;;; Addition and subtraction.
+
+(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 temp non-descriptor-reg nl0-offset)
+ (:temp temp2 non-descriptor-reg nl1-offset)
+ (:temp lra descriptor-reg lra-offset)
+ (:temp nargs any-reg nargs-offset)
+ (:temp ocfp any-reg ocfp-offset))
+ (inst andcc zero-tn x fixnum-tag-mask)
+ (inst b :ne DO-STATIC-FUN)
+ (inst andcc zero-tn y fixnum-tag-mask)
+ (inst b :ne DO-STATIC-FUN)
+ (inst nop)
+ (inst addcc temp x y)
+ (inst b :vc done)
+ (inst nop)
+
+ (inst sra temp x fixnum-tag-bits)
+ (inst sra temp2 y fixnum-tag-bits)
+ (inst add temp2 temp)
+ (with-fixed-allocation (res temp bignum-widetag (1+ bignum-digits-offset))
+ (storew temp2 res bignum-digits-offset other-pointer-lowtag))
+ (lisp-return lra :offset 2)
+
+ DO-STATIC-FUN
+ (inst ld code-tn null-tn (static-fun-offset 'two-arg-+))
+ (inst li nargs (fixnumize 2))
+ (inst move ocfp cfp-tn)
+ (inst j code-tn
+ (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
+ (inst move cfp-tn csp-tn)
+
+ DONE
+ (move res temp))
+
+
+(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 temp non-descriptor-reg nl0-offset)
+ (:temp temp2 non-descriptor-reg nl1-offset)
+ (:temp lra descriptor-reg lra-offset)
+ (:temp nargs any-reg nargs-offset)
+ (:temp ocfp any-reg ocfp-offset))
+ (inst andcc zero-tn x fixnum-tag-mask)
+ (inst b :ne DO-STATIC-FUN)
+ (inst andcc zero-tn y fixnum-tag-mask)
+ (inst b :ne DO-STATIC-FUN)
+ (inst nop)
+ (inst subcc temp x y)
+ (inst b :vc done)
+ (inst nop)
+
+ (inst sra temp x fixnum-tag-bits)
+ (inst sra temp2 y fixnum-tag-bits)
+ (inst sub temp2 temp temp2)
+ (with-fixed-allocation (res temp bignum-widetag (1+ bignum-digits-offset))
+ (storew temp2 res bignum-digits-offset other-pointer-lowtag))
+ (lisp-return lra :offset 2)
+
+ DO-STATIC-FUN
+ (inst ld code-tn null-tn (static-fun-offset 'two-arg--))
+ (inst li nargs (fixnumize 2))
+ (inst move ocfp cfp-tn)
+ (inst j code-tn
+ (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
+ (inst move cfp-tn csp-tn)
+
+ DONE
+ (move res temp))
+
+
+
+;;;; Multiplication
+
+
+(define-assembly-routine (generic-*
+ (:cost 50)
+ (: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 temp non-descriptor-reg nl0-offset)
+ (:temp lo non-descriptor-reg nl1-offset)
+ (:temp hi non-descriptor-reg nl2-offset)
+ (:temp lra descriptor-reg lra-offset)
+ (:temp nargs any-reg nargs-offset)
+ (:temp ocfp any-reg ocfp-offset))
+ ;; If either arg is not a fixnum, call the static function.
+ (inst andcc zero-tn x fixnum-tag-mask)
+ (inst b :ne DO-STATIC-FUN)
+ (inst andcc zero-tn y fixnum-tag-mask)
+ (inst b :ne DO-STATIC-FUN)
+ (inst nop)
+
+ ;; Remove the tag from one arg so that the result will have the correct
+ ;; fixnum tag.
+ (inst sra temp x fixnum-tag-bits)
+ ;; Compute the produce temp * y and return the double-word product
+ ;; in hi:lo.
+ ;;
+ ;; FIXME: Note that the below shebang read-time conditionals aren't
+ ;; actually shebang. This is because the assembly files are also
+ ;; built in warm-init, when #! is not a defined read-macro. This
+ ;; problem will actually go away when we rewrite these low-level
+ ;; bits and pieces to use the backend-subfeatures machinery, as we
+ ;; will then conditionalize at code-emission time or assembly time
+ ;; for the VOP and the assembly routine respectively. - CSR,
+ ;; 2002-02-11
+ #+:sparc-64
+ ;; Sign extend y to a full 64-bits. temp was already
+ ;; sign-extended by the sra instruction above.
+ (progn
+ (inst sra y 0)
+ (inst mulx hi temp y)
+ (inst move lo hi)
+ (inst srax hi 32))
+ #+(and (not :sparc-64) (or :sparc-v8 :sparc-v9))
+ (progn
+ (inst smul lo temp y)
+ (inst rdy hi))
+ #+(and (not :sparc-64) (not (or :sparc-v8 :sparc-v9)))
+ (let ((MULTIPLIER-POSITIVE (gen-label)))
+ (inst wry temp)
+ (inst andcc hi zero-tn)
+ (inst nop)
+ (inst nop)
+ (dotimes (i 32)
+ (inst mulscc hi y))
+ (inst mulscc hi zero-tn)
+ (inst cmp x)
+ (inst b :ge MULTIPLIER-POSITIVE)
+ (inst nop)
+ (inst sub hi y)
+ (emit-label MULTIPLIER-POSITIVE)
+ (inst rdy lo))
+
+ ;; Check to see if the result will fit in a fixnum. (I.e. the high word
+ ;; is just 32 copies of the sign bit of the low word).
+ (inst sra temp lo 31)
+ (inst xorcc temp hi)
+ (inst b :eq LOW-FITS-IN-FIXNUM)
+ ;; Shift the double word hi:lo down two bits to get rid of the fixnum tag.
+ (inst sll temp hi 30)
+ (inst srl lo fixnum-tag-bits)
+ (inst or lo temp)
+ (inst sra hi fixnum-tag-bits)
+ ;; Allocate a BIGNUM for the result.
+ #+nil
+ (pseudo-atomic (:extra (pad-data-block (1+ bignum-digits-offset)))
+ (let ((one-word (gen-label)))
+ (inst or res alloc-tn other-pointer-lowtag)
+ ;; We start out assuming that we need one word. Is that correct?
+ (inst sra temp lo 31)
+ (inst xorcc temp hi)
+ (inst b :eq one-word)
+ (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag))
+ ;; Nope, we need two, so allocate the addition space.
+ (inst add alloc-tn (- (pad-data-block (+ 2 bignum-digits-offset))
+ (pad-data-block (1+ bignum-digits-offset))))
+ (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag))
+ (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag)
+ (emit-label one-word)
+ (storew temp res 0 other-pointer-lowtag)
+ (storew lo res bignum-digits-offset other-pointer-lowtag)))
+ ;; Always allocate 2 words for the bignum result, even if we only
+ ;; need one. The copying GC will take care of the extra word if it
+ ;; isn't needed.
+ (with-fixed-allocation
+ (res temp bignum-widetag (+ 2 bignum-digits-offset))
+ (let ((one-word (gen-label)))
+ (inst or res alloc-tn other-pointer-lowtag)
+ ;; We start out assuming that we need one word. Is that correct?
+ (inst sra temp lo 31)
+ (inst xorcc temp hi)
+ (inst b :eq one-word)
+ (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag))
+ ;; Need 2 words. Set the header appropriately, and save the
+ ;; high and low parts.
+ (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag))
+ (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag)
+ (emit-label one-word)
+ (storew temp res 0 other-pointer-lowtag)
+ (storew lo res bignum-digits-offset other-pointer-lowtag)))
+ ;; Out of here
+ (lisp-return lra :offset 2)
+
+ DO-STATIC-FUN
+ (inst ld code-tn null-tn (static-fun-offset 'two-arg-*))
+ (inst li nargs (fixnumize 2))
+ (inst move ocfp cfp-tn)
+ (inst j code-tn
+ (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
+ (inst move cfp-tn csp-tn)
+
+ LOW-FITS-IN-FIXNUM
+ (move res lo))
+
+(macrolet
+ ((frob (name note cost type sc)
+ `(define-assembly-routine (,name
+ (:note ,note)
+ (:cost ,cost)
+ (:translate *)
+ (:policy :fast-safe)
+ (:arg-types ,type ,type)
+ (:result-types ,type))
+ ((:arg x ,sc nl0-offset)
+ (:arg y ,sc nl1-offset)
+ (:res res ,sc nl0-offset)
+ (:temp temp ,sc nl2-offset))
+ ,@(when (eq type 'tagged-num)
+ `((inst sra x 2)))
+ #+:sparc-64
+ ;; Sign extend, then multiply
+ (progn
+ (inst sra x 0)
+ (inst sra y 0)
+ (inst mulx res x y))
+ #+(and (not :sparc-64) (or :sparc-v8 :sparc-v9))
+ (inst smul res x y)
+ #+(and (not :sparc-64) (not (or :sparc-v8 :sparc-v9)))
+ (progn
+ (inst wry x)
+ (inst andcc temp zero-tn)
+ (inst nop)
+ (inst nop)
+ (dotimes (i 32)
+ (inst mulscc temp y))
+ (inst mulscc temp zero-tn)
+ (inst rdy res)))))
+ (frob unsigned-* "unsigned *" 40 unsigned-num unsigned-reg)
+ (frob signed-* "unsigned *" 41 signed-num signed-reg)
+ (frob fixnum-* "fixnum *" 30 tagged-num any-reg))
+
+
+
+;;;; Division.
+
+#+sb-assembling
+(defun emit-divide-loop (divisor rem quo tagged)
+ (inst li quo 0)
+ (labels
+ ((do-loop (depth)
+ (cond
+ ((zerop depth)
+ (inst unimp 0))
+ (t
+ (let ((label-1 (gen-label))
+ (label-2 (gen-label)))
+ (inst cmp divisor rem)
+ (inst b :geu label-1)
+ (inst nop)
+ (inst sll divisor 1)
+ (do-loop (1- depth))
+ (inst srl divisor 1)
+ (inst cmp divisor rem)
+ (emit-label label-1)
+ (inst b :gtu label-2)
+ (inst sll quo 1)
+ (inst add quo (if tagged (fixnumize 1) 1))
+ (inst sub rem divisor)
+ (emit-label label-2))))))
+ (do-loop (if tagged 30 32))))
+
+(define-assembly-routine (positive-fixnum-truncate
+ (:note "unsigned fixnum truncate")
+ (:cost 45)
+ (:translate truncate)
+ (:policy :fast-safe)
+ (:arg-types positive-fixnum positive-fixnum)
+ (:result-types positive-fixnum positive-fixnum))
+ ((:arg dividend any-reg nl0-offset)
+ (:arg divisor any-reg nl1-offset)
+
+ (:res quo any-reg nl2-offset)
+ (:res rem any-reg nl0-offset))
+
+ (let ((error (generate-error-code nil division-by-zero-error
+ dividend divisor)))
+ (inst cmp divisor)
+ (inst b :eq error))
+
+ (move rem dividend)
+ (emit-divide-loop divisor rem quo t))
+
+
+(define-assembly-routine (fixnum-truncate
+ (:note "fixnum truncate")
+ (:cost 50)
+ (:policy :fast-safe)
+ (:translate truncate)
+ (:arg-types tagged-num tagged-num)
+ (:result-types tagged-num tagged-num))
+ ((:arg dividend any-reg nl0-offset)
+ (:arg divisor any-reg nl1-offset)
+
+ (:res quo any-reg nl2-offset)
+ (:res rem any-reg nl0-offset)
+
+ (:temp quo-sign any-reg nl5-offset)
+ (:temp rem-sign any-reg nargs-offset))
+
+ (let ((error (generate-error-code nil division-by-zero-error
+ dividend divisor)))
+ (inst cmp divisor)
+ (inst b :eq error))
+
+ (inst xor quo-sign dividend divisor)
+ (inst move rem-sign dividend)
+ (let ((label (gen-label)))
+ (inst cmp dividend)
+ (inst ba :lt label)
+ (inst neg dividend)
+ (emit-label label))
+ (let ((label (gen-label)))
+ (inst cmp divisor)
+ (inst ba :lt label)
+ (inst neg divisor)
+ (emit-label label))
+ (move rem dividend)
+ (emit-divide-loop divisor rem quo t)
+ (let ((label (gen-label)))
+ ;; If the quo-sign is negative, we need to negate quo.
+ (inst cmp quo-sign)
+ (inst ba :lt label)
+ (inst neg quo)
+ (emit-label label))
+ (let ((label (gen-label)))
+ ;; If the rem-sign is negative, we need to negate rem.
+ (inst cmp rem-sign)
+ (inst ba :lt label)
+ (inst neg rem)
+ (emit-label label)))
+
+
+(define-assembly-routine (signed-truncate
+ (:note "(signed-byte 32) truncate")
+ (:cost 60)
+ (:policy :fast-safe)
+ (:translate truncate)
+ (:arg-types signed-num signed-num)
+ (:result-types signed-num signed-num))
+
+ ((:arg dividend signed-reg nl0-offset)
+ (:arg divisor signed-reg nl1-offset)
+
+ (:res quo signed-reg nl2-offset)
+ (:res rem signed-reg nl0-offset)
+
+ (:temp quo-sign signed-reg nl5-offset)
+ (:temp rem-sign signed-reg nargs-offset))
+
+ (let ((error (generate-error-code nil division-by-zero-error
+ dividend divisor)))
+ (inst cmp divisor)
+ (inst b :eq error))
+
+ (inst xor quo-sign dividend divisor)
+ (inst move rem-sign dividend)
+ (let ((label (gen-label)))
+ (inst cmp dividend)
+ (inst ba :lt label)
+ (inst neg dividend)
+ (emit-label label))
+ (let ((label (gen-label)))
+ (inst cmp divisor)
+ (inst ba :lt label)
+ (inst neg divisor)
+ (emit-label label))
+ (move rem dividend)
+ (emit-divide-loop divisor rem quo nil)
+ (let ((label (gen-label)))
+ ;; If the quo-sign is negative, we need to negate quo.
+ (inst cmp quo-sign)
+ (inst ba :lt label)
+ (inst neg quo)
+ (emit-label label))
+ (let ((label (gen-label)))
+ ;; If the rem-sign is negative, we need to negate rem.
+ (inst cmp rem-sign)
+ (inst ba :lt label)
+ (inst neg rem)
+ (emit-label label)))
+
+
+;;;; Comparison
+
+(macrolet
+ ((define-cond-assem-rtn (name translate static-fn cmp)
+ `(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 nargs any-reg nargs-offset)
+ (:temp ocfp any-reg ocfp-offset))
+ (inst andcc zero-tn x fixnum-tag-mask)
+ (inst b :ne DO-STATIC-FN)
+ (inst andcc zero-tn y fixnum-tag-mask)
+ (inst b :eq DO-COMPARE)
+ (inst cmp x y)
+
+ DO-STATIC-FN
+ (inst ld code-tn null-tn (static-fun-offset ',static-fn))
+ (inst li nargs (fixnumize 2))
+ (inst move ocfp cfp-tn)
+ (inst j code-tn
+ (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
+ (inst move cfp-tn csp-tn)
+
+ DO-COMPARE
+ (inst b ,cmp done)
+ (load-symbol res t)
+ (inst move res null-tn)
+ DONE)))
+
+ (define-cond-assem-rtn generic-< < two-arg-< :lt)
+ (define-cond-assem-rtn generic-<= <= two-arg-<= :le)
+ (define-cond-assem-rtn generic-> > two-arg-> :gt)
+ (define-cond-assem-rtn generic->= >= two-arg->= :ge))
+
+
+(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 lra descriptor-reg lra-offset)
+ (:temp nargs any-reg nargs-offset)
+ (:temp ocfp any-reg ocfp-offset))
+ (inst cmp x y)
+ (inst b :eq RETURN-T)
+ (inst andcc zero-tn x fixnum-tag-mask)
+ (inst b :eq RETURN-NIL)
+ (inst andcc zero-tn y fixnum-tag-mask)
+ (inst b :ne DO-STATIC-FN)
+ (inst nop)
+
+ RETURN-NIL
+ (inst move res null-tn)
+ (lisp-return lra :offset 2)
+
+ DO-STATIC-FN
+ (inst ld code-tn null-tn (static-fun-offset 'eql))
+ (inst li nargs (fixnumize 2))
+ (inst move ocfp cfp-tn)
+ (inst j code-tn
+ (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
+ (inst move cfp-tn csp-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 lra descriptor-reg lra-offset)
+ (:temp nargs any-reg nargs-offset)
+ (:temp ocfp any-reg ocfp-offset))
+ (inst andcc zero-tn x fixnum-tag-mask)
+ (inst b :ne DO-STATIC-FN)
+ (inst andcc zero-tn y fixnum-tag-mask)
+ (inst b :ne DO-STATIC-FN)
+ (inst cmp x y)
+ (inst b :eq RETURN-T)
+ (inst nop)
+
+ (inst move res null-tn)
+ (lisp-return lra :offset 2)
+
+ DO-STATIC-FN
+ (inst ld code-tn null-tn (static-fun-offset 'two-arg-=))
+ (inst li nargs (fixnumize 2))
+ (inst move ocfp cfp-tn)
+ (inst j code-tn
+ (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
+ (inst move cfp-tn csp-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 lra descriptor-reg lra-offset)
+ (:temp nargs any-reg nargs-offset)
+ (:temp ocfp any-reg ocfp-offset))
+ (inst cmp x y)
+ (inst b :eq RETURN-NIL)
+ (inst andcc zero-tn x fixnum-tag-mask)
+ (inst b :ne DO-STATIC-FN)
+ (inst andcc zero-tn y fixnum-tag-mask)
+ (inst b :ne DO-STATIC-FN)
+ (inst nop)
+
+ (load-symbol res t)
+ (lisp-return lra :offset 2)
+
+ DO-STATIC-FN
+ (inst ld code-tn null-tn (static-fun-offset 'two-arg-=))
+ (inst li nargs (fixnumize 2))
+ (inst move ocfp cfp-tn)
+ (inst j code-tn
+ (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
+ (inst move cfp-tn csp-tn)
+
+ RETURN-NIL
+ (inst move res null-tn))
View
114 src/assembly/sparc/array.lisp
@@ -0,0 +1,114 @@
+;;;; support routines for arrays and vectors
+
+;;;; 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")
+
+(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 ()
+ (inst or vector alloc-tn other-pointer-lowtag)
+ (inst add ndescr words (* (1+ vector-data-offset) n-word-bytes))
+ (inst andn ndescr 7)
+ (inst add alloc-tn ndescr)
+ (inst srl ndescr type word-shift)
+ (storew ndescr vector 0 other-pointer-lowtag)
+ (storew length vector vector-length-slot other-pointer-lowtag))
+ ;; This makes sure the zero byte at the end of a string is paged in so
+ ;; the kernel doesn't bitch if we pass it the string.
+ (storew zero-tn alloc-tn 0)
+ (move result vector))
+
+
+
+;;;; Hash primitives
+
+;;; this is commented out in the alpha port. I'm therefore going to
+;;; comment it out here pending explanation -- CSR, 2001-08-31.
+
+#|
+#+assembler
+(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 temp non-descriptor-reg nl2-offset)
+ (:temp offset non-descriptor-reg nl3-offset))
+
+ (declare (ignore result accum data temp offset))
+
+ (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 temp non-descriptor-reg nl2-offset)
+ (:temp offset non-descriptor-reg nl3-offset))
+ (emit-label sxhash-simple-substring-entry)
+
+ (inst li offset (- (* vector-data-offset n-word-bytes) other-pointer-lowtag))
+ (inst b test)
+ (move accum zero-tn)
+
+ LOOP
+
+ (inst xor accum data)
+ (inst sll temp accum 27)
+ (inst srl accum 5)
+ (inst or accum temp)
+ (inst add offset 4)
+
+ TEST
+
+ (inst subcc length (fixnumize 4))
+ (inst b :ge loop)
+ (inst ld data string offset)
+
+ (inst addcc length (fixnumize 4))
+ (inst b :eq done)
+ (inst neg length)
+ (inst sll length 1)
+ (inst srl data length)
+ (inst xor accum data)
+
+ DONE
+
+ (inst sll result accum 5)
+ (inst srl result result 3))
+|#
View
238 src/assembly/sparc/assem-rtns.lisp
@@ -0,0 +1,238 @@
+;;;; 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")
+
+;;;; 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 ocfp any-reg nl1-offset)
+ (:temp lra descriptor-reg lra-offset)
+
+ ;; These are just needed to facilitate the transfer
+ (:temp count any-reg nl2-offset)
+ (:temp src any-reg nl3-offset)
+ (:temp dst any-reg nl4-offset)
+ (:temp 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))
+
+ ;; Note, because of the way the return-multiple vop is written, we can
+ ;; assume that we are never called with nvals == 1 and that a0 has already
+ ;; been loaded.
+ (inst cmp nvals)
+ (inst b :le default-a0-and-on)
+ (inst cmp nvals (fixnumize 2))
+ (inst b :le default-a2-and-on)
+ (inst ld a1 vals (* 1 n-word-bytes))
+ (inst cmp nvals (fixnumize 3))
+ (inst b :le default-a3-and-on)
+ (inst ld a2 vals (* 2 n-word-bytes))
+ (inst cmp nvals (fixnumize 4))
+ (inst b :le default-a4-and-on)
+ (inst ld a3 vals (* 3 n-word-bytes))
+ (inst cmp nvals (fixnumize 5))
+ (inst b :le default-a5-and-on)
+ (inst ld a4 vals (* 4 n-word-bytes))
+ (inst cmp nvals (fixnumize 6))
+ (inst b :le done)
+ (inst ld a5 vals (* 5 n-word-bytes))
+
+ ;; Copy the remaining args to the top of the stack.
+ (inst add src vals (* 6 n-word-bytes))
+ (inst add dst cfp-tn (* 6 n-word-bytes))
+ (inst subcc count nvals (fixnumize 6))
+
+ LOOP
+ (inst ld temp src)
+ (inst add src n-word-bytes)
+ (inst st temp dst)
+ (inst add dst n-word-bytes)
+ (inst b :gt loop)
+ (inst subcc count (fixnumize 1))
+
+ (inst b done)
+ (inst nop)
+
+ DEFAULT-A0-AND-ON
+ (inst move a0 null-tn)
+ (inst move a1 null-tn)
+ DEFAULT-A2-AND-ON
+ (inst move a2 null-tn)
+ DEFAULT-A3-AND-ON
+ (inst move a3 null-tn)
+ DEFAULT-A4-AND-ON
+ (inst move a4 null-tn)
+ DEFAULT-A5-AND-ON
+ (inst move a5 null-tn)
+ DONE
+
+ ;; Clear the stack.
+ (move ocfp-tn cfp-tn)
+ (move cfp-tn ocfp)
+ (inst add csp-tn ocfp-tn nvals)
+
+ ;; 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 nargs csp-tn args)
+
+ ;; Load the argument regs (must do this now, 'cause the blt might
+ ;; trash these locations)
+ (inst ld a0 args (* 0 n-word-bytes))
+ (inst ld a1 args (* 1 n-word-bytes))
+ (inst ld a2 args (* 2 n-word-bytes))
+ (inst ld a3 args (* 3 n-word-bytes))
+ (inst ld a4 args (* 4 n-word-bytes))
+ (inst ld a5 args (* 5 n-word-bytes))
+
+ ;; Calc SRC, DST, and COUNT
+ (inst addcc count nargs (fixnumize (- register-arg-count)))
+ (inst b :le done)
+ (inst add src args (* n-word-bytes register-arg-count))
+ (inst add dst cfp-tn (* n-word-bytes register-arg-count))
+
+ LOOP
+ ;; Copy one arg.
+ (inst ld temp src)
+ (inst add src src n-word-bytes)
+ (inst st temp dst)
+ (inst addcc count (fixnumize -1))
+ (inst b :gt loop)
+ (inst add dst dst n-word-bytes)
+
+ DONE
+ ;; We are done. Do the jump.
+ (loadw temp lexenv closure-fun-slot fun-pointer-lowtag)
+ (lisp-jump temp))
+
+
+
+;;;; Non-local exit noise.
+
+(define-assembly-routine (unwind
+ (:return-style :none)
+ (: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))
+
+ (let ((error (generate-error-code nil invalid-unwind-error)))
+ (inst cmp block)
+ (inst b :eq error))
+
+ (load-symbol-value cur-uwp *current-unwind-protect-block*)
+ (loadw target-uwp block unwind-block-current-uwp-slot)
+ (inst cmp cur-uwp target-uwp)
+ (inst b :ne do-uwp)
+ (inst nop)
+
+ (move cur-uwp block)
+
+ 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
+ (:return-style :none))
+ ((:arg target descriptor-reg a0-offset)
+ (:arg start any-reg ocfp-offset)
+ (:arg count any-reg nargs-offset)
+ (:temp catch any-reg a1-offset)
+ (:temp tag descriptor-reg a2-offset)
+ (:temp temp non-descriptor-reg nl0-offset))
+
+ (declare (ignore start count))
+
+ (load-symbol-value catch *current-catch-block*)
+
+ loop
+
+ (let ((error (generate-error-code nil unseen-throw-tag-error target)))
+ (inst cmp catch)
+ (inst b :eq error)
+ (inst nop))
+
+ (loadw tag catch catch-block-tag-slot)
+ (inst cmp tag target)
+ (inst b :eq exit)
+ (inst nop)
+ (loadw catch catch catch-block-previous-catch-slot)
+ (inst b loop)
+ (inst nop)
+
+ exit
+
+ (move target catch)
+ (inst li temp (make-fixup 'unwind :assembly-routine))
+ (inst j temp)
+ (inst nop))
+
+
View
78 src/assembly/sparc/support.lisp
@@ -0,0 +1,78 @@
+;;;; the machine-specific support routines needed by the file assembler
+
+;;;; 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")
+
+(!def-vm-support-routine generate-call-sequence (name style vop)
+ (ecase style
+ (:raw
+ (let ((temp (make-symbol "TEMP"))
+ (lip (make-symbol "LIP")))
+ (values
+ `((inst jali ,lip ,temp (make-fixup ',name :assembly-routine))
+ (inst nop))
+ `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1))
+ ,temp)
+ (:temporary (:scs (interior-reg) :from (:eval 0) :to (:eval 1))
+ ,lip)))))
+ (: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 ,lra code-tn lra-label ,temp)
+ (note-next-instruction ,vop :call-site)
+ (inst ji ,temp (make-fixup ',name :assembly-routine))
+ (inst nop)
+ (emit-return-pc lra-label)
+ (note-this-location ,vop :single-value-return)
+ (without-scheduling ()
+ (move csp-tn ocfp-tn)
+ (inst nop))
+ (inst compute-code-from-lra code-tn code-tn
+ lra-label ,temp)
+ (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 ((temp (make-symbol "TEMP")))
+ (values
+ `((inst ji ,temp (make-fixup ',name :assembly-routine))
+ (inst nop))
+ `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1))
+ ,temp)))))))
+
+(!def-vm-support-routine generate-return-sequence (style)
+ (ecase style
+ (:raw
+ `((inst j
+ (make-random-tn :kind :normal
+ :sc (sc-or-lose 'interior-reg)
+ :offset lip-offset)
+ 8)
+ (inst nop)))
+ (:full-call
+ `((lisp-return (make-random-tn :kind :normal
+ :sc (sc-or-lose 'descriptor-reg)
+ :offset lra-offset)
+ :offset 2)))
+ (:none)))
View
2 src/code/alpha-vm.lisp
@@ -102,7 +102,7 @@
;;; FIXME: Whether COERCE actually knows how to make a float out of a
;;; long is another question. This stuff still needs testing.
-(define-alien-routine ("os_context_fpregister_addr"
+(define-alien-routine ("os_context_float_register_addr"
context-float-register-addr)
(* long)
(context (* os-context-t))
View
4 src/code/cold-init.lisp
@@ -210,7 +210,7 @@
;; Barlow's Alpha patches suppress it for Alpha. Why the difference?
#!+alpha
(set-floating-point-modes :traps '(:overflow
- #!-x86 :underflow
+ #!+alpha :underflow
:invalid
:divide-by-zero))
@@ -289,7 +289,7 @@ instead (which is another name for the same thing)."))
;; disabled by default. Joe User can
;; explicitly enable them if
;; desired.
- #!-x86 :underflow))
+ #!+alpha :underflow))
;; Clear pseudo atomic in case this core wasn't compiled with
;; support.
;;
View
28 src/code/sc-offset.lisp
@@ -0,0 +1,28 @@
+;;;; 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.
+
+;;; SC-OFFSETs are needed by sparc-vm.lisp
+
+(in-package "SB!C")
+
+;;;; SC-OFFSETs
+;;;;
+;;;; We represent the place where some value is stored with a SC-OFFSET,
+;;;; which is the SC number and offset encoded as an integer.
+
+(defconstant-eqx sc-offset-scn-byte (byte 5 0) #'equalp)
+(defconstant-eqx sc-offset-offset-byte (byte 22 5) #'equalp)
+(def!type sc-offset () '(unsigned-byte 27))
+
+(defmacro make-sc-offset (scn offset)
+ `(dpb ,scn sc-offset-scn-byte
+ (dpb ,offset sc-offset-offset-byte 0)))
+
+(defmacro sc-offset-scn (sco) `(ldb sc-offset-scn-byte ,sco))
+(defmacro sc-offset-offset (sco) `(ldb sc-offset-offset-byte ,sco))
View
201 src/code/sparc-vm.lisp
@@ -0,0 +1,201 @@
+;;;; SPARC-specific runtime stuff
+
+;;;; 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")
+
+
+
+;;; See x86-vm.lisp for a description of this.
+(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."
+ "SPARC")
+
+(defun machine-version ()
+ "Returns a string describing the version of the local machine."
+ "SPARC")
+
+
+(defun fixup-code-object (code offset fixup kind)
+ (declare (type index offset))
+ (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))))
+ (ecase kind
+ (:call
+ (error "Can't deal with CALL fixups, yet."))
+ (:sethi
+ (setf (ldb (byte 22 0) (sap-ref-32 sap offset))
+ (ldb (byte 22 10) fixup)))
+ (:add
+ (setf (ldb (byte 10 0) (sap-ref-32 sap offset))
+ (ldb (byte 10 0) fixup)))))))
+
+
+;;;; "Sigcontext" access functions, cut & pasted from alpha-vm.lisp.
+;;;;
+;;;; See also x86-vm for commentary on signed vs unsigned.
+
+(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 (deref (context-pc-addr context))))
+
+(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))
+
+;;; This is like CONTEXT-REGISTER, but returns the value of a float
+;;; register. FORMAT is the type of float to return.
+
+;;; FIXME: Whether COERCE actually knows how to make a float out of a
+;;; long is another question. This stuff still needs testing.
+#+nil
+(define-alien-routine ("os_context_float_register_addr" context-float-register-addr)
+ (* long)
+ (context (* os-context-t))
+ (index int))
+#+nil
+(defun context-float-register (context index format)
+ (declare (type (alien (* os-context-t)) context))
+ (coerce (deref (context-float-register-addr context index)) format))
+#+nil
+(defun %set-context-float-register (context index format new)
+ (declare (type (alien (* os-context-t)) context))
+ (setf (deref (context-float-register-addr context index))
+ (coerce new format)))
+
+;;; Given a signal context, return the floating point modes word in
+;;; the same format as returned by FLOATING-POINT-MODES.
+(defun context-floating-point-modes (context)
+ ;; FIXME: As of sbcl-0.6.7 and the big rewrite of signal handling for
+ ;; POSIXness and (at the Lisp level) opaque signal contexts,
+ ;; this is stubified. It needs to be rewritten as an
+ ;; alien function.
+ (warn "stub CONTEXT-FLOATING-POINT-MODES")
+ ;; old code for Linux:
+ #+nil
+ (let ((cw (slot (deref (slot context 'fpstate) 0) 'cw))
+ (sw (slot (deref (slot context 'fpstate) 0) 'sw)))
+ ;;(format t "cw = ~4X~%sw = ~4X~%" cw sw)
+ ;; NOT TESTED -- Clear sticky bits to clear interrupt condition.
+ (setf (slot (deref (slot context 'fpstate) 0) 'sw) (logandc2 sw #x3f))
+ ;;(format t "new sw = ~X~%" (slot (deref (slot context 'fpstate) 0) 'sw))
+ ;; Simulate floating-point-modes VOP.
+ (logior (ash (logand sw #xffff) 16) (logxor (logand cw #xffff) #x3f)))
+
+ 0)
+
+;;;; INTERNAL-ERROR-ARGS.
+
+;;; Given a (POSIX) signal context, extract the internal error
+;;; arguments from the instruction stream. This is e.g.
+;;; 4 23 254 240 2 0 0 0
+;;; | ~~~~~~~~~~~~~~~~~~~~~~~~~
+;;; length data (everything is an octet)
+;;; (pc)
+(defun internal-error-args (context)
+ (declare (type (alien (* os-context-t)) context))
+ (sb!int::/show0 "entering INTERNAL-ERROR-ARGS")
+ (let* ((pc (context-pc context))
+ (bad-inst (sap-ref-32 pc 0))
+ (op (ldb (byte 2 30) bad-inst))
+ (op2 (ldb (byte 3 22) bad-inst))
+ (op3 (ldb (byte 6 19) bad-inst)))
+ (declare (type system-area-pointer pc))
+ (cond ((and (= op #b00) (= op2 #b000))
+ (args-for-unimp-inst context))
+ ((and (= op #b10) (= (ldb (byte 4 2) op3) #b1000))
+ (args-for-tagged-add-inst context bad-inst))
+ ((and (= op #b10) (= op3 #b111010))
+ (args-for-tcc-inst bad-inst))
+ (t
+ (values #.(error-number-or-lose 'unknown-error) nil)))))
+
+(defun args-for-unimp-inst (context)
+ (declare (type (alien (* os-context-t)) context))
+ (let* ((pc (context-pc context))
+ (length (sap-ref-8 pc 4))
+ (vector (make-array length :element-type '(unsigned-byte 8))))
+ (declare (type system-area-pointer pc)
+ (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))))))
+
+(defun args-for-tagged-add-inst (context bad-inst)
+ (declare (type (alien (* os-context-t)) context))
+ (let* ((rs1 (ldb (byte 5 14) bad-inst))
+ (op1 (sb!kernel:make-lisp-obj (context-register context rs1))))
+ (if (fixnump op1)
+ (if (zerop (ldb (byte 1 13) bad-inst))
+ (let* ((rs2 (ldb (byte 5 0) bad-inst))
+ (op2 (sb!kernel:make-lisp-obj (context-register context rs2))))
+ (if (fixnump op2)
+ (values #.(error-number-or-lose 'unknown-error) nil)
+ (values #.(error-number-or-lose 'object-not-fixnum-error)
+ (list (sb!c::make-sc-offset
+ descriptor-reg-sc-number
+ rs2)))))
+ (values #.(error-number-or-lose 'unknown-error) nil))
+ (values #.(error-number-or-lose 'object-not-fixnum-error)
+ (list (sb!c::make-sc-offset descriptor-reg-sc-number
+ rs1))))))
+
+(defun args-for-tcc-inst (bad-inst)
+ (let* ((trap-number (ldb (byte 8 0) bad-inst))
+ (reg (ldb (byte 5 8) bad-inst)))
+ (values (case trap-number
+ (#.object-not-list-trap
+ #.(error-number-or-lose 'object-not-list-error))
+ (#.object-not-instance-trap
+ #.(error-number-or-lose 'object-not-instance-error))
+ (t
+ #.(error-number-or-lose 'unknown-error)))
+ (list (sb!c::make-sc-offset descriptor-reg-sc-number reg)))))
+
+
+;;; Do whatever is necessary to make the given code component
+;;; executable. On the sparc, we don't need to do anything, because
+;;; the i and d caches are unified.
+(defun sanctify-for-execution (component)
+ (declare (ignore component))
+ nil)
View
17 src/code/target-hash-table.lisp
@@ -140,7 +140,18 @@
;; boxing.
(rehash-threshold (float rehash-threshold 1.0))
(size+1 (1+ size)) ; The first element is not usable.
- (scaled-size (round (/ (float size+1) rehash-threshold)))
+ ;; KLUDGE: The most natural way of expressing the below is
+ ;; (round (/ (float size+1) rehash-threshold)), and indeed
+ ;; it was expressed like that until 0.7.0. However,
+ ;; MAKE-HASH-TABLE is called very early in cold-init, and
+ ;; the SPARC has no primitive instructions for rounding,
+ ;; but only for truncating; therefore, we fudge this issue
+ ;; a little. The other uses of truncate, below, similarly
+ ;; used to be round. -- CSR, 2002-10-01
+ ;;
+ ;; Note that this has not yet been audited for
+ ;; correctness. It just seems to work. -- CSR, 2002-11-02
+ (scaled-size (truncate (/ (float size+1) rehash-threshold)))
(length (almost-primify (max scaled-size
(1+ +min-hash-table-size+))))
(index-vector (make-array length
@@ -224,7 +235,7 @@
(fixnum
(+ rehash-size old-size))
(float
- (the index (round (* rehash-size old-size)))))))
+ (the index (truncate (* rehash-size old-size)))))))
(new-kv-vector (make-array (* 2 new-size)
:initial-element +empty-ht-slot+))
(new-next-vector (make-array new-size
@@ -236,7 +247,7 @@
:initial-element #x80000000)))
(old-index-vector (hash-table-index-vector table))
(new-length (almost-primify
- (round (/ (float new-size)
+ (truncate (/ (float new-size)
(hash-table-rehash-threshold table)))))
(new-index-vector (make-array new-length
:element-type '(unsigned-byte 32)
View
14 src/cold/warm.lisp
@@ -13,6 +13,20 @@
;;;; general warm init compilation policy
+;;; Without generational GC, GC gets really slow unless we collect in
+;;; large chunks. For small chunks, efficiency tends to grow roughly
+;;; linearly with chunk size. Later we hit diminishing returns as we
+;;; approach the total amount of RAM we use, or we can even get into
+;;; performance trouble by clobbering cache and VM systems too hard.
+;;; But modern machines tend to think of 20 Mb as a moderate amount of
+;;; memory, and it's of the same order of magnitude as the amount of
+;;; RAM we need for the build, so it seems like a plausible chunk size.
+#-gencgc
+(progn
+ (sb!ext:gc-off)
+ (setf (sb!ext:bytes-consed-between-gcs) (* 20 (expt 10 6)))
+ (sb!ext:gc-on))
+
(proclaim '(optimize (compilation-speed 1)
(debug #+sb-show 2 #-sb-show 1)
(inhibit-warnings 2)
View
1 src/compiler/aliencomp.lisp
@@ -68,7 +68,6 @@
(defknown alien-funcall (alien-value &rest *) *
(any recursive))
-(defknown %alien-funcall (system-area-pointer alien-type &rest *) *)
;;;; cosmetic transforms
View
20 src/compiler/dump.lisp
@@ -753,6 +753,20 @@
(t
(sub-dump-object obj file))))))
+;;; In the grand scheme of things I don't pretend to understand any
+;;; more how this works, or indeed whether. But to write out specialized
+;;; vectors in the same format as fop-int-vector expects to read them
+;;; we need to be target-endian. dump-integer-as-n-bytes always writes
+;;; little-endian (which is correct for all other integers) so for a bigendian
+;;; target we need to swap octets -- CSR, after DB
+
+(defun octet-swap (word bits)
+ "BITS must be a multiple of 8"
+ (do ((input word (ash input -8))
+ (output 0 (logior (ash output 8) (logand input #xff)))
+ (bits bits (- bits 8)))
+ ((<= bits 0) output)))
+
(defun dump-i-vector (vec file &key data-only)
(declare (type (simple-array * (*)) vec))
(let ((len (length vec)))
@@ -772,7 +786,11 @@
(multiple-value-bind (floor rem) (floor size 8)
(aver (zerop rem))
(dovector (i vec)
- (dump-integer-as-n-bytes i floor file))))
+ (dump-integer-as-n-bytes
+ (ecase sb!c:*backend-byte-order*
+ (:little-endian i)
+ (:big-endian (octet-swap i size)))
+ floor file))))
(t ; harder cases, not supported in cross-compiler
(dump-raw-bytes vec bytes file))))
(dump-signed-vector (size bytes)
View
3 src/compiler/early-aliencomp.lisp
@@ -0,0 +1,3 @@
+(in-package "SB!C")
+
+(defknown %alien-funcall (system-area-pointer alien-type &rest *) *)
View
59 src/compiler/generic/genesis.lisp
@@ -405,32 +405,38 @@
(n)
(let* ((name (intern (format nil "BYTE-VECTOR-REF-~A" n)))
(number-octets (/ n 8))
- (ash-list
+ (ash-list-le
(loop for i from 0 to (1- number-octets)
collect `(ash (aref byte-vector (+ byte-index ,i))
,(* i 8))))
- (setf-list
+ (ash-list-be
+ (loop for i from 0 to (1- number-octets)
+ collect `(ash (aref byte-vector (+ byte-index
+ ,(- number-octets 1 i)))
+ ,(* i 8))))
+ (setf-list-le
(loop for i from 0 to (1- number-octets)
append
`((aref byte-vector (+ byte-index ,i))
- (ldb (byte 8 ,(* i 8)) new-value)))))
+ (ldb (byte 8 ,(* i 8)) new-value))))
+ (setf-list-be
+ (loop for i from 0 to (1- number-octets)
+ append
+ `((aref byte-vector (+ byte-index ,i))
+ (ldb (byte 8 ,(- n 8 (* i 8))) new-value)))))
`(progn
(defun ,name (byte-vector byte-index)
- (aver (= sb!vm:n-word-bits 32))
- (aver (= sb!vm:n-byte-bits 8))
- (ecase sb!c:*backend-byte-order*
- (:little-endian
- (logior ,@ash-list))
- (:big-endian
- (error "stub: no big-endian ports of SBCL (yet?)"))))
- (defun (setf ,name) (new-value byte-vector byte-index)
- (aver (= sb!vm:n-word-bits 32))
- (aver (= sb!vm:n-byte-bits 8))
- (ecase sb!c:*backend-byte-order*
- (:little-endian
- (setf ,@setf-list))
- (:big-endian
- (error "stub: no big-endian ports of SBCL (yet?)"))))))))
+ (aver (= sb!vm:n-word-bits 32))
+ (aver (= sb!vm:n-byte-bits 8))
+ (logior ,@(ecase sb!c:*backend-byte-order*
+ (:little-endian ash-list-le)
+ (:big-endian ash-list-be))))
+ (defun (setf ,name) (new-value byte-vector byte-index)
+ (aver (= sb!vm:n-word-bits 32))
+ (aver (= sb!vm:n-byte-bits 8))
+ (setf ,@(ecase sb!c:*backend-byte-order*
+ (:little-endian setf-list-le)
+ (:big-endian setf-list-be))))))))
(make-byte-vector-ref-n 8)
(make-byte-vector-ref-n 16)
(make-byte-vector-ref-n 32))
@@ -1636,6 +1642,20 @@
(ldb (byte 8 0) value)
(byte-vector-ref-8 gspace-bytes (1+ gspace-byte-offset))
(ldb (byte 8 8) value)))))
+ (:sparc
+ (ecase kind
+ (:call
+ (error "Can't deal with call fixups yet."))
+ (:sethi
+ (setf (byte-vector-ref-32 gspace-bytes gspace-byte-offset)
+ (dpb (ldb (byte 22 10) value)
+ (byte 22 0)
+ (byte-vector-ref-32 gspace-bytes gspace-byte-offset))))
+ (:add
+ (setf (byte-vector-ref-32 gspace-bytes gspace-byte-offset)
+ (dpb (ldb (byte 10 0) value)
+ (byte 10 0)
+ (byte-vector-ref-32 gspace-bytes gspace-byte-offset))))))
(:x86
(let* ((un-fixed-up (byte-vector-ref-32 gspace-bytes
gspace-byte-offset))
@@ -2970,7 +2990,8 @@ initially undefined function references:~2%")
sb!vm:static-space-start))
(*dynamic* (make-gspace :dynamic
dynamic-space-id
- sb!vm:dynamic-space-start))
+ #!+gencgc sb!vm:dynamic-space-start
+ #!-gencgc sb!vm:dynamic-0-space-start))
(*nil-descriptor* (make-nil-descriptor))
(*current-reversed-cold-toplevels* *nil-descriptor*)
(*unbound-marker* (make-other-immediate-descriptor
View
189 src/compiler/sparc/alloc.lisp
@@ -0,0 +1,189 @@
+;;;; allocation VOPs for the Sparc port
+
+;;;; 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")
+
+;;;; 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 result null-tn))
+ ((and star (= num 1))
+ (move result (tn-ref-tn things)))
+ (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)
+ (inst andn res alloc-tn lowtag-mask)
+ (inst or res list-pointer-lowtag)
+ (move ptr res)
+ (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 add ptr ptr (pad-data-block cons-size))
+ (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 result res)))))))
+
+(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 add boxed boxed-arg (fixnumize (1+ code-trace-table-offset-slot)))
+ (inst and boxed (lognot lowtag-mask))
+ (inst srl unboxed unboxed-arg word-shift)
+ (inst add unboxed lowtag-mask)
+ (inst and unboxed (lognot lowtag-mask))
+ (pseudo-atomic ()
+ ;; CMUCL Comment:
+ ;; Note: we don't have to subtract off the 4 that was added by
+ ;; pseudo-atomic, because oring in other-pointer-lowtag just adds
+ ;; it right back.
+ ;;
+ ;; This looks like another dreadful type pun. CSR - 2002-02-06
+ (inst or result alloc-tn other-pointer-lowtag)
+ (inst add alloc-tn boxed)
+ (inst add alloc-tn unboxed)
+ (inst sll ndescr boxed (- n-widetag-bits word-shift))
+ (inst or ndescr code-header-widetag)
+ (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 temp (make-fixup (extern-alien-name "undefined_tramp") :foreign))
+ (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 andn result alloc-tn lowtag-mask)
+ (inst or result fun-pointer-lowtag)
+ (inst li temp (logior (ash (1- size) n-widetag-bits) closure-header-widetag))
+ (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 result unbound-marker-widetag)))
+
+(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))
+ (cond ((logbitp (1- n-lowtag-bits) lowtag)
+ (inst or result alloc-tn lowtag))
+ (t
+ (inst andn result alloc-tn lowtag-mask)
+ (inst or result lowtag)))
+ (when type
+ (inst li temp (logior (ash (1- words) n-widetag-bits) type))
+ (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 add bytes extra (* (1+ words) n-word-bytes))
+ (inst sll header bytes (- n-widetag-bits 2))
+ (inst add header header (+ (ash -2 n-widetag-bits) type))
+ (inst and bytes (lognot lowtag-mask))
+ (pseudo-atomic ()
+ ;; Need to be careful if the lowtag and the pseudo-atomic flag
+ ;; are not compatible.
+ (cond ((logbitp (1- n-lowtag-bits) lowtag)
+ (inst or result alloc-tn lowtag))
+ (t
+ (inst andn result alloc-tn lowtag-mask)
+ (inst or result lowtag)))
+ (storew header result 0 lowtag)
+ (inst add alloc-tn alloc-tn bytes))))
View
1,251 src/compiler/sparc/arith.lisp
@@ -0,0 +1,1251 @@
+;;;; the VM definition arithmetic VOPs for the Alpha
+
+;;;; 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")
+
+;;;; unary operations.
+
+(define-vop (fast-safe-arith-op)
+ (:policy :fast-safe)
+ (:effects)
+ (:affected))
+
+(define-vop (fixnum-unop fast-safe-arith-op)
+ (:args (x :scs (any-reg)))
+ (:results (res :scs (any-reg)))
+ (:note "inline fixnum arithmetic")
+ (:arg-types tagged-num)
+ (:result-types tagged-num))
+
+(define-vop (signed-unop fast-safe-arith-op)
+ (:args (x :scs (signed-reg)))
+ (:results (res :scs (signed-reg)))
+ (:note "inline (signed-byte 32) arithmetic")
+ (:arg-types signed-num)
+ (:result-types signed-num))
+
+(define-vop (fast-negate/fixnum fixnum-unop)
+ (:translate %negate)
+ (:generator 1
+ (inst neg res x)))
+
+(define-vop (fast-negate/signed signed-unop)
+ (:translate %negate)
+ (:generator 2
+ (inst neg res x)))
+
+(define-vop (fast-lognot/fixnum fixnum-unop)
+ (:translate lognot)
+ (:generator 2
+ (inst xor res x (fixnumize -1))))
+
+(define-vop (fast-lognot/signed signed-unop)
+ (:translate lognot)
+ (:generator 1
+ (inst not res x)))
+
+;;;; Binary fixnum operations.
+
+;;; Assume that any constant operand is the second arg...
+
+(define-vop (fast-fixnum-binop fast-safe-arith-op)
+ (:args (x :target r :scs (any-reg zero))
+ (y :target r :scs (any-reg zero)))
+ (:arg-types tagged-num tagged-num)
+ (:results (r :scs (any-reg)))
+ (:result-types tagged-num)
+ (:note "inline fixnum arithmetic"))
+
+(define-vop (fast-unsigned-binop fast-safe-arith-op)
+ (:args (x :target r :scs (unsigned-reg zero))
+ (y :target r :scs (unsigned-reg zero)))
+ (:arg-types unsigned-num unsigned-num)
+ (:results (r :scs (unsigned-reg)))
+ (:result-types unsigned-num)
+ (:note "inline (unsigned-byte 32) arithmetic"))
+
+(define-vop (fast-signed-binop fast-safe-arith-op)
+ (:args (x :target r :scs (signed-reg zero))
+ (y :target r :scs (signed-reg zero)))
+ (:arg-types signed-num signed-num)
+ (:results (r :scs (signed-reg)))
+ (:result-types signed-num)
+ (:note "inline (signed-byte 32) arithmetic"))
+
+
+(define-vop (fast-fixnum-binop-c fast-safe-arith-op)
+ (:args (x :target r :scs (any-reg zero)))
+ (:info y)
+ (:arg-types tagged-num
+ (:constant (and (signed-byte 11) (not (integer 0 0)))))
+ (:results (r :scs (any-reg)))
+ (:result-types tagged-num)
+ (:note "inline fixnum arithmetic"))
+
+(define-vop (fast-unsigned-binop-c fast-safe-arith-op)
+ (:args (x :target r :scs (unsigned-reg zero)))
+ (:info y)
+ (:arg-types unsigned-num
+ (:constant (and (signed-byte 13) (not (integer 0 0)))))
+ (:results (r :scs (unsigned-reg)))
+ (:result-types unsigned-num)
+ (:note "inline (unsigned-byte 32) arithmetic"))
+
+(define-vop (fast-signed-binop-c fast-safe-arith-op)
+ (:args (x :target r :scs (signed-reg zero)))
+ (:info y)
+ (:arg-types signed-num
+ (:constant (and (signed-byte 13) (not (integer 0 0)))))
+ (:results (r :scs (signed-reg)))
+ (:result-types signed-num)
+ (:note "inline (signed-byte 32) arithmetic"))
+
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+(defmacro define-binop (translate untagged-penalty op)
+ `(progn
+ (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
+ fast-fixnum-binop)
+ (:translate ,translate)
+ (:generator 2
+ (inst ,op r x y)))
+ (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
+ fast-fixnum-binop-c)
+ (:translate ,translate)
+ (:generator 1
+ (inst ,op r x (fixnumize y))))
+ (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
+ fast-signed-binop)
+ (:translate ,translate)
+ (:generator ,(1+ untagged-penalty)
+ (inst ,op r x y)))
+ (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
+ fast-signed-binop-c)
+ (:translate ,translate)
+ (:generator ,untagged-penalty
+ (inst ,op r x y)))
+ (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED")
+ fast-unsigned-binop)
+ (:translate ,translate)
+ (:generator ,(1+ untagged-penalty)
+ (inst ,op r x y)))
+ (define-vop (,(symbolicate 'fast- translate '-c/unsigned=>unsigned)
+ fast-unsigned-binop-c)
+ (:translate ,translate)
+ (:generator ,untagged-penalty
+ (inst ,op r x y)))))
+
+); eval-when
+
+(define-binop + 4 add)
+(define-binop - 4 sub)
+(define-binop logand 2 and)
+(define-binop logandc2 2 andn)
+(define-binop logior 2 or)
+(define-binop logorc2 2 orn)
+(define-binop logxor 2 xor)
+(define-binop logeqv 2 xnor)
+
+;;; Special logand cases: (logand signed unsigned) => unsigned
+
+(define-vop (fast-logand/signed-unsigned=>unsigned
+ fast-logand/unsigned=>unsigned)
+ (:args (x :target r :scs (signed-reg))
+ (y :scs (unsigned-reg unsigned-stack)))
+ (:arg-types signed-num unsigned-num))
+
+(define-vop (fast-logand/unsigned-signed=>unsigned
+ fast-logand/unsigned=>unsigned)
+ (:args (x :target r :scs (unsigned-reg))
+ (y :scs (signed-reg signed-stack)))
+ (:arg-types unsigned-num signed-num))
+
+;;; Special case fixnum + and - that trap on overflow. Useful when we
+;;; don't know that the output type is a fixnum.
+
+;;; I (toy@rtp.ericsson.se) took these out. They don't seem to be
+;;; used anywhere at all.
+#+nil
+(progn
+(define-vop (+/fixnum fast-+/fixnum=>fixnum)
+ (:policy :safe)
+ (:results (r :scs (any-reg descriptor-reg)))
+ (:result-types tagged-num)
+ (:note "safe inline fixnum arithmetic")
+ (:generator 4
+ (inst taddcctv r x y)))
+
+(define-vop (+-c/fixnum fast-+-c/fixnum=>fixnum)
+ (:policy :safe)
+ (:results (r :scs (any-reg descriptor-reg)))
+ (:result-types tagged-num)
+ (:note "safe inline fixnum arithmetic")
+ (:generator 3
+ (inst taddcctv r x (fixnumize y))))
+
+(define-vop (-/fixnum fast--/fixnum=>fixnum)
+ (:policy :safe)
+ (:results (r :scs (any-reg descriptor-reg)))
+ (:result-types tagged-num)
+ (:note "safe inline fixnum arithmetic")
+ (:generator 4
+ (inst tsubcctv r x y)))
+
+(define-vop (--c/fixnum fast---c/fixnum=>fixnum)
+ (:policy :safe)
+ (:results (r :scs (any-reg descriptor-reg)))
+ (:result-types tagged-num)
+ (:note "safe inline fixnum arithmetic")
+ (:generator 3
+ (inst tsubcctv r x (fixnumize y))))
+
+)
+
+;;; Truncate
+
+;; This doesn't work for some reason.
+#+nil
+(define-vop (fast-v8-truncate/fixnum=>fixnum fast-safe-arith-op)
+ (:translate truncate)
+ (:args (x :scs (any-reg))
+ (y :scs (any-reg)))
+ (:arg-types tagged-num tagged-num)
+ (:results (quo :scs (any-reg))
+ (rem :scs (any-reg)))
+ (:result-types tagged-num tagged-num)
+ (:note "inline fixnum arithmetic")
+ (:temporary (:scs (any-reg) :target quo) q)
+ (:temporary (:scs (any-reg)) r)
+ (:temporary (:scs (signed-reg)) y-int)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:guard #!+(or :sparc-v8 (and :sparc-v9 (not :sparc-64))) t
+ #!-(or :sparc-v8 (and :sparc-v9 (not :sparc-64))) nil)
+ (:generator 12
+ (let ((zero (generate-error-code vop division-by-zero-error x y)))
+ (inst cmp y zero-tn)
+ (inst b :eq zero)
+ ;; Extend the sign of X into the Y register
+ (inst sra r x 31)
+ (inst wry r)
+ ;; Remove tag bits so Q and R will be tagged correctly.
+ (inst sra y-int y fixnum-tag-bits)
+ (inst nop)
+ (inst nop)
+
+ (inst sdiv q x y-int) ; Q is tagged.
+ ;; We have the quotient so we need to compute the remainder
+ (inst smul r q y-int) ; R is tagged
+ (inst sub rem x r)
+ (unless (location= quo q)
+ (move quo q)))))
+
+(define-vop (fast-v8-truncate/signed=>signed fast-safe-arith-op)
+ (:translate truncate)
+ (:args (x :scs (signed-reg))
+ (y :scs (signed-reg)))
+ (:arg-types signed-num signed-num)
+ (:results (quo :scs (signed-reg))
+ (rem :scs (signed-reg)))
+ (:result-types signed-num signed-num)
+ (:note "inline (signed-byte 32) arithmetic")
+ (:temporary (:scs (signed-reg) :target quo) q)
+ (:temporary (:scs (signed-reg)) r)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:guard #!+(or :sparc-v8 (and :sparc-v9 (not :sparc-64))) t
+ #!-(or :sparc-v8 (and :sparc-v9 (not :sparc-64))) nil)
+ (:generator 12
+ (let ((zero (generate-error-code vop division-by-zero-error x y)))
+ (inst cmp y zero-tn)
+ (inst b :eq zero #!+:sparc-v9 :pn)
+ ;; Extend the sign of X into the Y register
+ (inst sra r x 31)
+ (inst wry r)
+ (inst nop)
+ (inst nop)
+ (inst nop)
+
+ (inst sdiv q x y)
+ ;; We have the quotient so we need to compue the remainder
+ (inst smul r q y) ; rem
+ (inst sub rem x r)
+ (unless (location= quo q)
+ (move quo q)))))
+
+(define-vop (fast-v8-truncate/unsigned=>unsigned fast-safe-arith-op)
+ (:translate truncate)
+ (:args (x :scs (unsigned-reg))
+ (y :scs (unsigned-reg)))
+ (:arg-types unsigned-num unsigned-num)
+ (:results (quo :scs (unsigned-reg))
+ (rem :scs (unsigned-reg)))
+ (:result-types unsigned-num unsigned-num)
+ (:note "inline (unsigned-byte 32) arithmetic")
+ (:temporary (:scs (unsigned-reg) :target quo) q)
+ (:temporary (:scs (unsigned-reg)) r)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:guard #!+(or :sparc-v8 (and :sparc-v9 (not :sparc-64))) t
+ #!-(or :sparc-v8 (and :sparc-v9 (not :sparc-64))) nil)
+ (:generator 8
+ (let ((zero (generate-error-code vop division-by-zero-error x y)))
+ (inst cmp y zero-tn)
+ (inst b :eq zero #!+:sparc-v9 :pn)
+ (inst wry zero-tn) ; Clear out high part
+ (inst nop)
+ (inst nop)
+ (inst nop)
+
+ (inst udiv q x y)
+ ;; Compute remainder
+ (inst umul r q y)
+ (inst sub rem x r)
+ (unless (location= quo q)
+ (inst move quo q)))))
+
+#!+:sparc-v9
+(define-vop (fast-v9-truncate/signed=>signed fast-safe-arith-op)
+ (:translate truncate)
+ (:args (x :scs (signed-reg))
+ (y :scs (signed-reg)))
+ (:arg-types signed-num signed-num)
+ (:results (quo :scs (signed-reg))
+ (rem :scs (signed-reg)))
+ (:result-types signed-num signed-num)
+ (:note "inline (signed-byte 32) arithmetic")
+ (:temporary (:scs (signed-reg) :target quo) q)
+ (:temporary (:scs (signed-reg)) r)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:guard #!+:sparc-64 t #!-:sparc-64 nil)
+ (:generator 8
+ (let ((zero (generate-error-code vop division-by-zero-error x y)))
+ (inst cmp y zero-tn)
+ (inst b :eq zero #!+:sparc-v9 :pn)
+ ;; Sign extend the numbers, just in case.
+ (inst sra x 0)
+ (inst sra y 0)
+ (inst sdivx q x y)
+ ;; Compute remainder
+ (inst mulx r q y)
+ (inst sub rem x r)
+ (unless (location= quo q)
+ (inst move quo q)))))
+
+(define-vop (fast-v9-truncate/unsigned=>unsigned fast-safe-arith-op)
+ (:translate truncate)
+ (:args (x :scs (unsigned-reg))
+ (y :scs (unsigned-reg)))
+ (:arg-types unsigned-num unsigned-num)
+ (:results (quo :scs (unsigned-reg))
+ (rem :scs (unsigned-reg)))
+ (:result-types unsigned-num unsigned-num)
+ (:note "inline (unsigned-byte 32) arithmetic")
+ (:temporary (:scs (unsigned-reg) :target quo) q)
+ (:temporary (:scs (unsigned-reg)) r)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:guard #!+:sparc-64 t #!-:sparc-64 nil)
+ (:generator 8
+ (let ((zero (generate-error-code vop division-by-zero-error x y)))
+ (inst cmp y zero-tn)
+ (inst b :eq zero #!+:sparc-v9 :pn)
+ ;; Zap the higher 32 bits, just in case
+ (inst srl x 0)
+ (inst srl y 0)
+ (inst udivx q x y)
+ ;; Compute remainder
+ (inst mulx r q y)
+ (inst sub rem x r)
+ (unless (location= quo q)
+ (inst move quo q)))))
+
+;;; Shifting
+
+(macrolet
+ ((frob (name sc-type type shift-right-inst)
+ `(define-vop (,name)
+ (:note "inline ASH")
+ (:args (number :scs (,sc-type) :to :save)
+ (amount :scs (signed-reg immediate)))
+ (:arg-types ,type signed-num)
+ (:results (result :scs (,sc-type)))
+ (:result-types ,type)
+ (:translate ash)
+ (:policy :fast-safe)
+ (:temporary (:sc non-descriptor-reg) ndesc)
+ (:generator 5
+ (sc-case amount
+ #!+:sparc-v9
+ (signed-reg
+ (let ((done (gen-label))
+ (positive (gen-label)))
+ (inst cmp amount)
+ (inst b :ge positive)
+ (inst neg ndesc amount)
+ ;; ndesc = max(-amount, 31)
+ (inst cmp ndesc 31)
+ (inst cmove :ge ndesc 31)
+ (inst b done)
+ (inst ,shift-right-inst result number ndesc)
+ (emit-label positive)
+ ;; The result-type assures us that this shift will not
+ ;; overflow.
+ (inst sll result number amount)
+ ;; We want a right shift of the appropriate size.
+ (emit-label done)))
+ #!-:sparc-v9
+ (signed-reg
+ (let ((positive (gen-label))
+ (done (gen-label)))
+ (inst cmp amount)
+ (inst b :ge positive)
+ (inst neg ndesc amount)
+ (inst cmp ndesc 31)
+ (inst b :le done)
+ (inst ,shift-right-inst result number ndesc)
+ (inst b done)
+ (inst ,shift-right-inst result number 31)
+
+ (emit-label positive)
+ ;; The result-type assures us that this shift will not overflow.
+ (inst sll result number amount)
+
+ (emit-label done)))
+ (immediate
+ (let ((amount (tn-value amount)))
+ (if (minusp amount)
+ (let ((amount (min 31 (- amount))))
+ (inst ,shift-right-inst result number amount))
+ (inst sll result number amount)))))))))
+ (frob fast-ash/signed=>signed signed-reg signed-num sra)
+ (frob fast-ash/unsigned=>unsigned unsigned-reg unsigned-num srl))
+
+;; Some special cases where we know we want a left shift. Just do the
+;; shift, instead of checking for the sign of the shift.
+(macrolet
+ ((frob (name sc-type type result-type cost)
+ `(define-vop (,name)
+ (:note "inline ASH")
+ (:translate ash)
+ (:args (number :scs (,sc-type))
+ (amount :scs (signed-reg unsigned-reg immediate)))
+ (:arg-types ,type positive-fixnum)
+ (:results (result :scs (,result-type)))
+ (:result-types ,type)
+ (:policy :fast-safe)
+ (:generator ,cost
+ ;; The result-type assures us that this shift will not
+ ;; overflow. And for fixnum's, the zero bits that get
+ ;; shifted in are just fine for the fixnum tag.
+ (sc-case amount
+ ((signed-reg unsigned-reg)
+ (inst sll result number amount))
+ (immediate
+ (let ((amount (tn-value amount)))
+ (assert (>= amount 0))
+ (inst sll result number amount))))))))
+ (frob fast-ash-left/signed=>signed signed-reg signed-num signed-reg 3)
+ (frob fast-ash-left/fixnum=>fixnum any-reg tagged-num any-reg 2)
+ (frob fast-ash-left/unsigned=>unsigned unsigned-reg unsigned-num unsigned-reg 3))
+
+(defknown ash-right-signed ((signed-byte #.sb!vm:n-word-bits)
+ (and fixnum unsigned-byte))
+ (signed-byte #.sb!vm:n-word-bits)
+ (movable foldable flushable))
+
+(defknown ash-right-unsigned ((unsigned-byte #.sb!vm:n-word-bits)
+ (and fixnum unsigned-byte))
+ (unsigned-byte #.sb!vm:n-word-bits)
+ (movable foldable flushable))
+
+;; Some special cases where we want a right shift. Just do the shift.
+;; (Needs appropriate deftransforms to call these, though.)
+
+(macrolet
+ ((frob (trans name sc-type type shift-inst cost)
+ `(define-vop (,name)
+ (:note "inline right ASH")
+ (:translate ,trans)
+ (:args (number :scs (,sc-type))
+ (amount :scs (signed-reg unsigned-reg immediate)))
+ (:arg-types ,type positive-fixnum)
+ (:results (result :scs (,sc-type)))
+ (:result-types ,type)
+ (:policy :fast-safe)
+ (:generator ,cost
+ (sc-case amount
+ ((signed-reg unsigned-reg)
+ (inst ,shift-inst result number amount))
+ (immediate
+ (let ((amt (tn-value amount)))
+ (inst ,shift-inst result number amt))))))))
+ (frob ash-right-signed fast-ash-right/signed=>signed
+ signed-reg signed-num sra 3)
+ (frob ash-right-unsigned fast-ash-right/unsigned=>unsigned
+ unsigned-reg unsigned-num srl 3))
+
+(define-vop (fast-ash-right/fixnum=>fixnum)
+ (:note "inline right ASH")
+ (:translate ash-right-signed)
+ (:args (number :scs (any-reg))
+ (amount :scs (signed-reg unsigned-reg immediate)))
+ (:arg-types tagged-num positive-fixnum)
+ (:results (result :scs (any-reg)))
+ (:result-types tagged-num)
+ (:temporary (:sc non-descriptor-reg :target result) temp)
+ (:policy :fast-safe)
+ (:generator 2
+ ;; Shift the fixnum right by the desired amount. Then zap out the
+ ;; 2 LSBs to make it a fixnum again. (Those bits are junk.)
+ (sc-case amount
+ ((signed-reg unsigned-reg)
+ (inst sra temp number amount))
+ (immediate
+ (inst sra temp number (tn-value amount))))
+ (inst andn result temp fixnum-tag-mask)))
+
+
+
+
+(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
+ (let ((loop (gen-label))
+ (test (gen-label)))
+ (inst addcc shift zero-tn arg)
+ (inst b :ge test)
+ (move res zero-tn)
+ (inst b test)
+ (inst not shift)
+
+ (emit-label loop)
+ (inst add res (fixnumize 1))
+
+ (emit-label test)
+ (inst cmp shift)
+ (inst b :ne loop)
+ (inst srl shift 1))))
+
+(define-vop (unsigned-byte-32-count)
+ (:translate logcount)
+ (:note "inline (unsigned-byte 32) logcount")
+ (:policy :fast-safe)
+ (:args (arg :scs (unsigned-reg)))
+ (:arg-types unsigned-num)
+ (:results (res :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) mask temp)
+ (:generator 35
+ (move res arg)
+
+ (dolist (stuff '((1 #x55555555) (2 #x33333333) (4 #x0f0f0f0f)
+ (8 #x00ff00ff) (16 #x0000ffff)))
+ (destructuring-bind (shift bit-mask)
+ stuff
+ ;; Set mask
+ (inst sethi mask (ldb (byte 22 10) bit-mask))
+ (inst add mask (ldb (byte 10 0) bit-mask))
+
+ (inst and temp res mask)
+ (inst srl res shift)
+ (inst and res mask)
+ (inst add res temp)))))
+