Raymond Toy pushed to branch master at cmucl / cmucl
Commits: e5c415bd by Raymond Toy at 2016-12-11T10:01:42-08:00 Forgot to remove the original assembly/sparcv9 files.
These were moved to assembly/sparc64.
- - - - - 0f4c649a by Raymond Toy at 2016-12-11T10:05:01-08:00 Default motif_variant for sparc64_sunc
Make motif variant default to solaris_sunc when sparc64_sunc is the lisp variant.
- - - - -
6 changed files:
- bin/create-target.sh - − src/assembly/sparcv9/alloc.lisp - − src/assembly/sparcv9/arith.lisp - − src/assembly/sparcv9/array.lisp - − src/assembly/sparcv9/assem-rtns.lisp - − src/assembly/sparcv9/support.lisp
Changes:
===================================== bin/create-target.sh ===================================== --- a/bin/create-target.sh +++ b/bin/create-target.sh @@ -78,7 +78,7 @@ case $uname_s in OpenBSD*) motif_variant=OpenBSD ;; *_darwin) motif_variant=Darwin ;; sun4_solaris_gcc|sparc_gcc) motif_variant=solaris ;; - sun4_solaris_sunc|sparc_sunc|x86_solaris_sunc) motif_variant=solaris_sunc ;; + sun4_solaris_sunc|sparc_sunc|x86_solaris_sunc|sparc64_sunc) motif_variant=solaris_sunc ;; sun4c*) motif_variant=sun4c_411 ;; hp700*) motif_variant=hpux_cc ;; pmax_mach) motif_variant=pmax_mach ;;
===================================== src/assembly/sparcv9/alloc.lisp deleted ===================================== --- a/src/assembly/sparcv9/alloc.lisp +++ /dev/null @@ -1,19 +0,0 @@ -;;; -*- Package: SPARC -*- -;;; -;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public domain. -;;; -(ext:file-comment - "$Header: src/assembly/sparc/alloc.lisp $") -;;; -;;; ********************************************************************** -;;; -;;; Stuff to handle allocating simple objects. -;;; -;;; Written by William Lott. -;;; - -(in-package "SPARC") - -;;; But we do everything inline now that we have a better pseudo-atomic.
===================================== src/assembly/sparcv9/arith.lisp deleted ===================================== --- a/src/assembly/sparcv9/arith.lisp +++ /dev/null @@ -1,364 +0,0 @@ -;;; -*- Package: SPARC -*- -;;; -;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public domain. -;;; -(ext:file-comment - "$Header: src/assembly/sparc/arith.lisp $") -;;; -;;; ********************************************************************** -;;; -;;; Stuff to handle simple cases for generic arithmetic. -;;; -;;; Written by William Lott. -;;; - -(in-package "SPARC") - - - -;;;; 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-type (1+ bignum-digits-offset)) - (storew temp2 res bignum-digits-offset other-pointer-type)) - (lisp-return lra :offset 2) - - DO-STATIC-FUN - (inst ld code-tn null-tn (static-function-offset 'two-arg-+)) - (inst li nargs (fixnumize 2)) - (inst move ocfp cfp-tn) - (inst j code-tn - (- (* function-code-offset word-bytes) function-pointer-type)) - (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-type (1+ bignum-digits-offset)) - (storew temp2 res bignum-digits-offset other-pointer-type)) - (lisp-return lra :offset 2) - - DO-STATIC-FUN - (inst ld code-tn null-tn (static-function-offset 'two-arg--)) - (inst li nargs (fixnumize 2)) - (inst move ocfp cfp-tn) - (inst j code-tn - (- (* function-code-offset word-bytes) function-pointer-type)) - (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. - (cond ((backend-featurep :sparc-64) - ;; Sign extend y to a full 64-bits. temp was already - ;; sign-extended by the sra instruction above. - (inst sra y 0) - (inst mulx hi temp y) - (inst move lo hi) - (inst srax hi 32)) - ((or (backend-featurep :sparc-v8) - (backend-featurep :sparc-v9)) - (inst smul lo temp y) - (inst rdy hi)) - (t - (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. We 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-type (+ 2 bignum-digits-offset)) - (let ((one-word (gen-label))) - ;; 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 type-bits) bignum-type)) - ;; Need 2 words. Set the header appropriately, and save the - ;; high and low parts. - (inst li temp (logior (ash 2 type-bits) bignum-type)) - (storew hi res (1+ bignum-digits-offset) other-pointer-type) - (emit-label one-word) - (storew temp res 0 other-pointer-type) - (storew lo res bignum-digits-offset other-pointer-type))) - ;; Out of here - (lisp-return lra :offset 2) - - DO-STATIC-FUN - (inst ld code-tn null-tn (static-function-offset 'two-arg-*)) - (inst li nargs (fixnumize 2)) - (inst move ocfp cfp-tn) - (inst j code-tn - (- (* function-code-offset word-bytes) function-pointer-type)) - (inst move cfp-tn csp-tn) - - LOW-FITS-IN-FIXNUM - (move res lo)) - - -;;;; 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-function-offset ',static-fn)) - (inst li nargs (fixnumize 2)) - (inst move ocfp cfp-tn) - (inst j code-tn - (- (* function-code-offset word-bytes) function-pointer-type)) - (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-function-offset 'eql)) - (inst li nargs (fixnumize 2)) - (inst move ocfp cfp-tn) - (inst j code-tn - (- (* function-code-offset word-bytes) function-pointer-type)) - (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-function-offset 'two-arg-=)) - (inst li nargs (fixnumize 2)) - (inst move ocfp cfp-tn) - (inst j code-tn - (- (* function-code-offset word-bytes) function-pointer-type)) - (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-function-offset 'two-arg-=)) - (inst li nargs (fixnumize 2)) - (inst move ocfp cfp-tn) - (inst j code-tn - (- (* function-code-offset word-bytes) function-pointer-type)) - (inst move cfp-tn csp-tn) - - RETURN-NIL - (inst move res null-tn))
===================================== src/assembly/sparcv9/array.lisp deleted ===================================== --- a/src/assembly/sparcv9/array.lisp +++ /dev/null @@ -1,169 +0,0 @@ -;;; -*- Package: SPARC -*- -;;; -;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public domain. -;;; -(ext:file-comment - "$Header: src/assembly/sparc/array.lisp $") -;;; -;;; ********************************************************************** -;;; -;;; $Header: src/assembly/sparc/array.lisp $ -;;; -;;; This file contains the support routines for arrays and vectors. -;;; -;;; Written by William Lott. -;;; -(in-package "SPARC") - - -(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 gc-temp non-descriptor-reg nl1-offset) - (:temp vector descriptor-reg a3-offset)) - (pseudo-atomic () - (inst add ndescr words (* (1+ vm:vector-data-offset) vm:word-bytes)) - (inst andn ndescr vm:lowtag-mask) - (allocation vector ndescr other-pointer-type :temp-tn gc-temp) - #+gencgc - (progn - ;; ndescr points to one word past the end of the allocated - ;; space. Fill the last word with a zero. - (inst add ndescr vector) - (storew zero-tn ndescr -1 vm:other-pointer-type)) - (inst srl ndescr type vm:word-shift) - (storew ndescr vector 0 vm:other-pointer-type) - (storew length vector vm:vector-length-slot vm:other-pointer-type)) - ;; 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. - ;; - ;; This used to write to the word after the last allocated word. I - ;; (RLT) made it write to the last allocated word, which is where - ;; the zero-byte of the string is. Look at the deftransform for - ;; make-array in array-tran.lisp. For strings we always allocate - ;; enough space to hold the zero-byte. - #-gencgc - (storew zero-tn alloc-tn -1) - (move result vector)) - - - -;;;; Hash primitives - -#+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 vm:vector-length-slot vm:other-pointer-type)) - - -;; Implement the one-at-a-time algorithm designed by Bob Jenkins -;; (see http://burtleburtle.net/bob/hash/doobs.html for some -;; more information). -;; -;; For completeness, here is the hash function, in C, from that web -;; page. ub4 is an unsigned 32-bit integer. - -#|| -ub4 one_at_a_time(char *key, ub4 len) -{ - ub4 hash, i; - for (hash=0, i=0; i<len; ++i) - { - hash += key[i]; - hash += (hash << 10); - hash ^= (hash >> 6); - } - hash += (hash << 3); - hash ^= (hash >> 11); - hash += (hash << 15); - return (hash & mask); -} - -||# - - -(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) - - #+unicode - (inst sll length 1) ; Number of bytes = twice the length - - (inst li offset (- (* vector-data-offset word-bytes) other-pointer-type)) - (inst b test) - (move accum zero-tn) - - LOOP - - ;; hash += key[i] - (inst add accum data) - ;; hash += (hash << 10) - (inst slln temp accum 10) - (inst add accum temp) - ;; hash ^= (hash >> 6) - (inst srln temp accum 6) - (inst xor accum temp) - (inst add offset 1) - - TEST - - (inst subcc length (fixnumize 1)) - (inst b :ge loop) - (inst ldub data string offset) - - ;; hash += (hash << 3) - (inst slln temp accum 3) - (inst add accum temp) - ;; hash ^= (hash >> 11) - (inst srln temp accum 11) - (inst xor accum temp) - ;; hash += (hash << 15) - (inst slln temp accum 15) - (inst add accum temp) - - ;;(inst li temp most-positive-fixnum) - ;;(inst and accum temp) - ;; Make it a fixnum result - - ;; Make the result a positive fixnum. Shifting it left, then right - ;; does what we want, and extracts the bits we need. - (inst slln accum (1+ vm:fixnum-tag-bits)) - (inst srln result accum 1))
===================================== src/assembly/sparcv9/assem-rtns.lisp deleted ===================================== --- a/src/assembly/sparcv9/assem-rtns.lisp +++ /dev/null @@ -1,311 +0,0 @@ -;;; -*- Package: SPARC -*- -;;; -;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public domain. -;;; -(ext:file-comment - "$Header: src/assembly/sparc/assem-rtns.lisp $") -;;; -;;; ********************************************************************** -;;; -;;; $Header: src/assembly/sparc/assem-rtns.lisp $ -;;; -;;; -(in-package "SPARC") - - -;;;; Return-multiple with other than one value - -#+assembler ;; 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 cname-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 vm:word-bytes)) - (inst cmp nvals (fixnumize 3)) - (inst b :le default-a3-and-on) - (inst ld a2 vals (* 2 vm:word-bytes)) - (inst cmp nvals (fixnumize 4)) - (inst b :le default-a4-and-on) - (inst ld a3 vals (* 3 vm:word-bytes)) - (inst cmp nvals (fixnumize 5)) - (inst b :le default-a5-and-on) - (inst ld a4 vals (* 4 vm:word-bytes)) - (inst cmp nvals (fixnumize 6)) - (inst b :le done) - (inst ld a5 vals (* 5 vm:word-bytes)) - - ;; Copy the remaining args to the top of the stack. - (inst add src vals (* 6 vm:word-bytes)) - (inst add dst cfp-tn (* 6 vm:word-bytes)) - (inst subcc count nvals (fixnumize 6)) - - LOOP - (inst ld temp src) - (inst add src vm:word-bytes) - (inst st temp dst) - (inst add dst vm: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. - -#+assembler ;; 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 cname-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 vm:word-bytes)) - (inst ld a1 args (* 1 vm:word-bytes)) - (inst ld a2 args (* 2 vm:word-bytes)) - (inst ld a3 args (* 3 vm:word-bytes)) - (inst ld a4 args (* 4 vm:word-bytes)) - (inst ld a5 args (* 5 vm:word-bytes)) - - ;; Calc SRC, DST, and COUNT - (inst addcc count nargs (fixnumize (- register-arg-count))) - (inst b :le done) - (inst add src args (* vm:word-bytes register-arg-count)) - (inst add dst cfp-tn (* vm:word-bytes register-arg-count)) - - LOOP - ;; Copy one arg. - (inst ld temp src) - (inst add src src vm:word-bytes) - (inst st temp dst) - (inst addcc count (fixnumize -1)) - (inst b :gt loop) - (inst add dst dst vm:word-bytes) - - DONE - ;; We are done. Do the jump. - (loadw temp lexenv vm:closure-function-slot vm:function-pointer-type) - (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 lisp::*current-unwind-protect-block*) - (loadw target-uwp block vm: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 vm:unwind-block-current-cont-slot) - (loadw code-tn cur-uwp vm:unwind-block-current-code-slot) - (loadw lra cur-uwp vm:unwind-block-entry-pc-slot) - (lisp-return lra :frob-code nil) - - DO-UWP - - (loadw next-uwp cur-uwp vm:unwind-block-current-uwp-slot) - (inst b do-exit) - (store-symbol-value next-uwp lisp::*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 lisp::*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 vm:catch-block-tag-slot) - (inst cmp tag target) - (inst b :eq exit) - (inst nop) - (loadw catch catch vm: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)) - - - - -;; Assembly routines for undefined_tramp and closure_tramp - -#+assembler -(define-assembly-routine (closure-tramp-function-alignment - (:return-style :none)) - () - ;; Align to a dualword and put in the magic function header stuff so - ;; that closure-tramp looks like a normal function with a function - ;; tag. - (align vm:lowtag-bits) - (inst byte 0)) - -#+assembler -(define-assembly-routine (closure-tramp - (:return-style :none)) - () - (inst byte 0) - (inst byte 0) - (inst byte vm:function-header-type) - ;; This is supposed to be closure-tramp, not 0. - (inst word 0) - (inst word (kernel:get-lisp-obj-address nil)) - (inst word (kernel:get-lisp-obj-address nil)) - (inst word (kernel:get-lisp-obj-address nil)) - (inst word (kernel:get-lisp-obj-address nil)) - - (loadw lexenv-tn cname-tn fdefn-function-slot other-pointer-type) - (loadw code-tn lexenv-tn closure-function-slot function-pointer-type) - (inst j code-tn (- (* function-code-offset word-bytes) function-pointer-type)) - (inst nop) - ;; Make sure following routine is dual-word aligned - (align vm:lowtag-bits)) - -#+assembler -(define-assembly-routine (undefined-tramp-function-alignment - (:return-style :none)) - () - ;; Align to a dualword and put in the magic function header stuff so - ;; that closure-tramp looks like a normal function with a function - ;; tag. - (align vm:lowtag-bits) - (inst byte 0)) - -#+assembler -(define-assembly-routine (undefined-tramp - (:return-style :none)) - () - (inst byte 0) - (inst byte 0) - (inst byte vm:function-header-type) - ;; This is supposed to be undefined-tramp, not 0. - (inst word 0) - (inst word (kernel:get-lisp-obj-address nil)) - (inst word (kernel:get-lisp-obj-address nil)) - (inst word (kernel:get-lisp-obj-address nil)) - (inst word (kernel:get-lisp-obj-address nil)) - - (let ((error (generate-cerror-code nil undefined-symbol-error cname-tn))) - (inst b error) - (inst nop) - ;; I don't think we ever return from the undefined-symbol-error - ;; handler, but the assembly code did this so we'll do it too. - (loadw code-tn cname-tn fdefn-raw-addr-slot other-pointer-type) - (inst j code-tn (- (* function-code-offset word-bytes) function-pointer-type)) - (inst nop)))
===================================== src/assembly/sparcv9/support.lisp deleted ===================================== --- a/src/assembly/sparcv9/support.lisp +++ /dev/null @@ -1,78 +0,0 @@ -;;; -*- Package: SPARC -*- -;;; -;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public domain. -;;; -(ext:file-comment - "$Header: src/assembly/sparc/support.lisp $") -;;; -;;; ********************************************************************** -;;; -(in-package "SPARC") - -(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 *backend*) - :offset lip-offset) - 8) - (inst nop))) - (:full-call - `((lisp-return (make-random-tn :kind :normal - :sc (sc-or-lose 'descriptor-reg *backend*) - :offset lra-offset) - :offset 2))) - (:none)))
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/7f62ee97f9d815eeb37c5bfd5...