array.lisp 4.93 KB
Newer Older
wlott's avatar
wlott committed
1 2 3
;;; -*- Package: SPARC -*-
;;;
;;; **********************************************************************
ram's avatar
ram committed
4 5 6 7
;;; 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
8
  "$Header: src/assembly/sparc/array.lisp $")
ram's avatar
ram committed
9
;;;
wlott's avatar
wlott committed
10 11
;;; **********************************************************************
;;;
12
;;; $Header: src/assembly/sparc/array.lisp $
wlott's avatar
wlott committed
13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32
;;;
;;;    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)
33
			  (:temp gc-temp non-descriptor-reg nl1-offset)
wlott's avatar
wlott committed
34
			  (:temp vector descriptor-reg a3-offset))
wlott's avatar
wlott committed
35 36
  (pseudo-atomic ()
    (inst add ndescr words (* (1+ vm:vector-data-offset) vm:word-bytes))
37 38 39 40 41 42 43 44
    (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))
wlott's avatar
wlott committed
45 46 47
    (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))
48 49
  ;; 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.
50 51 52 53 54 55
  ;;
  ;; 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.
56
  #-gencgc
57
  (storew zero-tn alloc-tn -1)
wlott's avatar
wlott committed
58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76
  (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)
77 78
			  (:temp temp non-descriptor-reg nl2-offset)
			  (:temp offset non-descriptor-reg nl3-offset))
wlott's avatar
wlott committed
79

80
  (declare (ignore result accum data temp offset))
wlott's avatar
wlott committed
81 82

  (inst b sxhash-simple-substring-entry)
83
  (loadw length string vm:vector-length-slot vm:other-pointer-type))
wlott's avatar
wlott committed
84 85


86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111
;; 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);
} 

||#


wlott's avatar
wlott committed
112 113 114 115 116 117 118 119 120 121 122
(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)
123 124
			  (:temp temp non-descriptor-reg nl2-offset)
			  (:temp offset non-descriptor-reg nl3-offset))
wlott's avatar
wlott committed
125 126
  (emit-label sxhash-simple-substring-entry)

rtoy's avatar
rtoy committed
127 128 129
  #+unicode
  (inst sll length 1)		  ; Number of bytes = twice the length
  
130
  (inst li offset (- (* vector-data-offset word-bytes) other-pointer-type))
wlott's avatar
wlott committed
131 132 133 134 135
  (inst b test)
  (move accum zero-tn)

  LOOP

136 137 138 139 140 141 142 143 144 145
  ;; 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)
  
wlott's avatar
wlott committed
146 147
  TEST

148
  (inst subcc length (fixnumize 1))
wlott's avatar
wlott committed
149
  (inst b :ge loop)
150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169
  (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))