Commit e75c8d39 authored by cvs2git's avatar cvs2git
Browse files

This commit was manufactured by cvs2svn to create branch 'intl-2-branch'.

parents 105e3cce 0d769677 24d534c3

BUILDING

0 → 100644
+670 −0

File added.

Preview size limit exceeded, changes collapsed.

assembly/alpha/alloc.lisp

0 → 100644
+22 −0
Original line number Diff line number Diff line 
;;; -*- Package: ALPHA -*-

;;;

;;; **********************************************************************

;;; 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: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/alpha/alloc.lisp,v 1.2 1994/10/31 04:55:55 ram Rel $")

;;;

;;; **********************************************************************

;;;

;;; Stuff to handle allocation of stuff we don't want to do inline.

;;;

;;; Written by William Lott.

;;;



(in-package "ALPHA")



;;; 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.

assembly/alpha/arith.lisp

0 → 100644
+426 −0
Original line number Diff line number Diff line 
;;; -*- Package: ALPHA -*-

;;;

;;; **********************************************************************

;;; 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: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/alpha/arith.lisp,v 1.5 2003/08/03 11:27:52 gerd Rel $")

;;;

;;; **********************************************************************

;;;

;;; Stuff to handle simple cases for generic arithmetic.

;;;

;;; Written by William Lott.

;;; Conversion by Sean Hallgren

;;;



(in-package "ALPHA")





(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 temp3 non-descriptor-reg nl2-offset)

			  (:temp lip interior-reg lip-offset)

			  (:temp lra descriptor-reg lra-offset)

			  (:temp nargs any-reg nargs-offset)

			  (:temp ocfp any-reg ocfp-offset))

  (inst and x 3 temp)

  (inst bne temp DO-STATIC-FUN)

  (inst and y 3 temp)

  (inst bne temp DO-STATIC-FUN)

  (inst addq x y res)

  

  ; Check to see if we need a bignum

  (inst sra res 31 temp)

  (inst beq temp DONE)

  (inst not temp temp)

  (inst beq temp DONE)

  (inst sra res 2 temp3)

  

  ; From move-from-signed

  (inst li 2 temp2)

  (inst sra temp3 31 temp)

  (inst cmoveq temp 1 temp2)

  (inst not temp temp)

  (inst cmoveq temp 1 temp2)

  (inst sll temp2 type-bits temp2)

  (inst bis temp2 bignum-type temp2)

  

  (pseudo-atomic (:extra (pad-data-block (+ bignum-digits-offset 3)))

    (inst bis alloc-tn other-pointer-type res)

    (storew temp2 res 0 other-pointer-type)

    (storew temp3 res bignum-digits-offset other-pointer-type)

    (inst srl temp3 32 temp)

    (storew temp res (1+ bignum-digits-offset) other-pointer-type))

  DONE

  (lisp-return lra lip :offset 2)



  DO-STATIC-FUN

  (inst ldl lip (static-function-offset 'two-arg-+) null-tn)

  (inst li (fixnumize 2) nargs)

  (inst move cfp-tn ocfp)

  (inst move csp-tn cfp-tn)

  (inst jmp zero-tn lip))





(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 temp3 non-descriptor-reg nl2-offset)

			  (:temp lip interior-reg lip-offset)

			  (:temp lra descriptor-reg lra-offset)

			  (:temp nargs any-reg nargs-offset)

			  (:temp ocfp any-reg ocfp-offset))

  (inst and x 3 temp)

  (inst bne temp DO-STATIC-FUN)

  (inst and y 3 temp)

  (inst bne temp DO-STATIC-FUN)

  (inst subq x y res)

  

  ; Check to see if we need a bignum

  (inst sra res 31 temp)

  (inst beq temp DONE)

  (inst not temp temp)

  (inst beq temp DONE)

  (inst sra res 2 temp3)

  

  ; From move-from-signed

  (inst li 2 temp2)

  (inst sra temp3 31 temp)

  (inst cmoveq temp 1 temp2)

  (inst not temp temp)

  (inst cmoveq temp 1 temp2)

  (inst sll temp2 type-bits temp2)

  (inst bis temp2 bignum-type temp2)

  

  (pseudo-atomic (:extra (pad-data-block (+ bignum-digits-offset 3)))

    (inst bis alloc-tn other-pointer-type res)

    (storew temp2 res 0 other-pointer-type)

    (storew temp3 res bignum-digits-offset other-pointer-type)

    (inst srl temp3 32 temp)

    (storew temp res (1+ bignum-digits-offset) other-pointer-type))

  DONE

  (lisp-return lra lip :offset 2)



  DO-STATIC-FUN

  (inst ldl lip (static-function-offset 'two-arg--) null-tn)

  (inst li (fixnumize 2) nargs)

  (inst move cfp-tn ocfp)

  (inst move csp-tn cfp-tn)

  (inst jmp zero-tn lip))





(define-assembly-routine (generic-*

			  (:cost 25)

			  (: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 temp2 non-descriptor-reg nl3-offset)

			  (:temp lip interior-reg lip-offset)

			  (:temp lra descriptor-reg lra-offset)

			  (:temp nargs any-reg nargs-offset)

			  (:temp ocfp any-reg ocfp-offset))

  ;; If either arg is not a fixnum, call the static function.

  (inst and x 3 temp)

  (inst bne temp DO-STATIC-FUN)

  (inst and y 3 temp)

  (inst bne temp DO-STATIC-FUN)



  ;; Remove the tag from one arg so that the result will have the correct

  ;; fixnum tag.

  (inst sra x 2 temp)

  (inst mulq temp y lo)

  (inst sra lo 32 hi)

  (inst sll lo 32 res)

  (inst sra res 32 res)

  ;; 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 res 31 temp)

  (inst xor hi temp temp)

  (inst beq temp DONE)

  ;; Shift the double word hi:res down two bits into hi:low to get rid of the

  ;; fixnum tag.

  (inst sra lo 2 lo)

  (inst sra lo 32 hi)



  ;; Do we need one word or two?  Assume two.

  (inst li (logior (ash 2 type-bits) bignum-type) temp2)

  (inst sra lo 31 temp)

  (inst xor temp hi temp)

  (inst bne temp two-words)



  ;; Only need one word, fix the header.

  (inst li (logior (ash 1 type-bits) bignum-type) temp2)

  ;; Allocate one word.

  (pseudo-atomic (:extra (pad-data-block (1+ bignum-digits-offset)))

    (inst bis alloc-tn other-pointer-type res)

    (storew temp2 res 0 other-pointer-type))

  ;; Store one word

  (storew lo res bignum-digits-offset other-pointer-type)

  ;; Out of here

  (lisp-return lra lip :offset 2)



  TWO-WORDS

  ;; Allocate two words.

  (pseudo-atomic (:extra (pad-data-block (+ 2 bignum-digits-offset)))

    (inst bis alloc-tn other-pointer-type res)

    (storew temp2 res 0 other-pointer-type))

  ;; Store two words.

  (storew lo res bignum-digits-offset other-pointer-type)

  (storew hi res (1+ bignum-digits-offset) other-pointer-type)

  ;; Out of here

  (lisp-return lra lip :offset 2)



  DO-STATIC-FUN

  (inst ldl lip (static-function-offset 'two-arg-*) null-tn)

  (inst li (fixnumize 2) nargs)

  (inst move cfp-tn ocfp)

  (inst move csp-tn cfp-tn)

  (inst jmp zero-tn lip)



  DONE)





;;;; Division.



(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 nl3-offset)



			  (:temp quo-sign signed-reg nl5-offset)

			  (:temp rem-sign signed-reg nargs-offset)

			  (:temp temp1 non-descriptor-reg nl4-offset))

  

  (let ((error (generate-error-code nil division-by-zero-error

				    dividend divisor)))

    (inst beq divisor error))



  (inst xor dividend divisor quo-sign)

  (inst move dividend rem-sign)

  (let ((label (gen-label)))

    (inst bge dividend label)

    (inst subq zero-tn dividend dividend)

    (emit-label label))

  (let ((label (gen-label)))

    (inst bge divisor label)

    (inst subq zero-tn divisor divisor)

    (emit-label label))

  (inst move zero-tn rem)

  (inst move zero-tn quo)

  (inst sll dividend 32 dividend)



  (dotimes (i 32)

    (inst srl dividend 63 temp1)

    (inst sll rem 1 rem)

    (inst bis temp1 rem rem)

    (inst cmple divisor rem temp1)

    (inst sll quo 1 quo)

    (inst bis temp1 quo quo)

    (inst sll dividend 1 dividend)

    (inst subq temp1 1 temp1)

    (inst zap divisor temp1 temp1)

    (inst subq rem temp1 rem))



  (let ((label (gen-label)))

    ;; If the quo-sign is negative, we need to negate quo.

    (inst bge quo-sign label)

    (inst subq zero-tn quo quo)

    (emit-label label))

  (let ((label (gen-label)))

    ;; If the rem-sign is negative, we need to negate rem.

    (inst bge rem-sign label)

    (inst subq zero-tn rem rem)

    (emit-label label)))





;;;; Comparison routines.



(macrolet

    ((define-cond-assem-rtn (name translate static-fn cmp not-p)

       `(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 temp non-descriptor-reg nl0-offset)

				  (:temp lip interior-reg lip-offset)

				  (:temp nargs any-reg nargs-offset)

				  (:temp ocfp any-reg ocfp-offset))

	  (inst and x 3 temp)

	  (inst bne temp DO-STATIC-FN)

	  (inst and y 3 temp)

	  (inst beq temp DO-COMPARE)

	  

	  DO-STATIC-FN

	  (inst ldl lip (static-function-offset ',static-fn) null-tn)

	  (inst li (fixnumize 2) nargs)

	  (inst move cfp-tn ocfp)

	  (inst move csp-tn cfp-tn)

	  (inst jmp zero-tn lip)

	  

	  DO-COMPARE

	  ,cmp

	  (inst move null-tn res)

	  (inst ,(if not-p 'bne 'beq) temp done)

	  (load-symbol res t)

	  DONE)))



  (define-cond-assem-rtn generic-< < two-arg-< (inst cmplt x y temp) nil)

  (define-cond-assem-rtn generic-> > two-arg-> (inst cmplt y x temp) nil))





(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 temp non-descriptor-reg nl0-offset)

			  (:temp lip interior-reg lip-offset)

			  (:temp lra descriptor-reg lra-offset)

			  (:temp nargs any-reg nargs-offset)

			  (:temp ocfp any-reg ocfp-offset))

  (inst cmpeq x y temp)

  (inst bne temp RETURN-T)

  (inst and x 3 temp)

  (inst beq temp RETURN-NIL)

  (inst and y 3 temp)

  (inst bne temp DO-STATIC-FN)



  RETURN-NIL

  (inst move null-tn res)

  (lisp-return lra lip :offset 2)



  DO-STATIC-FN

  (inst ldl lip (static-function-offset 'eql) null-tn)

  (inst li (fixnumize 2) nargs)

  (inst move cfp-tn ocfp)

  (inst move csp-tn cfp-tn)

  (inst jmp zero-tn lip)



  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 temp non-descriptor-reg nl0-offset)

			  (:temp lip interior-reg lip-offset)

			  (:temp lra descriptor-reg lra-offset)

			  (:temp nargs any-reg nargs-offset)

			  (:temp ocfp any-reg ocfp-offset))

  (inst and x 3 temp)

  (inst bne temp DO-STATIC-FN)

  (inst and y 3 temp)

  (inst bne temp DO-STATIC-FN)

  (inst cmpeq x y temp)

  (inst bne temp RETURN-T)



  (inst move null-tn res)

  (lisp-return lra lip :offset 2)



  DO-STATIC-FN

  (inst ldl lip (static-function-offset 'two-arg-=) null-tn)

  (inst li (fixnumize 2) nargs)

  (inst move cfp-tn ocfp)

  (inst move csp-tn cfp-tn)

  (inst jmp zero-tn lip)



  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 temp non-descriptor-reg nl0-offset)

			  (:temp lip interior-reg lip-offset)

			  (:temp lra descriptor-reg lra-offset)

			  (:temp nargs any-reg nargs-offset)

			  (:temp ocfp any-reg ocfp-offset))

  (inst and x 3 temp)

  (inst bne temp DO-STATIC-FN)

  (inst and y 3 temp)

  (inst bne temp DO-STATIC-FN)

  (inst cmpeq x y temp)

  (inst bne temp RETURN-NIL)



  (load-symbol res t)

  (lisp-return lra lip :offset 2)



  DO-STATIC-FN

  (inst ldl lip (static-function-offset 'two-arg-=) null-tn)

  (inst li (fixnumize 2) nargs)

  (inst move cfp-tn ocfp)

  (inst move csp-tn cfp-tn)

  (inst jmp zero-tn lip)



  RETURN-NIL

  (inst move null-tn res))

assembly/alpha/array.lisp

0 → 100644
+182 −0
Original line number Diff line number Diff line 
;;; -*- Package: ALPHA -*-

;;;

;;; **********************************************************************

;;; 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: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/alpha/array.lisp,v 1.4 2009/06/11 16:03:55 rtoy Rel $")

;;;

;;; **********************************************************************

;;;

;;;    This file contains the support routines for arrays and vectors.

;;;

;;; Written by William Lott.

;;; Conversion by Sean Hallgren

;;; 

(in-package "ALPHA")



(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))

  ;; This is kinda sleazy, changing words like this.  But we can because

  ;; the vop thinks it is temporary.

  (inst addq words (+ (1- (ash 1 lowtag-bits))

		      (* vector-data-offset word-bytes))

	words)

  (inst li (lognot lowtag-mask) ndescr)

  (inst and words ndescr words)

  (inst srl type word-shift ndescr)



  (pseudo-atomic ()

    (inst bis alloc-tn other-pointer-type result)

    (inst addq alloc-tn words alloc-tn)

    (storew ndescr result 0 other-pointer-type)

    (storew length result vector-length-slot other-pointer-type)))





;;;; Hash primitives



(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 lip interior-reg lip-offset)

			  (:temp accum non-descriptor-reg nl0-offset)

			  (:temp data non-descriptor-reg nl1-offset)

			  (:temp byte non-descriptor-reg nl2-offset)

			  (:temp retaddr non-descriptor-reg nl3-offset)

			  (:temp temp1 non-descriptor-reg nl4-offset))



  ;; These are needed after we jump into sxhash-simple-substring.

  (progn result lip accum data byte  retaddr)



  (inst li (make-fixup 'sxhash-simple-substring :assembly-routine) temp1)

  (loadw length string vector-length-slot other-pointer-type)

  (inst jmp zero-tn temp1

	(make-fixup 'sxhash-simple-substring :assembly-routine)))



(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 lip interior-reg lip-offset)

			  (:temp accum non-descriptor-reg nl0-offset)

			  (:temp data non-descriptor-reg nl1-offset)

			  (:temp byte non-descriptor-reg nl2-offset)

			  (:temp retaddr non-descriptor-reg nl3-offset))



  ;; Save the return address

  (inst subq lip code-tn retaddr)



  ;; Get a pointer to the data.

  (inst addq string

	(- (* vector-data-offset word-bytes) other-pointer-type)

	lip)

  (move zero-tn accum)

  (inst br zero-tn test)



  loop



  (inst and data #xff byte)

  (inst xor accum byte accum)

  (inst sll accum 5 byte)

  (inst srl accum 27 accum)

  (inst mskll accum 4 accum)

  (inst bis accum byte accum)



  (inst srl data 8 byte)

  (inst and byte #xff byte)

  (inst xor accum byte accum)

  (inst sll accum 5 byte)

  (inst srl accum 27 accum)

  (inst mskll accum 4 accum)

  (inst bis accum byte accum)



  (inst srl data 16 byte)

  (inst and byte #xff byte)

  (inst xor accum byte accum)

  (inst sll accum 5 byte)

  (inst srl accum 27 accum)

  (inst mskll accum 4 accum)

  (inst bis accum byte accum)



  (inst srl data 24 byte)

  (inst xor accum byte accum)

  (inst sll accum 5 byte)

  (inst srl accum 27 accum)

  (inst mskll accum 4 accum)

  (inst bis accum byte accum)



  (inst addq lip 4 lip)



  test



  (inst subq length (fixnumize 4) length)

  (inst ldl data 0 lip)

  (inst bge length loop)



  (inst addq length (fixnumize 3) length)

  (inst beq length one-more)

  (inst subq length (fixnumize 1) length)

  (inst beq length two-more)

  (inst bne length done)



  (inst srl data 16 byte)

  (inst and byte #xff byte)

  (inst xor accum byte accum)

  (inst sll accum 5 byte)

  (inst srl accum 27 accum)

  (inst mskll accum 4 accum)

  (inst bis accum byte accum)

  (inst addq length (fixnumize 1) length)



  two-more



  (inst subq length (fixnumize 1) length)

  (inst srl data 8 byte)

  (inst and byte #xff byte)

  (inst xor accum byte accum)

  (inst sll accum 5 byte)

  (inst srl accum 27 accum)

  (inst mskll accum 4 accum)

  (inst bis accum byte accum)

  (inst addq length (fixnumize 1) length)



  one-more



  (inst subq length (fixnumize 1) length)

  (inst and data #xff byte)

  (inst xor accum byte accum)

  (inst sll accum 5 byte)

  (inst srl accum 27 accum)

  (inst mskll accum 4 accum)

  (inst bis accum byte accum)



  done



  (inst sll accum 5 result)

  (inst mskll result 4 result)

  (inst srl result 3 result)



  ;; Restore the return address.

  (inst addq code-tn retaddr lip))

assembly/alpha/assem-rtns.lisp

0 → 100644
+234 −0

File added.

Preview size limit exceeded, changes collapsed.